471 lines
20 KiB
Racket
471 lines
20 KiB
Racket
|
|
(module folderr mzscheme
|
|
(require mzlib/unit
|
|
mzlib/class
|
|
framework
|
|
mred/mred-sig)
|
|
|
|
(require mzlib/list
|
|
mzlib/etc)
|
|
|
|
(require "sirmails.ss"
|
|
"pref.ss")
|
|
|
|
(require net/imap-sig)
|
|
|
|
(require mrlib/hierlist/hierlist-sig)
|
|
|
|
(require openssl/mzssl)
|
|
|
|
(provide folder@)
|
|
(define-unit folder@
|
|
(import sirmail:environment^
|
|
sirmail:shutdown-folder^
|
|
sirmail:options^
|
|
mred^
|
|
imap^
|
|
hierlist^)
|
|
(export)
|
|
|
|
(define (show-error x frame)
|
|
(message-box "Error"
|
|
(if (exn? x)
|
|
(exn-message x)
|
|
(format "Strange exception: ~s" x))
|
|
frame
|
|
'(ok stop)))
|
|
|
|
(define mailbox-cache-file (build-path (LOCAL-DIR) "folder-window-mailboxes"))
|
|
|
|
(define (imap-open-connection)
|
|
(let ([passwd
|
|
(or (get-PASSWORD)
|
|
(let ([p (get-text-from-user "Password"
|
|
(format "Password for ~a:" (USERNAME))
|
|
frame
|
|
""
|
|
'(password))])
|
|
(unless p (raise-user-error 'connect "connection cancelled"))
|
|
p))])
|
|
(let-values ([(server port-no)
|
|
(parse-server-name (IMAP-SERVER) (if (get-pref 'sirmail:use-ssl?) 993 143))])
|
|
(begin0
|
|
(if (get-pref 'sirmail:use-ssl?)
|
|
(let-values ([(in out) (ssl-connect server port-no)])
|
|
(imap-connect* in out (USERNAME) passwd mailbox-name))
|
|
(parameterize ([imap-port-number port-no])
|
|
(imap-connect server (USERNAME)
|
|
passwd
|
|
mailbox-name)))
|
|
(unless (get-PASSWORD)
|
|
(set-PASSWORD passwd))))))
|
|
|
|
(define imap-mailbox-name-mixin
|
|
(lambda (list%)
|
|
(class list%
|
|
(field
|
|
[full-mailbox-name 'unknown-full-mailbox-name]
|
|
[is-selectable? #f])
|
|
[define/public set-full-mailbox-name
|
|
(lambda (fm)
|
|
(set! full-mailbox-name fm))]
|
|
[define/public get-full-mailbox-name
|
|
(lambda ()
|
|
full-mailbox-name)]
|
|
[define/public set-selectable
|
|
(lambda (x) (set! is-selectable? x))]
|
|
[define/public selectable?
|
|
(lambda () is-selectable?)]
|
|
(super-instantiate ()))))
|
|
|
|
(define imap-mailbox-list-mixin
|
|
(lambda (list%)
|
|
(class list%
|
|
(field
|
|
[mailbox-name 'unknown-mailbox-name])
|
|
[define/public get-mailbox-name
|
|
(lambda ()
|
|
mailbox-name)]
|
|
[define/public set-mailbox-name
|
|
(lambda (m)
|
|
(set! mailbox-name m))]
|
|
(super-instantiate ()))))
|
|
|
|
;; mailbox-folder = (make-deep-folder (union #f bytes)
|
|
;; (union #f string)
|
|
;; bool
|
|
;; nested-mailbox-folder)
|
|
;; nested-mailbox-folder =
|
|
;; (union (make-flat-folder bytes (union #f string) bool)
|
|
;; (make-deep-folder bytes (union #f string) bool (listof mailbox-folder)))
|
|
(define-struct folder (name short-name selectable?))
|
|
(define-struct (deep-folder folder) (children))
|
|
(define-struct (flat-folder folder) ())
|
|
|
|
;; refresh-mailboxes : -> void
|
|
(define (refresh-mailboxes)
|
|
(let ([mailboxes (fetch-mailboxes)])
|
|
(when mailboxes
|
|
(write-mailbox-folder mailboxes)
|
|
(update-gui mailboxes))))
|
|
|
|
;; write-mailbox-folder : mailbox-folder -> void
|
|
(define (write-mailbox-folder mbf)
|
|
(let ([raw-datum
|
|
(let loop ([mbf mbf])
|
|
(cond
|
|
[(flat-folder? mbf) (list (folder-name mbf)
|
|
(folder-short-name mbf))]
|
|
[(deep-folder? mbf)
|
|
(list (folder-name mbf)
|
|
(folder-short-name mbf)
|
|
(folder-selectable? mbf)
|
|
(map loop (deep-folder-children mbf)))]
|
|
[else (error 'write-mailbox-folder "unknown mailbox folder: ~e"
|
|
mbf)]))])
|
|
(call-with-output-file mailbox-cache-file
|
|
(lambda (port)
|
|
(write raw-datum port))
|
|
'truncate 'text)))
|
|
|
|
;; read-mailbox-folder : -> mailbox-folder
|
|
(define (read-mailbox-folder)
|
|
(let* ([root-box (ROOT-MAILBOX-FOR-LIST)]
|
|
[default
|
|
(make-deep-folder (and root-box (string->bytes/utf-8 root-box))
|
|
root-box
|
|
#f ;; arbitrary
|
|
null)])
|
|
(if (file-exists? mailbox-cache-file)
|
|
(let/ec k
|
|
(let ([raw-datum (call-with-input-file mailbox-cache-file read 'text)])
|
|
(let loop ([rd raw-datum])
|
|
(cond
|
|
[(and (= 2 (length rd))
|
|
(or (not (car rd)) (bytes? (car rd)))
|
|
(or (not (car rd)) (string? (cadr rd))))
|
|
(make-flat-folder (car rd) (cadr rd) #t)]
|
|
[(and (= 3 (length rd))
|
|
(or (not (car rd)) (bytes? (car rd)))
|
|
(or (not (car rd)) (string? (cadr rd)))
|
|
(list? (caddr rd)))
|
|
(make-deep-folder (car rd)
|
|
(cadr rd)
|
|
#f
|
|
(map loop (caddr rd)))]
|
|
[(and (= 4 (length rd))
|
|
(or (not (car rd)) (bytes? (car rd)))
|
|
(or (not (cadr rd)) (string? (cadr rd)))
|
|
(boolean? (caddr rd))
|
|
(list? (cadddr rd)))
|
|
(make-deep-folder (car rd)
|
|
(cadr rd)
|
|
(caddr rd)
|
|
(map loop (cadddr rd)))]
|
|
[else (k default)]))))
|
|
default)))
|
|
|
|
|
|
;; fetch-mailboxes : -> (union #f mailbox-folder)
|
|
;; gets the current mailbox list from the server
|
|
(define (fetch-mailboxes)
|
|
(with-custodian-killing-stop-button
|
|
"Updating folder list..."
|
|
(lambda ()
|
|
(let-values ([(imap msg-count recent-count) (imap-open-connection)]
|
|
[(root-box) (ROOT-MAILBOX-FOR-LIST)])
|
|
(make-deep-folder
|
|
(and root-box (string->bytes/utf-8 root-box))
|
|
root-box
|
|
#f ;; arbitrary
|
|
(let loop ([mailbox-name (and root-box (string->bytes/utf-8 root-box))])
|
|
(let ([mailbox-name-length (if mailbox-name
|
|
(bytes-length mailbox-name)
|
|
0)]
|
|
[get-child-mailbox-name (lambda (item) (second item))]
|
|
[child-mailboxes (imap-list-child-mailboxes imap mailbox-name)])
|
|
(map (lambda (item)
|
|
(let* ([child-mailbox-name (get-child-mailbox-name item)]
|
|
[child-mailbox-flags (first item)]
|
|
[symbols (map imap-flag->symbol child-mailbox-flags)]
|
|
[flat-mailbox? (or (member 'noinferiors symbols)
|
|
(member 'hasnochildren symbols))]
|
|
[selectable? (not (member 'noselect symbols))]
|
|
[child-name-length (bytes-length child-mailbox-name)]
|
|
[strip-prefix?
|
|
(and (> child-name-length mailbox-name-length)
|
|
mailbox-name
|
|
(bytes=?
|
|
(subbytes child-mailbox-name 0 mailbox-name-length)
|
|
mailbox-name))]
|
|
[short-name
|
|
(bytes->string/utf-8
|
|
(if strip-prefix?
|
|
(subbytes child-mailbox-name
|
|
;; strip separator (thus add1)
|
|
(add1 mailbox-name-length)
|
|
child-name-length)
|
|
child-mailbox-name))])
|
|
(if flat-mailbox?
|
|
(make-flat-folder child-mailbox-name short-name #t)
|
|
(make-deep-folder
|
|
child-mailbox-name
|
|
short-name
|
|
selectable?
|
|
(loop child-mailbox-name)))))
|
|
(sort
|
|
child-mailboxes
|
|
(lambda (x y)
|
|
(string<=? (bytes->string/utf-8 (get-child-mailbox-name x))
|
|
(bytes->string/utf-8 (get-child-mailbox-name y)))))))))))))
|
|
|
|
(define imap-mailbox-mixin
|
|
(compose
|
|
imap-mailbox-list-mixin
|
|
imap-mailbox-name-mixin))
|
|
|
|
(define imap-top-list%
|
|
(class (imap-mailbox-list-mixin hierarchical-list%)
|
|
(field
|
|
[selected-mailbox #f])
|
|
[define/public get-selected-mailbox
|
|
(lambda ()
|
|
selected-mailbox)]
|
|
(define/override on-select
|
|
(lambda (i)
|
|
(send frame set-status-text "")
|
|
(set! selected-mailbox (and i
|
|
(send i selectable?)
|
|
(send i get-full-mailbox-name)))
|
|
(super on-select i)))
|
|
(define/override on-double-select
|
|
(lambda (i)
|
|
(when (and i (send i selectable?))
|
|
(let ([mail-box (send i get-full-mailbox-name)])
|
|
(send frame set-status-text (format "Opening ~a" mail-box))
|
|
(setup-mailboxes-file mail-box)
|
|
(open-mailbox (bytes->string/utf-8 mail-box))))
|
|
(super on-double-select i)))
|
|
(super-instantiate ())))
|
|
|
|
(define (update-gui orig-mbf)
|
|
(define (add-child hl mbf)
|
|
(let* ([deep? (deep-folder? mbf)]
|
|
[new-item (if deep?
|
|
(send hl new-list imap-mailbox-mixin)
|
|
(send hl new-item imap-mailbox-name-mixin))]
|
|
[text (send new-item get-editor)])
|
|
(send new-item set-full-mailbox-name (or (folder-name mbf) #""))
|
|
(send new-item set-selectable (folder-selectable? mbf))
|
|
(when deep?
|
|
(send new-item set-mailbox-name (or (folder-name mbf) #"")))
|
|
(send text insert (or (folder-short-name mbf) ""))
|
|
new-item))
|
|
(send (send top-list get-editor) begin-edit-sequence)
|
|
(for-each (lambda (x) (send top-list delete-item x))
|
|
(send top-list get-items))
|
|
(for-each (lambda (mbf)
|
|
(let loop ([hl top-list]
|
|
[mbf mbf])
|
|
(let ([new-item (add-child hl mbf)])
|
|
(when (deep-folder? mbf)
|
|
(for-each (lambda (child) (loop new-item child))
|
|
(deep-folder-children mbf))))))
|
|
(cons (make-flat-folder (string->bytes/utf-8 mailbox-name) mailbox-name #t)
|
|
(deep-folder-children orig-mbf)))
|
|
(send (send top-list get-editor) end-edit-sequence))
|
|
|
|
(define folders-frame%
|
|
(class frame:basic%
|
|
(define/override (on-size w h)
|
|
(put-pref 'sirmail:folder-window-w w)
|
|
(put-pref 'sirmail:folder-window-h h))
|
|
(define/override (on-move x y)
|
|
(put-pref 'sirmail:folder-window-x x)
|
|
(put-pref 'sirmail:folder-window-y y))
|
|
(define/augment (on-close)
|
|
(inner (void) on-close)
|
|
(shutdown-folders-window))
|
|
(define/override (on-message msg)
|
|
(let ([s (and (list? msg)
|
|
(number? (car msg))
|
|
(number? (cadr msg))
|
|
(let ([gx (car msg)]
|
|
[gy (cadr msg)])
|
|
(let-values ([(x y) (send top-list screen->client gx gy)])
|
|
(let ([lxb (box 0)]
|
|
[lyb (box 0)])
|
|
(let loop ([ed (send top-list get-editor)])
|
|
(set-box! lxb x)
|
|
(set-box! lyb y)
|
|
(send ed global-to-local lxb lyb)
|
|
(let* ([on-it-b (box #f)]
|
|
[pos (send ed find-position (unbox lxb) (unbox lyb) #f on-it-b)])
|
|
(and (unbox on-it-b)
|
|
(let ([snip (send ed find-snip pos 'after-or-none)])
|
|
(cond
|
|
[(is-a? snip hierarchical-item-snip%)
|
|
(let ([item (send snip get-item)])
|
|
(send item get-full-mailbox-name))]
|
|
[(is-a? snip hierarchical-list-snip%)
|
|
(let ([ed (send snip get-content-buffer)])
|
|
(or (loop ed)
|
|
(let ([i (send snip get-item)])
|
|
(and (send i selectable?)
|
|
(send i get-full-mailbox-name)))))]
|
|
[else #f])))))))))])
|
|
(send frame set-status-text (if s
|
|
(format "Dragging to ~a" s)
|
|
""))
|
|
s))
|
|
(define/public (get-mailbox-name)
|
|
(send top-list get-selected-mailbox))
|
|
(super-instantiate ())))
|
|
|
|
(define icon (make-object bitmap% (build-path (collection-path "sirmail")
|
|
"folder.bmp")))
|
|
(define icon-mask (make-object bitmap% (build-path (collection-path "sirmail")
|
|
"folder-mask.xbm")))
|
|
(define frame (make-object folders-frame% "Folders" #f
|
|
(get-pref 'sirmail:folder-window-w)
|
|
(get-pref 'sirmail:folder-window-h)
|
|
(max 0 (get-pref 'sirmail:folder-window-x))
|
|
(max 0 (get-pref 'sirmail:folder-window-y))))
|
|
(define top-panel (instantiate horizontal-panel% ((send frame get-area-container))
|
|
[alignment '(right center)]
|
|
[stretchable-height #f]))
|
|
|
|
(define re:setup-mailboxes (regexp "^([^/]*)/(.*)$"))
|
|
(define (setup-mailboxes-file bytes-mailbox-name)
|
|
(define mailbox-name (bytes->string/utf-8 bytes-mailbox-name))
|
|
(define mailboxes-file (build-path (LOCAL-DIR) "mailboxes"))
|
|
(define mailboxes
|
|
(with-handlers ([exn:fail? (lambda (x) '(("Inbox" #"inbox")))])
|
|
(with-input-from-file mailboxes-file
|
|
read)))
|
|
|
|
(define mailbox-loc (assoc mailbox-name mailboxes))
|
|
|
|
(unless mailbox-loc
|
|
|
|
(let ([fns (let loop ([str mailbox-name])
|
|
(cond
|
|
[(regexp-match re:setup-mailboxes str)
|
|
=>
|
|
(lambda (m)
|
|
(cons (cadr m)
|
|
(loop (caddr m))))]
|
|
[else
|
|
(if (string=? str "")
|
|
null
|
|
(list str))]))])
|
|
|
|
(unless (null? fns)
|
|
(let ([mailbox-dir
|
|
(let loop ([fns (if (string=? (car fns) "")
|
|
(cdr fns)
|
|
fns)]
|
|
[local-dir 'same]
|
|
[fs-dir (LOCAL-DIR)])
|
|
(cond
|
|
[(null? fns) local-dir]
|
|
[else (let ([new-fs-dir (build-path fs-dir (car fns))])
|
|
(unless (directory-exists? new-fs-dir)
|
|
(make-directory new-fs-dir))
|
|
(loop (cdr fns)
|
|
(build-path local-dir (car fns))
|
|
new-fs-dir))]))])
|
|
|
|
(with-output-to-file (build-path (LOCAL-DIR) "mailboxes")
|
|
(lambda () (write
|
|
(append mailboxes
|
|
(list (list mailbox-name
|
|
(path->bytes mailbox-dir))))))
|
|
'truncate))))))
|
|
|
|
|
|
(define refresh-mailbox-button
|
|
(instantiate button% ()
|
|
(label "Update Folder List")
|
|
(parent top-panel)
|
|
(callback (lambda (x y)
|
|
(refresh-mailboxes)))))
|
|
|
|
(define stop-thread #f)
|
|
(define stop-button
|
|
(instantiate button% ()
|
|
(label "Stop")
|
|
(parent top-panel)
|
|
(callback (lambda (x y)
|
|
(when stop-thread
|
|
(break-thread stop-thread))))))
|
|
|
|
(send stop-button enable #f)
|
|
|
|
(define (with-custodian-killing-stop-button what thunk)
|
|
(let ([c (make-custodian)]
|
|
[result #f])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(send frame set-status-text what)
|
|
(send (send frame get-menu-bar) enable #f)
|
|
(send top-list enable #f)
|
|
(send refresh-mailbox-button enable #f)
|
|
(send stop-button enable #t))
|
|
(lambda ()
|
|
(parameterize ([current-custodian c])
|
|
(set! stop-thread (thread (lambda ()
|
|
(with-handlers ([values (lambda (x)
|
|
(set! result x))])
|
|
(set! result (thunk))))))
|
|
(yield stop-thread)))
|
|
(lambda ()
|
|
(send frame set-status-text "")
|
|
(custodian-shutdown-all c)
|
|
(send (send frame get-menu-bar) enable #t)
|
|
(send top-list enable #t)
|
|
(send refresh-mailbox-button enable #t)
|
|
(send stop-button enable #f)))
|
|
(if (exn? result)
|
|
(raise result)
|
|
result)))
|
|
|
|
|
|
(define top-list (make-object imap-top-list% (send frame get-area-container)))
|
|
|
|
(when (and (send icon ok?) (send icon-mask ok?))
|
|
(send frame set-icon icon icon-mask 'both))
|
|
|
|
(define file-menu (make-object menu% "&File" (send frame get-menu-bar)))
|
|
(make-object menu-item% "&Add Folder..." file-menu
|
|
(lambda (i e)
|
|
(let ([t (get-text-from-user "New Folder" "New folder name:" frame)])
|
|
(when t
|
|
(when (with-custodian-killing-stop-button
|
|
(format "Creating ~a" t)
|
|
(lambda ()
|
|
(let-values ([(imap x y) (imap-open-connection)])
|
|
(imap-create-mailbox imap t))
|
|
#t))
|
|
(refresh-mailboxes))))))
|
|
(make-object separator-menu-item% file-menu)
|
|
(make-object menu-item% "Close" file-menu
|
|
(lambda (i e)
|
|
(send frame close)))
|
|
|
|
(frame:reorder-menus frame)
|
|
|
|
(send frame show #t)
|
|
(send frame min-width 350)
|
|
(send frame min-height 450)
|
|
(send frame create-status-line)
|
|
(send top-list set-mailbox-name (ROOT-MAILBOX-FOR-LIST))
|
|
(update-gui (read-mailbox-folder))
|
|
|
|
(uncaught-exception-handler
|
|
(lambda (x)
|
|
(show-error x frame)
|
|
((error-escape-handler))))
|
|
|
|
frame))
|