3227 lines
122 KiB
Scheme
3227 lines
122 KiB
Scheme
|
|
;; This module implements the mail-reading window as a unit. The
|
|
;; unit is instantiated once for each window.
|
|
|
|
;; General notes:
|
|
;;
|
|
;; * Always use `as-background' when communicating with the
|
|
;; server. That way, the user can kill the window if necessary.
|
|
;; use `enable-main-frame' for the first argument to `as-background'.
|
|
;; The `as-background' function is defined in "utilr.ss".
|
|
;;
|
|
|
|
(module readr mzscheme
|
|
(require mzlib/unit
|
|
mzlib/class
|
|
mzlib/file
|
|
mred/mred-sig
|
|
framework
|
|
mzlib/process)
|
|
|
|
(require mzlib/string
|
|
mzlib/list
|
|
mzlib/thread
|
|
"spell.ss")
|
|
|
|
(require "sirmails.ss")
|
|
|
|
(require "pref.ss")
|
|
|
|
(require net/imap-sig
|
|
net/smtp-sig
|
|
net/head-sig
|
|
net/base64-sig
|
|
net/mime-sig
|
|
net/qp-sig
|
|
browser/htmltext)
|
|
|
|
(require mrlib/hierlist/hierlist-sig)
|
|
|
|
(require net/sendurl)
|
|
|
|
(require openssl/mzssl)
|
|
|
|
;; Constant for messages without a title:
|
|
(define no-subject-string "<No subject>")
|
|
|
|
(provide read@)
|
|
(define-unit read@
|
|
(import sirmail:options^
|
|
sirmail:environment^
|
|
sirmail:utils^
|
|
sirmail:send^
|
|
mred^
|
|
imap^
|
|
smtp^
|
|
head^
|
|
base64^
|
|
(prefix mime: mime^)
|
|
qp^
|
|
hierlist^)
|
|
(export sirmail:read^)
|
|
|
|
;; This will be set to the frame object
|
|
(define main-frame #f)
|
|
(define done? #f)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Error Handling ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; It's possible that SirMail can't even start with
|
|
;; the default preference values. This flag lets us
|
|
;; give the user a chance.
|
|
(define got-started? #f)
|
|
|
|
(define (show-error x)
|
|
(show-error-message-box x main-frame)
|
|
(when (not got-started?)
|
|
(when (eq? 'yes (confirm-box "Startup Error"
|
|
(string-append
|
|
"Looks like you didn't even get started. "
|
|
"Set preferences (so you're ready to try again)?")
|
|
#f
|
|
'(app)))
|
|
(show-pref-dialog))))
|
|
|
|
(uncaught-exception-handler
|
|
(lambda (x)
|
|
(show-error x)
|
|
((error-escape-handler))))
|
|
|
|
;; Install std bindings global for file dialog, etc.
|
|
(let ([km (make-object keymap%)])
|
|
(add-text-keymap-functions km)
|
|
(keymap:setup-global km)
|
|
(let ([f (current-text-keymap-initializer)])
|
|
(current-text-keymap-initializer
|
|
(lambda (k)
|
|
(send k chain-to-keymap km #f)
|
|
(f k)))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Mailbox List ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; In case this is the first run...
|
|
(unless (directory-exists? (LOCAL-DIR))
|
|
(make-directory (LOCAL-DIR)))
|
|
|
|
;; The "mailboxes" file tells us where to find local copies
|
|
;; of the mailbox content
|
|
(define mailboxes
|
|
(with-handlers ([void (lambda (x) '(("Inbox" #"inbox")))])
|
|
(with-input-from-file (build-path (LOCAL-DIR) "mailboxes")
|
|
read)))
|
|
|
|
(unless (assoc mailbox-name mailboxes)
|
|
(error 'sirmail "No local mapping for mailbox: ~a" mailbox-name))
|
|
|
|
(define (string/bytes->path s)
|
|
(if (string? s)
|
|
(string->path s)
|
|
(bytes->path s)))
|
|
|
|
;; find the mailbox for this window:
|
|
(define mailbox-dir (build-path (LOCAL-DIR)
|
|
(string/bytes->path (cadr (assoc mailbox-name mailboxes)))))
|
|
|
|
(unless (directory-exists? mailbox-dir)
|
|
(make-directory mailbox-dir))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Message data structure ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; We use a lists so they can be easily read and written
|
|
|
|
;; type message = (list ... message attributes, see selectors below ...)
|
|
|
|
(define uid-validity #f)
|
|
|
|
;; mailbox : (listof message)
|
|
;; mailboxes holds the list of messages reflected in the top list
|
|
;; in the GUI. When modifying this value (usually indirectly), use
|
|
;; `header-chganging-action'. Mutate the variable, but not the list!
|
|
(define mailbox (let* ([mailbox-file (build-path mailbox-dir "mailbox")]
|
|
[l (with-handlers ([void (lambda (x)
|
|
(message-box "SirMail"
|
|
(format
|
|
"error reading mailbox ~s, ~a\n"
|
|
mailbox-file
|
|
(exn-message x)))
|
|
null)])
|
|
(with-input-from-file mailbox-file
|
|
read))])
|
|
(when (eof-object? l)
|
|
(message-box "SirMail" (format "mailbox ~s was eof\n" mailbox-file))
|
|
(set! l '()))
|
|
;; If the file's list start with an integer, that's
|
|
;; the uidvalidity value. Otherwise, for backward
|
|
;; compatibility, we allow the case that it wasn't
|
|
;; recorded.
|
|
(let ([l (if (and (pair? l)
|
|
(or (not (car l)) (integer? (car l))))
|
|
(begin
|
|
(set! uid-validity (car l))
|
|
(cdr l))
|
|
l)])
|
|
;; Convert each entry to a vector:
|
|
(map list->vector l))))
|
|
|
|
(define mailbox-ht #f)
|
|
(define (rebuild-mailbox-table!)
|
|
(set! mailbox-ht (make-hash-table 'equal))
|
|
(for-each (lambda (m) (hash-table-put! mailbox-ht (vector-ref m 0) m))
|
|
mailbox))
|
|
(rebuild-mailbox-table!)
|
|
|
|
(define (find-message id)
|
|
(hash-table-get mailbox-ht id (lambda () #f)))
|
|
|
|
(define (message-uid m) (vector-ref m 0))
|
|
(define (message-position m) (vector-ref m 1))
|
|
(define (message-downloaded? m) (vector-ref m 2))
|
|
(define (message-from m) (vector-ref m 3))
|
|
(define (message-subject m) (vector-ref m 4))
|
|
(define (message-flags m) (vector-ref m 5))
|
|
(define (message-size m)
|
|
;; For backward compatibility:
|
|
(if ((vector-length m) . < . 7)
|
|
#f
|
|
(vector-ref m 6)))
|
|
(define (set-message-position! m v) (vector-set! m 1 v))
|
|
(define (set-message-downloaded?! m v) (vector-set! m 2 v))
|
|
(define (set-message-flags! m v) (vector-set! m 5 v))
|
|
|
|
(define (message-marked? m) (memq 'marked (message-flags m)))
|
|
|
|
(define (write-mailbox)
|
|
(status "Saving mailbox information...")
|
|
(with-output-to-file (build-path mailbox-dir "mailbox")
|
|
(lambda ()
|
|
(write (cons uid-validity (map vector->list mailbox))))
|
|
'truncate))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Connection ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-values (connect disconnect force-disconnect)
|
|
(let ([connection #f]
|
|
[connection-custodian #f]
|
|
[message-count 0])
|
|
(values
|
|
(letrec ([connect
|
|
(case-lambda
|
|
[() (connect 'reuse)]
|
|
[(mode) (connect 'reuse void void)]
|
|
[(mode break-bad break-ok)
|
|
|
|
(define (with-disconnect-handler thunk)
|
|
(with-handlers ([void (lambda (exn)
|
|
(force-disconnect)
|
|
(status "")
|
|
(raise exn))])
|
|
(break-ok)
|
|
(begin0
|
|
(thunk)
|
|
(break-bad))))
|
|
|
|
|
|
(if connection
|
|
|
|
;; Already Connected
|
|
(cond
|
|
[(eq? mode 'reselect)
|
|
(let-values ([(count new) (with-disconnect-handler
|
|
(lambda ()
|
|
(imap-noop connection)))])
|
|
(check-validity (or (imap-uidvalidity connection) 0) void)
|
|
(values connection (imap-messages connection) (imap-new? connection)))]
|
|
[(eq? mode 'check-new)
|
|
(let-values ([(count new) (with-disconnect-handler
|
|
(lambda ()
|
|
(imap-noop connection)))])
|
|
(values connection message-count (imap-new? connection)))]
|
|
[else
|
|
(values connection message-count (imap-new? connection))])
|
|
|
|
;; New connection
|
|
(begin
|
|
(let ([pw (or (get-PASSWORD)
|
|
(let ([p (get-pw-from-user (USERNAME) main-frame)])
|
|
(unless p (raise-user-error 'connect "connection canceled"))
|
|
p))])
|
|
(let*-values ([(imap count new) (let-values ([(server port-no)
|
|
(parse-server-name (IMAP-SERVER)
|
|
(if (get-pref 'sirmail:use-ssl?) 993 143))])
|
|
(set! connection-custodian (make-custodian))
|
|
(parameterize ([current-custodian connection-custodian])
|
|
(with-disconnect-handler
|
|
(lambda ()
|
|
(if (get-pref 'sirmail:use-ssl?)
|
|
(let ([c (ssl-make-client-context)])
|
|
(let ([cert (get-pref 'sirmail:server-certificate)])
|
|
(when cert
|
|
(ssl-set-verify! c #t)
|
|
(ssl-load-verify-root-certificates! c cert)))
|
|
(let-values ([(in out) (ssl-connect server port-no c)])
|
|
(imap-connect* in out (USERNAME) pw mailbox-name)))
|
|
(parameterize ([imap-port-number port-no])
|
|
(imap-connect server (USERNAME) pw mailbox-name)))))))])
|
|
(unless (get-PASSWORD)
|
|
(set-PASSWORD pw))
|
|
(status "(Connected, ~a messages)" count)
|
|
(with-disconnect-handler
|
|
(lambda ()
|
|
(check-validity (or (imap-uidvalidity imap) 0)
|
|
(lambda () (imap-disconnect imap)))))
|
|
(set! connection imap)
|
|
(set! message-count count)
|
|
(send disconnected-msg show #f)
|
|
(values imap count (imap-new? imap))))))])])
|
|
connect)
|
|
(lambda ()
|
|
(when connection
|
|
(status "Disconnecting...")
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(with-handlers ([void (lambda (exn)
|
|
(force-disconnect/status)
|
|
(raise exn))])
|
|
(break-ok)
|
|
(imap-disconnect connection)))
|
|
close-frame)
|
|
(status "")
|
|
(set! connection #f)))
|
|
(lambda ()
|
|
(custodian-shutdown-all connection-custodian)
|
|
(set! connection #f)))))
|
|
|
|
(define (force-disconnect/status)
|
|
(force-disconnect)
|
|
(send disconnected-msg show #t)
|
|
(set! initialized? #f)
|
|
(set! continue? #f)
|
|
(status ""))
|
|
|
|
(define (check-validity v cleanup)
|
|
(when (and uid-validity
|
|
(not (= uid-validity v))
|
|
(pair? mailbox))
|
|
;; This is really very unlikely, but we checked
|
|
;; to guard against disaster.
|
|
(cleanup)
|
|
(raise-user-error 'connect "UID validity changed, ~a -> ~a! SirMail can't handle it."
|
|
uid-validity v))
|
|
(set! uid-validity v))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Mailbox Actions (indepdent of the GUI) ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define initialized? #f)
|
|
(define new-messages? #f)
|
|
(define current-count 0)
|
|
(define continue? #f)
|
|
|
|
(define (initialized count)
|
|
(set! initialized? #t)
|
|
(set! continue? #t)
|
|
(set! new-messages? #f)
|
|
(set! current-count count)
|
|
(hide-new-mail-msg))
|
|
|
|
;; Syncs `mailbox' with the server
|
|
(define (update-local break-bad break-ok)
|
|
(status "Updating ~a from ~a..." mailbox-name (IMAP-SERVER))
|
|
(let-values ([(imap count new?) (connect 'reselect break-bad break-ok)])
|
|
(imap-reset-new! imap)
|
|
(start-biff)
|
|
(status "Getting message ids...")
|
|
(let* ([positions (if continue?
|
|
(let ([p (length mailbox)])
|
|
(map (lambda (i) (+ i p))
|
|
(enumerate (- count p))))
|
|
(enumerate count))]
|
|
[data (with-handlers ([void (lambda (exn)
|
|
(force-disconnect/status)
|
|
(raise exn))])
|
|
(break-ok)
|
|
(begin0
|
|
(imap-get-messages imap
|
|
positions
|
|
'(uid))
|
|
(break-bad)))]
|
|
[uids (map car data)]
|
|
[curr-uids (map (lambda (m) (vector-ref m 0)) mailbox)]
|
|
[deleted (if continue?
|
|
null
|
|
(remove* uids curr-uids))]
|
|
[position-uids (map cons uids positions)]
|
|
[new (if continue?
|
|
position-uids
|
|
(remove* curr-uids position-uids
|
|
(lambda (a b) (equal? a (car b)))))])
|
|
(status "~a deleted, ~a locally new" (length deleted) (length new))
|
|
|
|
(unless (null? new)
|
|
(status "Getting new headers..."))
|
|
(let* ([new-data (with-handlers ([void (lambda (exn)
|
|
(force-disconnect/status)
|
|
(raise exn))])
|
|
(break-ok)
|
|
(begin0
|
|
(imap-get-messages imap
|
|
(map cdr new)
|
|
'(header size))
|
|
(break-bad)))]
|
|
[new-headers (map car new-data)]
|
|
[new-sizes (map cadr new-data)]
|
|
[new-uid/size-map (map cons (map car new) new-sizes)])
|
|
(if (and (null? deleted) (null? new))
|
|
(begin
|
|
(initialized count)
|
|
(status "No new messages")
|
|
#f)
|
|
(begin
|
|
(unless (null? deleted)
|
|
(status "Deleting local messages...")
|
|
(for-each
|
|
(lambda (uid)
|
|
(with-handlers ([void void])
|
|
(let ([path (build-path mailbox-dir (format "~a" uid))])
|
|
(delete-file path)
|
|
(let ([body (string-append path "body")])
|
|
(when (file-exists? body)
|
|
(delete-file body))))))
|
|
deleted))
|
|
|
|
(unless (null? new-headers)
|
|
(status "Saving new headers...")
|
|
(for-each
|
|
(lambda (position-uid header)
|
|
(with-output-to-file (build-path mailbox-dir (format "~a" (car position-uid)))
|
|
(lambda ()
|
|
(display header))
|
|
'truncate))
|
|
new new-headers))
|
|
|
|
(set! mailbox
|
|
(append
|
|
(if continue? mailbox null)
|
|
(map
|
|
(lambda (uid pos)
|
|
(let ([old (ormap (lambda (m)
|
|
(and (equal? uid (message-uid m))
|
|
m))
|
|
mailbox)])
|
|
(list->vector
|
|
`(,uid ,pos
|
|
,(if old
|
|
(message-downloaded? old)
|
|
#f)
|
|
,(if old
|
|
(message-from old)
|
|
(extract-field "From" (get-header uid)))
|
|
,(if old
|
|
(message-subject old)
|
|
(extract-field "Subject" (get-header uid)))
|
|
,(if old
|
|
(message-flags old)
|
|
null)
|
|
,(if old
|
|
(message-size old)
|
|
(let ([new (assoc uid new-uid/size-map)])
|
|
(if new
|
|
(cdr new)
|
|
0)))))))
|
|
uids positions)))
|
|
(rebuild-mailbox-table!)
|
|
(write-mailbox)
|
|
(initialized count)
|
|
(display-message-count (length mailbox))
|
|
(let ([len (length new-headers)])
|
|
(status "Got ~a new message~a"
|
|
len
|
|
(if (= 1 len) "" "s")))
|
|
#t))))))
|
|
|
|
(define (check-for-new break-bad break-ok)
|
|
(status "Checking ~a at ~a..." mailbox-name (IMAP-SERVER))
|
|
(let-values ([(imap count new?) (connect 'check-new break-bad break-ok)])
|
|
(set! new-messages? new?))
|
|
(if new-messages?
|
|
(begin
|
|
(show-new-mail-msg)
|
|
(status "New mail")
|
|
#t)
|
|
(begin
|
|
(hide-new-mail-msg)
|
|
(status "No new mail")
|
|
#f))
|
|
new-messages?)
|
|
|
|
;; gets cached header
|
|
(define (get-header uid)
|
|
(let ([file (build-path mailbox-dir (format "~a" uid))])
|
|
(with-input-from-file file
|
|
(lambda ()
|
|
(bytes->string/latin-1
|
|
(read-bytes (file-size file)))))))
|
|
|
|
;; gets cached body or downloads from server (and caches)
|
|
(define (get-body uid break-bad break-ok)
|
|
(let ([v (find-message uid)]
|
|
[file (build-path mailbox-dir (format "~abody" uid))])
|
|
(when (not v)
|
|
(error 'internal-error "unknown message: ~a" uid))
|
|
(unless (message-downloaded? v)
|
|
(status "Getting message ~a..." uid)
|
|
(let ([size (message-size v)]
|
|
[warn-size (WARN-DOWNLOAD-SIZE)])
|
|
(when (and size warn-size (> size warn-size))
|
|
(unless (eq? 'yes
|
|
(confirm-box "Large Message"
|
|
(format "The message is ~s bytes.~nReally download?" size)
|
|
main-frame))
|
|
(status "")
|
|
(raise-user-error "download aborted"))))
|
|
(let*-values ([(imap count new?) (connect 'reuse break-bad break-ok)])
|
|
(let ([body (with-handlers ([void
|
|
(lambda (exn)
|
|
(force-disconnect/status)
|
|
(raise exn))])
|
|
(break-ok)
|
|
(begin0
|
|
(let ([reply (imap-get-messages
|
|
imap
|
|
(list (message-position v))
|
|
'(uid body))])
|
|
(if (equal? (caar reply) (message-uid v))
|
|
(cadar reply)
|
|
(raise-user-error (string-append "server UID does not match local UID; "
|
|
"update the message list and try again"))))
|
|
(break-bad)))])
|
|
(status "Saving message ~a..." uid)
|
|
(with-output-to-file file
|
|
(lambda () (write-bytes body))
|
|
'truncate)
|
|
|
|
(set-message-downloaded?! v #t)
|
|
(write-mailbox))))
|
|
(begin0
|
|
(with-input-from-file file
|
|
(lambda ()
|
|
(read-bytes (file-size file))))
|
|
(status ""))))
|
|
|
|
;; Checks that `mailbox' is synced with the server
|
|
(define (check-positions imap msgs)
|
|
(status "Checking message mapping...")
|
|
(let ([ids (imap-get-messages imap (map message-position msgs) '(uid))])
|
|
(unless (equal? (map car ids) (map message-uid msgs))
|
|
(raise-user-error
|
|
'position-check "server's position->id mapping doesn't match local copy. server: ~s local: ~s"
|
|
(map car ids)
|
|
(map message-uid msgs)))))
|
|
|
|
(define (remove-delete-flags imap)
|
|
(status "Removing old delete flags...")
|
|
(imap-store imap '- (map message-position mailbox) (list (symbol->imap-flag 'deleted))))
|
|
|
|
;; purge-messages : (listof messages) -> void
|
|
(define (purge-messages marked bad-break break-ok)
|
|
(unless (null? marked)
|
|
(let-values ([(imap count new?) (connect)])
|
|
(with-handlers ([void
|
|
(lambda (exn)
|
|
(force-disconnect/status)
|
|
(raise exn))])
|
|
(break-ok)
|
|
(check-positions imap marked)
|
|
(remove-delete-flags imap)
|
|
(status "Deleting marked messages...")
|
|
(imap-store imap '+ (map message-position marked)
|
|
(list (symbol->imap-flag 'deleted)))
|
|
(imap-expunge imap)
|
|
(unless (equal? (imap-get-expunges imap)
|
|
(map message-position marked))
|
|
(error "expunge notification list doesn't match expunge request"))
|
|
(bad-break))
|
|
(set! mailbox
|
|
(filter
|
|
(lambda (m) (not (memq m marked)))
|
|
mailbox))
|
|
(rebuild-mailbox-table!)
|
|
(let loop ([l mailbox][p 1])
|
|
(unless (null? l)
|
|
(set-message-position! (car l) p)
|
|
(loop (cdr l) (add1 p))))
|
|
(write-mailbox)
|
|
(let* ([problems null]
|
|
[try-delete
|
|
(lambda (f)
|
|
(with-handlers ([void
|
|
(lambda (x)
|
|
(set! problems (cons x problems)))])
|
|
(delete-file f)))])
|
|
(for-each
|
|
(lambda (m)
|
|
(let ([uid (message-uid m)])
|
|
(try-delete (build-path mailbox-dir (format "~a" uid)))
|
|
(when (message-downloaded? m)
|
|
(try-delete (build-path mailbox-dir (format "~abody" uid))))))
|
|
marked)
|
|
(unless (null? problems)
|
|
(message-box "Warning"
|
|
(apply
|
|
string-append
|
|
"There we problems deleting some local files:"
|
|
(map
|
|
(lambda (x)
|
|
(string-append
|
|
(string #\newline)
|
|
(if (exn? x)
|
|
(exn-message x)
|
|
"<unknown exn>")))
|
|
problems))
|
|
main-frame))
|
|
(display-message-count (length mailbox))
|
|
(status "Messages deleted")))))
|
|
|
|
;; purge-marked : -> void
|
|
;; purges the marked mailbox messages.
|
|
(define (purge-marked bad-break break-ok)
|
|
(let* ([marked (filter message-marked? mailbox)])
|
|
(purge-messages marked bad-break break-ok)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; GUI: Message List Tools ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define FROM-WIDTH 150)
|
|
(define SUBJECT-WIDTH 300)
|
|
(define UID-WIDTH 150)
|
|
|
|
;; update-frame-width : -> void
|
|
;; updates the green line's width
|
|
;; preferences's value of sirmail:frame-width must be
|
|
;; up to date before calling this function
|
|
(define (update-frame-width)
|
|
(let* ([goofy-margin 15]
|
|
[calc-w (- (get-pref 'sirmail:frame-width) goofy-margin)])
|
|
(set! FROM-WIDTH (quotient calc-w 4))
|
|
(set! UID-WIDTH (quotient calc-w 5))
|
|
(set! SUBJECT-WIDTH (- calc-w FROM-WIDTH UID-WIDTH)))
|
|
|
|
(when (object? sorting-from-snip)
|
|
(send sorting-from-snip set-min-width FROM-WIDTH)
|
|
(send sorting-from-snip set-max-width FROM-WIDTH)
|
|
(send sorting-uid-snip set-min-width UID-WIDTH)
|
|
(send sorting-uid-snip set-max-width UID-WIDTH)
|
|
(send sorting-subject-snip set-min-width SUBJECT-WIDTH)
|
|
(send sorting-subject-snip set-max-width SUBJECT-WIDTH))
|
|
|
|
(when (object? header-list)
|
|
(let ([e (send header-list get-editor)])
|
|
(send e begin-edit-sequence)
|
|
(for-each (lambda (item)
|
|
(let* ([e (send item get-editor)]
|
|
[line-snip
|
|
(let loop ([s (send e find-first-snip)])
|
|
(cond
|
|
[(not s) #f]
|
|
[(is-a? s line-snip%) s]
|
|
[else (loop (send s next))]))])
|
|
(send line-snip set-width (+ FROM-WIDTH SUBJECT-WIDTH UID-WIDTH))))
|
|
(send header-list get-items))
|
|
(send e end-edit-sequence))))
|
|
|
|
(update-frame-width)
|
|
|
|
(define unselected-delta (make-object style-delta% 'change-normal-color))
|
|
(define selected-delta (make-object style-delta%))
|
|
(send selected-delta set-delta-foreground "BLUE")
|
|
|
|
(define unread-delta (make-object style-delta% 'change-bold))
|
|
(define read-delta (make-object style-delta% 'change-weight 'normal))
|
|
|
|
(define marked-delta (make-object style-delta% 'change-italic))
|
|
(define unmarked-delta (make-object style-delta% 'change-style 'normal))
|
|
|
|
(define red-delta (make-object style-delta%))
|
|
(send red-delta set-delta-foreground "red")
|
|
(define green-delta (make-object style-delta%))
|
|
(send green-delta set-delta-foreground "green")
|
|
|
|
;; url-delta : style-delta
|
|
;; this is used to higlight urls in the editor window
|
|
(define url-delta (make-object style-delta% 'change-underline #t))
|
|
(send url-delta set-delta-foreground "blue")
|
|
|
|
(define (apply-style i delta)
|
|
(let ([e (send i get-editor)])
|
|
(send e change-style delta 0 (send e last-position))))
|
|
|
|
(define (set-standard-style t s e)
|
|
(send t change-style (send (send t get-style-list) find-named-style "Standard")
|
|
s e))
|
|
|
|
(define current-selected #f)
|
|
|
|
(define (set-current-selected i)
|
|
(unless (eq? current-selected i)
|
|
(let ([e (send header-list get-editor)])
|
|
(send e begin-edit-sequence)
|
|
(when current-selected
|
|
(apply-style current-selected unselected-delta))
|
|
(set! current-selected i)
|
|
(when i
|
|
(apply-style i selected-delta)
|
|
; In case we downloaded it just now:
|
|
(apply-style i read-delta))
|
|
(send e end-edit-sequence))))
|
|
|
|
(define vertical-line-snipclass
|
|
(make-object
|
|
(class snip-class% ()
|
|
(define/override (read s)
|
|
(make-object vertical-line-snip%))
|
|
(super-instantiate ()))))
|
|
(send vertical-line-snipclass set-version 1)
|
|
(send vertical-line-snipclass set-classname "sirmail:vertical-line%")
|
|
(send (get-the-snip-class-list) add vertical-line-snipclass)
|
|
(define body-pen (send the-pen-list find-or-create-pen "blue" 0 'solid))
|
|
(define body-brush (send the-brush-list find-or-create-brush "WHITE" 'solid))
|
|
(define vertical-line-snip%
|
|
(class snip%
|
|
(inherit set-snipclass get-style get-admin)
|
|
(field
|
|
[width 15]
|
|
[height 10])
|
|
[define/override get-extent
|
|
(lambda (dc x y w-box h-box descent-box space-box lspace-box rspace-box)
|
|
(for-each (lambda (box) (when box (set-box! box 0)))
|
|
(list w-box h-box lspace-box rspace-box))
|
|
(let ([old-font (send dc get-font)])
|
|
(send dc set-font (send (get-style) get-font))
|
|
(let-values ([(w h descent ascent)
|
|
(send dc get-text-extent "yxX")])
|
|
(when w-box
|
|
(set-box! w-box width))
|
|
|
|
;; add one here because I know the descent for the entire
|
|
;; line is going to be one more than the descent of the font.
|
|
(when descent-box
|
|
(set-box! descent-box (+ descent 1)))
|
|
|
|
(when space-box
|
|
(set-box! space-box ascent))
|
|
(let ([text (and (get-admin)
|
|
(send (get-admin) get-editor))])
|
|
|
|
;; add 2 here because I know lines are two pixels taller
|
|
;; than the font. How do I know? I just know.
|
|
(set! height (+ h 2))
|
|
(when h-box
|
|
(set-box! h-box (+ h 2)))
|
|
|
|
(send dc set-font old-font)))))]
|
|
[define/override draw
|
|
(lambda (dc x y left top right bottom dx dy draw-caret)
|
|
(let ([orig-pen (send dc get-pen)]
|
|
[orig-brush (send dc get-brush)])
|
|
(send dc set-pen body-pen)
|
|
(send dc set-brush body-brush)
|
|
|
|
(send dc draw-line
|
|
(+ x (quotient width 2))
|
|
y
|
|
(+ x (quotient width 2))
|
|
(+ y (- height 1)))
|
|
|
|
(send dc set-pen orig-pen)
|
|
(send dc set-brush orig-brush)))]
|
|
[define/override write
|
|
(lambda (s)
|
|
(void))]
|
|
[define/override copy
|
|
(lambda ()
|
|
(let ([s (make-object vertical-line-snip%)])
|
|
(send s set-style (get-style))
|
|
s))]
|
|
(super-instantiate ())
|
|
(set-snipclass vertical-line-snipclass)))
|
|
|
|
(define common-style-list #f)
|
|
(define (single-style t)
|
|
;; Commented out for now:
|
|
'(if common-style-list
|
|
(send t set-style-list common-style-list)
|
|
(set! common-style-list (send t get-style-list)))
|
|
t)
|
|
|
|
(define (make-field w)
|
|
(let ([m (instantiate editor-snip% ()
|
|
(editor (single-style (let ([e (make-object text% 0.0)])
|
|
(send e set-keymap #f)
|
|
(send e set-max-undo-history 0)
|
|
e)))
|
|
(with-border? #f)
|
|
(top-margin 1)
|
|
(top-inset 1)
|
|
(bottom-margin 1)
|
|
(bottom-inset 1)
|
|
(min-width w)
|
|
(max-width w))])
|
|
(send m set-flags (remove 'handles-events (send m get-flags)))
|
|
m))
|
|
|
|
(define first-gap 35)
|
|
(define second-gap 15)
|
|
(define line-space 8)
|
|
(define extra-height 2)
|
|
(define left-edge-space 2)
|
|
|
|
(define line-snip%
|
|
(class snip%
|
|
(init-field from subject uid)
|
|
(define/override (draw dc x y left top bottom right dx dy draw-caret)
|
|
(let ([w (get-width)])
|
|
(let-values ([(_1 h _2 _3) (send dc get-text-extent "yX")])
|
|
|
|
(let* ([old-clip (send dc get-clipping-region)]
|
|
[new-clip #f]
|
|
[set-clip
|
|
(lambda (x y w h)
|
|
(if old-clip
|
|
(begin
|
|
(send dc set-clipping-region #f)
|
|
(unless new-clip
|
|
(set! new-clip (make-object region% dc)))
|
|
(send new-clip set-rectangle x y w h)
|
|
(send new-clip intersect old-clip)
|
|
(send dc set-clipping-region new-clip))
|
|
(send dc set-clipping-rect x y w h)))])
|
|
(set-clip x y (+ FROM-WIDTH (/ first-gap 2) (- line-space)) h)
|
|
(send dc draw-text from (+ x left-edge-space) y #t)
|
|
(set-clip (+ x FROM-WIDTH (/ first-gap 2) line-space)
|
|
y
|
|
(+ SUBJECT-WIDTH (/ second-gap 2) (- line-space))
|
|
h)
|
|
(send dc draw-text subject (+ x FROM-WIDTH (/ first-gap 2) line-space) y #t)
|
|
(send dc set-clipping-region old-clip)
|
|
(send dc draw-text
|
|
uid
|
|
(+ x FROM-WIDTH first-gap SUBJECT-WIDTH (/ second-gap 2) line-space)
|
|
y
|
|
#t))
|
|
|
|
(let ([p (send dc get-pen)])
|
|
(send dc set-pen body-pen)
|
|
(send dc draw-line
|
|
(+ x FROM-WIDTH (/ first-gap 2))
|
|
y
|
|
(+ x FROM-WIDTH (/ first-gap 2))
|
|
(+ y h extra-height))
|
|
(send dc draw-line
|
|
(+ x FROM-WIDTH first-gap SUBJECT-WIDTH (/ second-gap 2))
|
|
y
|
|
(+ x FROM-WIDTH first-gap SUBJECT-WIDTH (/ second-gap 2))
|
|
(+ y h extra-height))
|
|
(send dc set-pen p)))))
|
|
|
|
(inherit get-style)
|
|
(define/override (get-extent dc x y wb hb db sb lb rb)
|
|
(let-values ([(w h d s) (send dc get-text-extent "yX" (send (get-style) get-font))])
|
|
(set-box/f! hb (+ extra-height h))
|
|
(set-box/f! wb (get-width))
|
|
(set-box/f! db d)
|
|
(set-box/f! sb s)
|
|
(set-box/f! lb 2)
|
|
(set-box/f! rb 0)))
|
|
|
|
(inherit get-admin)
|
|
|
|
(field [width 500])
|
|
(define/public (set-width w)
|
|
(let ([admin (get-admin)])
|
|
(when admin
|
|
(send admin resized this #t)))
|
|
(set! width w))
|
|
(define/private (get-width) width)
|
|
(super-new)))
|
|
|
|
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
|
|
|
|
(define (add-message m)
|
|
(let* ([i (send header-list new-item)]
|
|
[e (send i get-editor)]
|
|
[one-line
|
|
(lambda (s)
|
|
(regexp-replace* #rx"[ \r\n\t]+" s " "))]
|
|
[snip (new line-snip%
|
|
(from
|
|
(one-line (or (parse-encoded (message-from m))
|
|
"<unknown>")))
|
|
(subject
|
|
(one-line (or (parse-encoded (message-subject m))
|
|
no-subject-string)))
|
|
(uid (format "~a" (message-uid m))))]
|
|
[before (send e last-position)])
|
|
(send e begin-edit-sequence)
|
|
(send i user-data (message-uid m))
|
|
(send e set-line-spacing 0)
|
|
(send snip set-width (+ FROM-WIDTH SUBJECT-WIDTH UID-WIDTH))
|
|
(send e insert snip)
|
|
(unless (message-downloaded? m)
|
|
(send e change-style unread-delta before (+ before 1)))
|
|
(when (memq 'marked (message-flags m))
|
|
(send e change-style marked-delta before (+ before 1)))
|
|
(send e end-edit-sequence)
|
|
i))
|
|
|
|
(define display-text%
|
|
(html-text-mixin
|
|
(text:foreground-color-mixin
|
|
text:standard-style-list%)))
|
|
|
|
;; Class for the panel that has columns titles and
|
|
;; supports clicks to change the sort order
|
|
(define sorting-list%
|
|
(class hierarchical-list%
|
|
(inherit get-editor selectable set-no-sublists)
|
|
|
|
(define/private (find-sorting-key evt)
|
|
(let loop ([editor (get-editor)])
|
|
(when editor
|
|
(let ([xb (box (send evt get-x))]
|
|
[yb (box (send evt get-y))])
|
|
(send editor global-to-local xb yb)
|
|
(let* ([pos (send editor find-position (unbox xb) (unbox yb))]
|
|
[snip (send editor find-snip pos 'after-or-none)])
|
|
(cond
|
|
[(eq? snip sorting-from-snip) 'from]
|
|
[(eq? snip sorting-subject-snip) 'subject]
|
|
[(eq? snip sorting-uid-snip) 'uid]
|
|
[(is-a? snip editor-snip%)
|
|
(loop (send snip get-editor))]
|
|
[else #f]))))))
|
|
|
|
(define tracking #f)
|
|
(define tracking-on? #f)
|
|
|
|
(define/override (on-event evt)
|
|
(cond
|
|
[(send evt button-down?)
|
|
(set! tracking (find-sorting-key evt))
|
|
(if tracking
|
|
(begin
|
|
(set! tracking-on? #t)
|
|
(reset-sorting-tracking)
|
|
(set-sorting-tracking tracking))
|
|
(begin
|
|
(set! tracking-on? #f)
|
|
(reset-sorting-tracking)))]
|
|
[(and tracking
|
|
(send evt button-up?))
|
|
(let ([sorting-key (find-sorting-key evt)]
|
|
[was-tracking tracking])
|
|
(set! tracking #f)
|
|
(set! tracking-on? #f)
|
|
(and (eq? sorting-key was-tracking)
|
|
(case sorting-key
|
|
[(from) (sort-by-sender)]
|
|
[(subject) (sort-by-subject)]
|
|
[(uid) (sort-by-order-received)])))
|
|
(reset-sorting-tracking)]
|
|
[(and tracking
|
|
(send evt dragging?))
|
|
(let ([sorting-key (find-sorting-key evt)])
|
|
(if (eq? sorting-key tracking)
|
|
(unless tracking-on?
|
|
(set! tracking-on? #t)
|
|
(reset-sorting-tracking)
|
|
(set-sorting-tracking tracking))
|
|
(when tracking-on?
|
|
(set! tracking-on? #f)
|
|
(reset-sorting-tracking))))]
|
|
[tracking
|
|
(set! tracking #f)
|
|
(set! tracking-on? #f)
|
|
(reset-sorting-tracking)]))
|
|
|
|
(super-new (style '(hide-hscroll hide-vscroll)))
|
|
(set-no-sublists #t)
|
|
(selectable #f)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; GUI: Frame, Menus, & Key Bindings ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Message display modes
|
|
(define show-full-headers? #f)
|
|
(define quote-in-reply? #t)
|
|
(define mime-mode? #t)
|
|
(define no-mime-inline? #f)
|
|
(define html-mode? #t)
|
|
(define img-mode? #f)
|
|
(define prefer-text? (get-pref 'sirmail:prefer-text))
|
|
|
|
(define global-keymap (make-object keymap%))
|
|
(send global-keymap add-function "new-mailer"
|
|
(lambda (w e) (start-new-mailer #f "" "" "" "" "" null)))
|
|
(send global-keymap add-function "disconnect"
|
|
(lambda (w e)
|
|
(disconnect)
|
|
(force-disconnect/status)))
|
|
(send global-keymap add-function "get-new-mail"
|
|
(lambda (w e) (get-new-mail)))
|
|
(send global-keymap add-function "archive-current"
|
|
(lambda (w e) (send header-list archive-current-message)))
|
|
(send global-keymap add-function "prev-msg"
|
|
(lambda (w e) (send header-list select-prev)))
|
|
(send global-keymap add-function "next-msg"
|
|
(lambda (w e) (send header-list select-next)))
|
|
(send global-keymap add-function "mark-msg"
|
|
(lambda (w e) (send header-list mark-message #t)))
|
|
(send global-keymap add-function "unmark-msg"
|
|
(lambda (w e) (send header-list unmark-message #t)))
|
|
(send global-keymap add-function "hit-msg"
|
|
(lambda (w e) (send header-list hit)))
|
|
(send global-keymap add-function "scroll-down"
|
|
(lambda (w e)
|
|
(if (send header-list selected-hit?)
|
|
(let*-values ([(e) (send message get-editor)]
|
|
[(x y) (send e editor-location-to-dc-location 0 0)])
|
|
(send e move-position 'down #f 'page)
|
|
(let*-values ([(x2 y2) (send e editor-location-to-dc-location 0 0)])
|
|
(when (= y y2)
|
|
(let ([current (send header-list get-selected)])
|
|
(send header-list select-next)
|
|
(unless (eq? current (send header-list get-selected))
|
|
(send header-list hit))))))
|
|
(send header-list hit))))
|
|
(send global-keymap add-function "scroll-up"
|
|
(lambda (w e)
|
|
(when (send header-list selected-hit?)
|
|
(let ([e (send message get-editor)])
|
|
(send e move-position 'up #f 'page)))))
|
|
(send global-keymap add-function "rewind-msg"
|
|
(lambda (w e) (send header-list rewind-selected)))
|
|
(send global-keymap add-function "forward-msg"
|
|
(lambda (w e) (send header-list forward-selected)))
|
|
(send global-keymap add-function "purge"
|
|
(lambda (w e)
|
|
(purge-marked/update-headers)))
|
|
(send global-keymap add-function "gc"
|
|
(lambda (w e) (collect-garbage) (collect-garbage) (dump-memory-stats)))
|
|
(send global-keymap add-function "show-memory-graph"
|
|
(lambda (w e) (show-memory-graph)))
|
|
|
|
(send global-keymap map-function ":m" "new-mailer")
|
|
(send global-keymap map-function ":g" "get-new-mail")
|
|
(send global-keymap map-function ":a" "archive-current")
|
|
(send global-keymap map-function ":i" "disconnect")
|
|
(send global-keymap map-function ":n" "next-msg")
|
|
(send global-keymap map-function ":p" "prev-msg")
|
|
(send global-keymap map-function ":return" "hit-msg")
|
|
(send global-keymap map-function ":d" "mark-msg")
|
|
(send global-keymap map-function ":u" "unmark-msg")
|
|
(send global-keymap map-function ":space" "scroll-down")
|
|
(send global-keymap map-function ":b" "scroll-up")
|
|
(send global-keymap map-function "#" "purge")
|
|
(send global-keymap map-function "!" "gc")
|
|
(send global-keymap map-function ":z" "show-memory-graph")
|
|
(send global-keymap map-function ":m:left" "rewind-msg")
|
|
(send global-keymap map-function ":d:left" "rewind-msg")
|
|
(send global-keymap map-function ":m:right" "forward-msg")
|
|
(send global-keymap map-function ":d:right" "forward-msg")
|
|
|
|
(define icon (make-object bitmap% (build-path (collection-path "sirmail")
|
|
"postmark.bmp")))
|
|
(define icon-mask (make-object bitmap% (build-path (collection-path "sirmail")
|
|
"postmark-mask.xbm")))
|
|
(unless (and (send icon ok?)
|
|
(send icon-mask ok?))
|
|
(set! icon #f))
|
|
|
|
(define sm-super-frame%
|
|
(frame:standard-menus-mixin
|
|
frame:basic%))
|
|
|
|
(define sm-frame%
|
|
(class sm-super-frame%
|
|
(inherit get-menu-bar set-icon)
|
|
|
|
(define/override (file-menu:create-new?) #f)
|
|
(define/override (file-menu:create-open?) #f)
|
|
(define/override (file-menu:create-open-recent?) #f)
|
|
|
|
;; -------------------- File Menu --------------------
|
|
|
|
(define/override (file-menu:between-save-as-and-print file-menu)
|
|
(make-object menu-item% "&Get New Mail" file-menu
|
|
(lambda (i e) (get-new-mail))
|
|
#\g)
|
|
(make-object menu-item% "&Download All" file-menu
|
|
(lambda (i e) (download-all))
|
|
#\l)
|
|
(make-object menu-item% "Archive Message" file-menu
|
|
(lambda (i e) (send header-list archive-current-message)))
|
|
(make-object separator-menu-item% file-menu)
|
|
(make-object menu-item%
|
|
"&Open Folders List"
|
|
file-menu
|
|
(lambda (x1 x2) (open-folders-window)))
|
|
(make-object separator-menu-item% file-menu)
|
|
(make-object menu-item% "&New Message" file-menu
|
|
(lambda (i e) (start-new-mailer #f "" "" "" "" "" null))
|
|
#\m)
|
|
(make-object menu-item% "&Resume Message..." file-menu
|
|
(lambda (i e)
|
|
(let ([file (get-file "Select message to resume"
|
|
main-frame)])
|
|
(when file
|
|
(start-new-mailer file "" "" "" "" "" null)))))
|
|
(instantiate menu-item% ()
|
|
(label "Send Queued Messages")
|
|
(parent file-menu)
|
|
(demand-callback
|
|
(lambda (menu-item)
|
|
(send menu-item enable (enqueued-messages?))))
|
|
(callback
|
|
(lambda (i e)
|
|
(send-queued-messages))))
|
|
|
|
(make-object separator-menu-item% file-menu)
|
|
(make-object menu-item% "&Save Message As..." file-menu
|
|
(lambda (i e)
|
|
(let ([f (put-file "Save message to"
|
|
main-frame)])
|
|
(when f
|
|
(send (send message get-editor) save-file f 'text))))))
|
|
|
|
(define/override (file-menu:create-print?) #t)
|
|
(define/override (file-menu:print-callback i e)
|
|
(send (send message get-editor) print))
|
|
|
|
(define/override (file-menu:between-print-and-close file-menu)
|
|
(make-object separator-menu-item% file-menu)
|
|
(make-object menu-item% "D&isconnect" file-menu
|
|
(lambda (i e)
|
|
(disconnect)
|
|
(force-disconnect/status))
|
|
#\i))
|
|
|
|
(define/override (file-menu:close-callback i e) (send main-frame on-close))
|
|
(define/override (file-menu:create-quit?) #f)
|
|
|
|
;; -------------------- Help Menu --------------------
|
|
|
|
(define/override (help-menu:after-about menu)
|
|
(make-object menu-item% "&Help" menu
|
|
(lambda (i e)
|
|
(let* ([f (instantiate frame% ("Help")
|
|
[width 500]
|
|
[height 300])]
|
|
[e (make-object text%)]
|
|
[c (make-object editor-canvas% f e)])
|
|
(send e load-file
|
|
(build-path (collection-path "sirmail")
|
|
"doc.txt"))
|
|
(send f show #t))))
|
|
(super help-menu:after-about menu))
|
|
|
|
;; -------------------- Misc. --------------------
|
|
|
|
(inherit get-edit-target-object)
|
|
|
|
[define/override on-size
|
|
(lambda (w h)
|
|
(put-pref 'sirmail:frame-width w)
|
|
(put-pref 'sirmail:frame-height h)
|
|
(update-frame-width)
|
|
(super on-size w h))]
|
|
[define/augment can-close? (lambda ()
|
|
(and (send (get-menu-bar) is-enabled?)
|
|
(inner #t can-close?)))]
|
|
[define/augment on-close (lambda ()
|
|
(logout)
|
|
(set! done? #t)
|
|
(inner (void) on-close))]
|
|
[define/override on-subwindow-char
|
|
(lambda (w e)
|
|
(or (and
|
|
(send (send main-frame get-menu-bar) is-enabled?)
|
|
(or (send global-keymap handle-key-event w e)
|
|
(and (eq? #\tab (send e get-key-code))
|
|
(member w (list header-list message))
|
|
(send (if (eq? w message)
|
|
header-list
|
|
message)
|
|
focus))))
|
|
(super on-subwindow-char w e)))]
|
|
(super-instantiate ())
|
|
(when icon
|
|
(set-icon icon icon-mask 'both))))
|
|
|
|
;; -------------------- Frame Creation --------------------
|
|
|
|
(set! main-frame (make-object sm-frame% mailbox-name #f
|
|
(get-pref 'sirmail:frame-width)
|
|
(get-pref 'sirmail:frame-height)))
|
|
(define mb (send main-frame get-menu-bar))
|
|
|
|
;; -------------------- Message Menu --------------------
|
|
|
|
(define msg-menu (make-object menu% "&Message" mb))
|
|
|
|
(make-object menu-item% "&Reply" msg-menu
|
|
(lambda (i e) (do-reply #f quote-in-reply?))
|
|
#\R)
|
|
(make-object menu-item% "&Follow Up" msg-menu
|
|
(lambda (i e) (do-reply #t quote-in-reply?))
|
|
#\t)
|
|
(make-object menu-item% "F&orward" msg-menu
|
|
(lambda (i e) (do-forward))
|
|
#\W)
|
|
(send (make-object checkable-menu-item% "&Quote Original" msg-menu
|
|
(lambda (item e)
|
|
(set! quote-in-reply? (send item is-checked?))))
|
|
check #t)
|
|
(make-object separator-menu-item% msg-menu)
|
|
(make-object menu-item% "&Mark Selected" msg-menu
|
|
(lambda (i e)
|
|
(send header-list mark-message #t))
|
|
#\D)
|
|
(make-object menu-item% "&Unmark Selected" msg-menu
|
|
(lambda (i e)
|
|
(send header-list unmark-message #t))
|
|
#\U)
|
|
(define (mark-all mark? between?)
|
|
(let* ([marked-uids (map message-uid (filter (if mark?
|
|
(lambda (x) (not (message-marked? x)))
|
|
message-marked?)
|
|
mailbox))]
|
|
[items (send header-list get-items)]
|
|
[selected (send header-list get-selected)])
|
|
(for-each
|
|
(lambda (i)
|
|
(when (member (send i user-data) marked-uids)
|
|
(send i select #t)
|
|
(if mark?
|
|
(send header-list mark-message #f)
|
|
(send header-list unmark-message #f))))
|
|
(if between?
|
|
(let ([drop-some
|
|
(lambda (items)
|
|
(let loop ([items items])
|
|
(if (null? items)
|
|
null
|
|
(if (message-marked? (find-message (send (car items) user-data)))
|
|
items
|
|
(loop (cdr items))))))])
|
|
(reverse (drop-some (reverse (drop-some items)))))
|
|
items))
|
|
(write-mailbox)
|
|
(status "~aarked all" (if mark? "M" "Unm"))
|
|
(if selected
|
|
(send selected select #t)
|
|
(send (send header-list get-selected) select #f))))
|
|
|
|
(make-object menu-item% "Mark All" msg-menu
|
|
(lambda (i e) (mark-all #t #f)))
|
|
(make-object menu-item% "Unmark All" msg-menu
|
|
(lambda (i e) (mark-all #f #f)))
|
|
(make-object menu-item% "Mark All Between Marked" msg-menu
|
|
(lambda (i e) (mark-all #t #t)))
|
|
|
|
(make-object separator-menu-item% msg-menu)
|
|
(make-object menu-item% "&Delete Marked" msg-menu
|
|
(lambda (i e)
|
|
(when (eq? 'yes
|
|
(confirm-box
|
|
"Delete Marked?"
|
|
"Really delete the marked messages?"
|
|
main-frame))
|
|
(purge-marked/update-headers))))
|
|
|
|
(make-object (class menu-item%
|
|
(inherit enable set-label)
|
|
(define/override (on-demand)
|
|
(let ([folder (get-active-folder)])
|
|
(enable folder)
|
|
(when folder
|
|
(set-label (format "&Copy Marked to ~a" folder)))))
|
|
(super-instantiate ()))
|
|
"&Copy Marked to Selected Folder"
|
|
msg-menu
|
|
(lambda x
|
|
(let ([mbox (get-active-folder)])
|
|
(if mbox
|
|
(copy-marked-to mbox)
|
|
(bell)))))
|
|
|
|
(make-object separator-menu-item% msg-menu)
|
|
(define sort-menu (make-object menu% "&Sort" msg-menu))
|
|
(let ([m (make-object menu% "Decode" msg-menu)])
|
|
(letrec ([switch (lambda (item e)
|
|
(if (send item is-checked?)
|
|
(begin
|
|
;; Disable others:
|
|
(send raw check (eq? raw item))
|
|
(send mime-lite check (eq? mime-lite item))
|
|
(send mime check (eq? mime item))
|
|
(send html check (eq? html item))
|
|
(send img check (eq? img item))
|
|
;; Update flags
|
|
(set! mime-mode? (or (send mime is-checked?)
|
|
(send mime-lite is-checked?)
|
|
(send html is-checked?)
|
|
(send img is-checked?)))
|
|
(set! no-mime-inline? (or (send mime-lite is-checked?)))
|
|
(set! html-mode? (or (send html is-checked?)
|
|
(send img is-checked?)))
|
|
(set! img-mode? (send img is-checked?))
|
|
;; Re-decode
|
|
(redisplay-current))
|
|
;; Turn it back on
|
|
(send item check #t)))]
|
|
[raw (make-object checkable-menu-item% "&Raw" m switch)]
|
|
[mime-lite (make-object checkable-menu-item% "MIME &without Inline" m switch)]
|
|
[mime (make-object checkable-menu-item% "&MIME" m switch)]
|
|
[html (make-object checkable-menu-item% "MIME and &HTML" m switch)]
|
|
[img (make-object checkable-menu-item% "MIME, HTML, and &Images" m switch)])
|
|
(send (if (and mime-mode? html-mode?)
|
|
html
|
|
(if mime-mode?
|
|
mime
|
|
raw))
|
|
check #t)
|
|
(make-object separator-menu-item% m)
|
|
(send (make-object checkable-menu-item% "Prefer &Text" m
|
|
(lambda (i e)
|
|
(put-pref 'sirmail:prefer-text (send i is-checked?))
|
|
(set! prefer-text? (send i is-checked?))
|
|
(redisplay-current)))
|
|
check prefer-text?)))
|
|
(define wrap-lines-item
|
|
(make-object checkable-menu-item% "&Wrap Lines" msg-menu
|
|
(lambda (item e)
|
|
(put-pref 'sirmail:wrap-lines (send item is-checked?))
|
|
(send (send message get-editor) auto-wrap
|
|
(send item is-checked?)))))
|
|
(make-object checkable-menu-item% "&View Full Header" msg-menu
|
|
(lambda (i e)
|
|
(set! show-full-headers? (send i is-checked?))
|
|
(redisplay-current)))
|
|
|
|
(make-object menu-item% "by From" sort-menu (lambda (i e) (sort-by-sender)))
|
|
(make-object menu-item% "by Subject" sort-menu (lambda (i e) (sort-by-subject)))
|
|
(make-object menu-item% "by Date" sort-menu (lambda (i e) (sort-by-date)))
|
|
(make-object menu-item% "by Order Received" sort-menu (lambda (i e) (sort-by-order-received)))
|
|
(make-object menu-item% "by Size" sort-menu (lambda (i e) (sort-by-size)))
|
|
(make-object menu-item% "by Header Field..." sort-menu (lambda (i e) (sort-by-header-field)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; GUI: Message List ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define drag-cursor (make-object cursor% 'hand))
|
|
(define plain-cursor (make-object cursor% 'arrow))
|
|
(define arrow+watch-cursor (make-object cursor% 'arrow+watch))
|
|
|
|
(define header-list%
|
|
(class hierarchical-list%
|
|
|
|
(inherit get-items show-focus set-cursor select)
|
|
(field [selected #f])
|
|
|
|
(define/public (mark marked? update?)
|
|
(when selected
|
|
(let* ([uid (send selected user-data)]
|
|
[m (find-message uid)]
|
|
[flags (message-flags m)])
|
|
(unless (eq? (not marked?)
|
|
(not (memq 'marked flags)))
|
|
(set-message-flags! m (if marked?
|
|
(cons 'marked flags)
|
|
(remq 'marked flags)))
|
|
(when update?
|
|
(write-mailbox))
|
|
(apply-style selected
|
|
(if marked?
|
|
marked-delta
|
|
unmarked-delta))
|
|
(when update?
|
|
(status "~aarked"
|
|
(if marked? "M" "Unm")))))))
|
|
|
|
(define/public (archive-current-message)
|
|
(when selected
|
|
(let ([archive-mailbox (ARCHIVE-MAILBOX)])
|
|
(when archive-mailbox
|
|
(let* ([uid (send selected user-data)]
|
|
[item (find-message uid)])
|
|
(header-changing-action
|
|
#f
|
|
(lambda ()
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (bad-break break-ok)
|
|
(with-handlers ([void no-status-handler])
|
|
(copy-messages-to (list item) archive-mailbox)
|
|
(purge-messages (list item) bad-break break-ok)))
|
|
close-frame))))))))
|
|
|
|
(define/public (hit)
|
|
(when selected
|
|
(on-double-select selected)))
|
|
|
|
(define/public (mark-message update?)
|
|
(mark #t update?))
|
|
(define/public (unmark-message update?)
|
|
(mark #f update?))
|
|
(define/public (selected-hit?) (eq? selected current-selected))
|
|
(define/override (on-select i)
|
|
(set! selected i))
|
|
|
|
;; -------------------- Message selection --------------------
|
|
|
|
(define past-selected null)
|
|
(define future-selected null)
|
|
|
|
(define/private (push-selected uid)
|
|
(unless (and (pair? past-selected)
|
|
(equal? uid (car past-selected)))
|
|
(set! future-selected (remove uid future-selected))
|
|
(set! past-selected (cons uid (remove uid past-selected)))))
|
|
|
|
(define/public (rewind-selected)
|
|
(when (pair? past-selected)
|
|
(set! future-selected (cons (car past-selected)
|
|
future-selected))
|
|
(set! past-selected (cdr past-selected)))
|
|
(unless (pair? past-selected)
|
|
(set! past-selected (reverse future-selected))
|
|
(set! future-selected null))
|
|
(set! past-selected (select-from-stack past-selected)))
|
|
|
|
(define/public (forward-selected)
|
|
(unless (pair? future-selected)
|
|
(set! future-selected (reverse past-selected))
|
|
(set! past-selected null))
|
|
(set! future-selected (select-from-stack future-selected))
|
|
(when (pair? future-selected)
|
|
(set! past-selected (cons (car future-selected)
|
|
past-selected))
|
|
(set! future-selected (cdr future-selected))))
|
|
|
|
(define (select-from-stack selected)
|
|
(if (pair? selected)
|
|
(let* ([uid (car selected)]
|
|
[i (ormap (lambda (i)
|
|
(and (equal? uid (send i user-data))
|
|
i))
|
|
(send header-list get-items))])
|
|
(if i
|
|
(begin
|
|
(select i)
|
|
(do-double-select i #f)
|
|
selected)
|
|
(select-from-stack (cdr selected))))
|
|
null))
|
|
|
|
(define/override (on-double-select i)
|
|
(do-double-select i #t))
|
|
|
|
(define/private (do-double-select i push?)
|
|
(let ([e (send message get-editor)]
|
|
[uid (send i user-data)])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(send e lock #f)
|
|
(send e begin-edit-sequence))
|
|
(lambda ()
|
|
(send e erase)
|
|
(set-current-selected #f)
|
|
(let* ([h (get-header uid)]
|
|
[small-h (get-viewable-headers h)])
|
|
(send e insert
|
|
(string-crlf->lf small-h)
|
|
0 'same #f)
|
|
;; Do the body (possibly mime)
|
|
(let ([body (as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(get-body uid break-bad break-ok))
|
|
close-frame)]
|
|
[insert (lambda (body delta)
|
|
(let ([start (send e last-position)])
|
|
(send e set-position start)
|
|
(send e insert
|
|
body
|
|
start 'same #f)
|
|
(let ([end (send e last-position)])
|
|
(delta e start end))))])
|
|
(when push?
|
|
(push-selected uid))
|
|
(parse-and-insert-body h body e insert 78 img-mode?)))
|
|
(send e set-position 0)
|
|
(set-current-selected i))
|
|
(lambda ()
|
|
(send e end-edit-sequence)
|
|
(send e lock #t)))))
|
|
|
|
;; -------------------- Message drag'n'drop --------------------
|
|
|
|
(inherit get-editor client->screen)
|
|
(field (dragging-item #f)
|
|
(dragging-title #f)
|
|
(last-status #f)
|
|
(drag-start-x 0)
|
|
(drag-start-y 0))
|
|
(define/override (on-event evt)
|
|
(cond
|
|
[(send evt button-down?)
|
|
(when dragging-item
|
|
(status "")
|
|
(send (get-editor) set-cursor plain-cursor)
|
|
(set! dragging-item #f))
|
|
(let ([text (get-editor)])
|
|
(when text
|
|
(let ([xb (box (send evt get-x))]
|
|
[yb (box (send evt get-y))])
|
|
(send text global-to-local xb yb)
|
|
(let* ([pos (send text find-position (unbox xb) (unbox yb))]
|
|
[snip (send text find-snip pos 'after-or-none)]
|
|
[item (and (is-a? snip hierarchical-item-snip%)
|
|
(send snip get-item))])
|
|
(set! dragging-title "???")
|
|
(set! dragging-item item)
|
|
(set! drag-start-x (send evt get-x))
|
|
(set! drag-start-y (send evt get-y))
|
|
(when dragging-item
|
|
(let* ([ud (send dragging-item user-data)]
|
|
[message (find-message ud)]
|
|
[cap-length 50])
|
|
(when message
|
|
(let ([title (message-subject message)])
|
|
(cond
|
|
[(not title) (set! dragging-title no-subject-string)]
|
|
[((string-length title) . <= . cap-length)
|
|
(set! dragging-title title)]
|
|
[else
|
|
(set! dragging-title
|
|
(string-append (substring title 0 (- cap-length 3)) "..."))])))))))))]
|
|
[(send evt dragging?)
|
|
(when dragging-item
|
|
(when (or ((abs (- (send evt get-x) drag-start-x)) . > . 5)
|
|
((abs (- (send evt get-y) drag-start-y)) . > . 5))
|
|
(send (get-editor) set-cursor drag-cursor))
|
|
(let-values ([(gx gy) (client->screen (send evt get-x) (send evt get-y))])
|
|
(let ([mailbox-name (send-message-to-window gx gy (list gx gy))])
|
|
(if (string? mailbox-name)
|
|
(status "Move message \"~a\" to ~a" dragging-title mailbox-name)
|
|
(status "")))))]
|
|
[(send evt button-up?)
|
|
(when dragging-item
|
|
(send (get-editor) set-cursor plain-cursor)
|
|
(let-values ([(gx gy) (client->screen (send evt get-x) (send evt get-y))]
|
|
[(ditem) dragging-item])
|
|
(set! dragging-item #f)
|
|
(let ([mailbox-name (send-message-to-window gx gy (list gx gy))])
|
|
(if (bytes? mailbox-name)
|
|
(let* ([user-data (send ditem user-data)]
|
|
[item (find-message user-data)])
|
|
(when item
|
|
(header-changing-action
|
|
#f
|
|
(lambda ()
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (bad-break break-ok)
|
|
(with-handlers ([void no-status-handler])
|
|
(void)
|
|
(copy-messages-to (list item) mailbox-name)
|
|
(purge-messages (list item) bad-break break-ok)))
|
|
close-frame)))))
|
|
(status "")))))]
|
|
[else
|
|
(when (and dragging-item
|
|
(not (and (or (send evt leaving?)
|
|
(send evt entering?))
|
|
(or (send evt get-left-down)
|
|
(send evt get-middle-down)
|
|
(send evt get-right-down)))))
|
|
(set! dragging-item #f)
|
|
(send (get-editor) set-cursor plain-cursor)
|
|
(status ""))])
|
|
|
|
(super on-event evt))
|
|
|
|
(super-new (style '(no-hscroll)))
|
|
(show-focus #t)))
|
|
|
|
;; header-changing-action: bool thunk -> thunk-result
|
|
;; Use this function to bracket operations that change
|
|
;; `mailbox'. It will use before an after values to update
|
|
;; the message list.
|
|
(define (header-changing-action downloads? go)
|
|
(let ([old-mailbox mailbox])
|
|
(dynamic-wind
|
|
void
|
|
go
|
|
(lambda ()
|
|
(let ([items (send header-list get-items)]
|
|
[selected (send header-list get-selected)]
|
|
[need-del-selection? #f]
|
|
[set-selection? #f])
|
|
(send (send header-list get-editor) begin-edit-sequence)
|
|
(for-each
|
|
(lambda (i)
|
|
(let ([a (find-message (send i user-data))])
|
|
(if a
|
|
(begin ; Message still here
|
|
(when (and downloads? (message-downloaded? a))
|
|
(apply-style i read-delta))
|
|
(when need-del-selection?
|
|
(set! need-del-selection? #f)
|
|
(send i select #t)))
|
|
(begin ; Message gone
|
|
(when (eq? i selected)
|
|
(set! need-del-selection? #t))
|
|
(when (eq? i current-selected)
|
|
(let ([e (send message get-editor)])
|
|
(send e begin-edit-sequence)
|
|
(send e lock #f)
|
|
(send e erase)
|
|
(send e lock #t)
|
|
(send e end-edit-sequence))
|
|
(set-current-selected #f))
|
|
(send header-list delete-item i)))))
|
|
items)
|
|
(let ([old-ids (make-hash-table 'equal)])
|
|
(for-each (lambda (m)
|
|
(hash-table-put! old-ids (message-uid m) #t))
|
|
old-mailbox)
|
|
(for-each
|
|
(lambda (m)
|
|
(unless (hash-table-get old-ids (message-uid m) #f)
|
|
(let ([i (add-message m)])
|
|
(unless set-selection?
|
|
(set! set-selection? #t)
|
|
(send i select #t)
|
|
(send i scroll-to)))))
|
|
mailbox))
|
|
(send (send header-list get-editor) end-edit-sequence))))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; GUI: Message Operations ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Closes connections and terminates the window
|
|
(define (logout)
|
|
(with-handlers ([void
|
|
(lambda (x)
|
|
(show-error x)
|
|
(when (eq? 'yes
|
|
(confirm-box
|
|
"Error"
|
|
"There was an error disconnecting. Exit anyway?"
|
|
main-frame))
|
|
(exit-sirmail "read-window exception (1)")
|
|
(send main-frame show #f)))])
|
|
(disconnect)
|
|
(when biff (send biff stop))
|
|
(exit-sirmail "read-window exception (2)")
|
|
(send main-frame show #f)))
|
|
|
|
(define (get-new-mail)
|
|
(with-handlers ([void
|
|
(lambda (x)
|
|
(status "")
|
|
(if (send disconnected-msg is-shown?)
|
|
(raise x)
|
|
(begin
|
|
(show-error x)
|
|
(when (exn:fail:network? x)
|
|
(when (eq? 'yes
|
|
(confirm-box
|
|
"Error"
|
|
(format "There was an communication error.~nClose the connection?")
|
|
main-frame))
|
|
(force-disconnect/status))))))])
|
|
(header-changing-action
|
|
#f
|
|
(lambda ()
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(when (or (not initialized?)
|
|
(check-for-new break-bad break-ok))
|
|
(update-local break-bad break-ok)))
|
|
close-frame)))))
|
|
|
|
(define (purge-marked/update-headers)
|
|
(header-changing-action
|
|
#f
|
|
(lambda ()
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(with-handlers ([void no-status-handler])
|
|
(purge-marked break-bad break-ok)))
|
|
close-frame))))
|
|
|
|
(define (copy-marked-to dest-mailbox-name)
|
|
(let* ([marked (filter message-marked? mailbox)])
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(copy-messages-to marked dest-mailbox-name))
|
|
close-frame)))
|
|
|
|
(define (copy-messages-to marked dest-mailbox-name)
|
|
(unless (null? marked)
|
|
(let-values ([(imap count new?) (connect)])
|
|
(check-positions imap marked)
|
|
(status "Copying messages to ~a..." dest-mailbox-name)
|
|
(imap-copy imap (map message-position marked) dest-mailbox-name)
|
|
(status "Copied to ~a" dest-mailbox-name))))
|
|
|
|
(define (auto-file)
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(break-ok)
|
|
(map
|
|
(lambda (auto)
|
|
(let* ([dest-mailbox-name (car auto)]
|
|
[fields (map car (cadr auto))]
|
|
[val-rxs (map string->regexp (map cadr (cadr auto)))])
|
|
(with-handlers ([void no-status-handler])
|
|
(break-ok)
|
|
(status "Finding ~a messages..." dest-mailbox-name)
|
|
(let ([file-msgs
|
|
(filter
|
|
(lambda (m)
|
|
(and (not (message-marked? m))
|
|
(let ([h (get-header (message-uid m))])
|
|
(ormap (lambda (field val-rx)
|
|
(let ([v (extract-field field h)])
|
|
(and v (regexp-match val-rx v))))
|
|
fields val-rxs))))
|
|
mailbox)])
|
|
(unless (null? file-msgs)
|
|
(status "Filing to ~a..." dest-mailbox-name)
|
|
(break-bad)
|
|
(let-values ([(imap count new?) (connect)])
|
|
(status (format "Filing to ~a..." dest-mailbox-name))
|
|
; Copy messages for filing:
|
|
(imap-copy imap (map message-position file-msgs) dest-mailbox-name)
|
|
; Mark them (let the user delete)
|
|
(for-each (lambda (m)
|
|
(set-message-flags! m (cons 'marked (message-flags m)))
|
|
(let ([i (let ([items (send header-list get-items)]
|
|
[uid (message-uid m)])
|
|
(ormap (lambda (i) (and (eq? (send i user-data) uid)
|
|
i))
|
|
items))])
|
|
(apply-style i marked-delta)))
|
|
file-msgs)
|
|
(write-mailbox)))))))
|
|
(AUTO-FILE-TABLE)))
|
|
close-frame)
|
|
(status "Auto file done"))
|
|
|
|
(define (download-all)
|
|
(get-new-mail)
|
|
(header-changing-action
|
|
#t
|
|
(lambda ()
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(with-handlers ([exn:break?
|
|
(lambda (x) "<interrupted>")])
|
|
(break-ok)
|
|
(with-handlers ([exn:break? (lambda (x) (void))])
|
|
(for-each (lambda (message)
|
|
(let ([uid (message-uid message)])
|
|
(break-bad)
|
|
(get-body uid break-bad break-ok)
|
|
(break-ok)))
|
|
mailbox))))
|
|
close-frame))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; GUI: Rest of Frame ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define sizing-panel (make-object panel:vertical-dragable% (send main-frame get-area-container)))
|
|
(define top-half (make-object vertical-panel% sizing-panel))
|
|
(define button-panel (new horizontal-panel%
|
|
(parent top-half)
|
|
(stretchable-height #f)))
|
|
(define sorting-list (instantiate sorting-list% ()
|
|
(parent top-half)
|
|
(stretchable-height #f)
|
|
(vertical-inset 1)))
|
|
(define header-list (make-object header-list% top-half))
|
|
(send (send header-list get-editor) set-line-spacing 0)
|
|
(define message (new canvas:color%
|
|
[parent sizing-panel]
|
|
[style '(auto-hscroll)]))
|
|
(send header-list min-height 20)
|
|
(send header-list stretchable-height #t)
|
|
(send header-list set-no-sublists #t)
|
|
(send main-frame reflow-container)
|
|
(with-handlers ([void void])
|
|
(send sizing-panel set-percentages (list 1/3 2/3)))
|
|
(let ([e (make-object display-text%)])
|
|
((current-text-keymap-initializer) (send e get-keymap))
|
|
(send e set-max-undo-history 0)
|
|
(send message set-editor e)
|
|
(make-fixed-width message e #f #f)
|
|
(let ([b (make-object bitmap% (build-path (collection-path "icons") "return.xbm") 'xbm)])
|
|
(when (send b ok?)
|
|
(send e set-autowrap-bitmap b)))
|
|
(send e lock #t))
|
|
|
|
(when (get-pref 'sirmail:wrap-lines)
|
|
(send wrap-lines-item check #t)
|
|
(send (send message get-editor) auto-wrap #t))
|
|
|
|
;; enable-main-frame - use with `as-background'
|
|
(define can-poll? #t)
|
|
(define (enable-main-frame on? refocus break-proc)
|
|
(let ([w (send main-frame get-focus-window)])
|
|
(set! can-poll? on?)
|
|
(send sorting-list enable on?)
|
|
(send header-list enable on?)
|
|
(send message enable on?)
|
|
(let* ([cursor (if on? plain-cursor arrow+watch-cursor)])
|
|
(send main-frame set-cursor cursor)
|
|
(send (send sorting-list get-editor) set-cursor cursor #t)
|
|
(send (send header-list get-editor) set-cursor cursor #t)
|
|
(send (send message get-editor) set-cursor (if on? #f cursor) #t))
|
|
(send (send main-frame get-menu-bar) enable on?)
|
|
(set! cancel-button-todo break-proc)
|
|
(send cancel-button enable (not on?))
|
|
(when (and on? refocus)
|
|
(send refocus focus))
|
|
w))
|
|
|
|
(define (close-frame)
|
|
(send main-frame show #f))
|
|
|
|
(define no-status-handler (lambda (x) (status "") (raise x)))
|
|
|
|
(define disable-button-panel (make-object horizontal-panel% button-panel))
|
|
(define mailbox-message (make-object message% (format "~a: XXXXX" mailbox-name) disable-button-panel))
|
|
(define (display-message-count n)
|
|
(send mailbox-message set-label (format "~a: ~a" mailbox-name n)))
|
|
(display-message-count (length mailbox))
|
|
(define new-mail-message%
|
|
(class canvas%
|
|
(inherit get-dc get-client-size get-parent
|
|
horiz-margin vert-margin)
|
|
(init-field font)
|
|
(define message "<<unset>>")
|
|
(define/override (on-paint)
|
|
(let ([dc (get-dc)])
|
|
(send dc set-font font)
|
|
(let-values ([(w h) (get-client-size)]
|
|
[(tw th ta td) (send dc get-text-extent message)])
|
|
(send dc set-pen (send the-pen-list find-or-create-pen (get-panel-background) 1 'transparent))
|
|
(send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
|
|
(send dc draw-rectangle 0 0 w h)
|
|
(send dc draw-text message
|
|
(- (/ w 2) (/ tw 2))
|
|
(- (/ h 2) (/ th 2))
|
|
#t))))
|
|
(define/public (set-message n)
|
|
(set! message
|
|
(cond
|
|
[(get-pref 'sirmail:always-happy) "New Mail!"]
|
|
[(n . <= . 50) "New Mail!"]
|
|
[(n . <= . 200) "New Mail"]
|
|
[else "New Mail!@#$%"]))
|
|
(update-min-width))
|
|
(inherit min-width)
|
|
(define/private (update-min-width)
|
|
(let-values ([(w h d s) (send (get-dc) get-text-extent message font)])
|
|
(min-width (inexact->exact (ceiling w)))))
|
|
(super-new (style '(transparent)))
|
|
(update-min-width)
|
|
(inherit stretchable-width)
|
|
(horiz-margin 2)
|
|
(vert-margin 2)
|
|
(stretchable-width #f)))
|
|
|
|
(define-values (show-new-mail-msg hide-new-mail-msg disconnected-msg enqueued-msg)
|
|
(let* ([font (make-object font% (send normal-control-font get-point-size) 'system 'normal 'bold)])
|
|
(let ([spacer (make-object message% " " disable-button-panel)]
|
|
[m (make-object new-mail-message% font disable-button-panel)]
|
|
[d (new message% [label "Disconnected"] [parent disable-button-panel] [font font])]
|
|
[e-msg (new message% [label "Mail Enqueued"] [parent disable-button-panel] [font font])])
|
|
(send m show #f)
|
|
(send e-msg show #f)
|
|
(values (lambda ()
|
|
(send m set-message (length mailbox))
|
|
(send m show #t))
|
|
(lambda () (send m show #f))
|
|
d
|
|
e-msg))))
|
|
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(unless (and (object? main-frame)
|
|
(send main-frame is-shown?)
|
|
(procedure? enqueued-messages?))
|
|
(sleep 1/2)
|
|
(loop)))
|
|
(let loop ()
|
|
(when (send main-frame is-shown?)
|
|
(send enqueued-msg show (enqueued-messages?))
|
|
(sleep 1/2)
|
|
(loop)))))
|
|
|
|
;; Optional GC icon (lots of work for this little thing!)
|
|
(when (get-pref 'sirmail:show-gc-icon)
|
|
(let* ([gif (make-object bitmap% (build-path (collection-path "icons") "recycle.png"))]
|
|
[w (send gif get-width)]
|
|
[h (send gif get-height)]
|
|
[scale 1]
|
|
[recycle-bm (make-object bitmap% (quotient w scale) (quotient h scale))]
|
|
[dc (make-object bitmap-dc% recycle-bm)])
|
|
(send dc set-scale (/ 1 scale) (/ 1 scale))
|
|
(send dc draw-bitmap gif 0 0)
|
|
(send dc set-bitmap #f)
|
|
(let* ([w (send recycle-bm get-width)]
|
|
[h (send recycle-bm get-height)]
|
|
[canvas (instantiate canvas% (button-panel)
|
|
[stretchable-width #f]
|
|
[stretchable-height #f]
|
|
[style '(border)])]
|
|
[empty-bm (make-object bitmap% w h)]
|
|
[dc (make-object bitmap-dc% empty-bm)])
|
|
(send canvas min-client-width w)
|
|
(send canvas min-client-height h)
|
|
(send dc clear)
|
|
(send dc set-bitmap #f)
|
|
(register-collecting-blit canvas
|
|
0 0 w h
|
|
recycle-bm empty-bm
|
|
0 0 0 0))))
|
|
|
|
(define cancel-button
|
|
(make-object button% "Stop" button-panel
|
|
(lambda (b e) (cancel-button-todo))))
|
|
(define cancel-button-todo void)
|
|
(send cancel-button enable #f)
|
|
|
|
;; -------------------- Status Line --------------------
|
|
|
|
(define last-status "")
|
|
(define status-sema (make-semaphore 1))
|
|
(define (status . args)
|
|
(semaphore-wait status-sema)
|
|
(let ([s (apply format args)])
|
|
(unless (equal? s last-status)
|
|
(set! last-status s)
|
|
(update-status-text)))
|
|
(semaphore-post status-sema))
|
|
|
|
;; update-status-text : -> void
|
|
;; =any thread=
|
|
(define (update-status-text)
|
|
(let ([mem-str
|
|
(if (and vsz rss)
|
|
(format "(mz: ~a vsz: ~a rss: ~a vocab: ~a)"
|
|
(format-number (quotient (current-memory-use) 1024))
|
|
vsz
|
|
rss
|
|
(word-count))
|
|
(format "(mz: ~a vocab: ~a)"
|
|
(format-number (quotient (current-memory-use) 1024))
|
|
(word-count)))])
|
|
(send main-frame set-status-text
|
|
(if (equal? last-status "")
|
|
mem-str
|
|
(string-append last-status " " mem-str)))))
|
|
(thread
|
|
(lambda ()
|
|
(let loop ()
|
|
(semaphore-wait status-sema)
|
|
(when (object? main-frame)
|
|
(update-status-text))
|
|
(semaphore-post status-sema)
|
|
(sleep 5)
|
|
(unless done?
|
|
(loop)))))
|
|
|
|
(define vsz #f)
|
|
(define rss #f)
|
|
(define (start-vsz/rss-thread)
|
|
(thread
|
|
(lambda ()
|
|
(define (get-numbers)
|
|
(with-handlers ([exn:fail? (lambda (x) #f)])
|
|
(let ([re:nums #rx"[^ \t]*[ \t]*[^ \t]*[ \t]*[^ \t]*[ \t]*[^ \t]*[ \t]*([0-9]*)[ \t]*([0-9]*)[ \t]*"])
|
|
(let ([m (regexp-match re:nums (get-lines))])
|
|
(and m
|
|
(map string->number (cdr m)))))))
|
|
(define command "ps wwaux | grep SirMail | grep -v grep")
|
|
|
|
(define (get-lines)
|
|
(let ([p (open-output-string)])
|
|
(parameterize ([current-output-port p]
|
|
[current-input-port (open-input-string "")])
|
|
(system command))
|
|
(get-output-string p)))
|
|
|
|
(let loop ()
|
|
(let ([v (get-numbers)])
|
|
(when (and v (send main-frame is-shown?))
|
|
(set! vsz (format-number (car v)))
|
|
(set! rss (format-number (cadr v)))
|
|
(sleep 10)
|
|
(loop)))))))
|
|
|
|
;; copied from framerok/private/frame.sss -- be sure to propogate fixes....
|
|
;; or establish single point of control.
|
|
(define (format-number n)
|
|
(if n
|
|
(let loop ([n n])
|
|
(cond
|
|
[(<= n 1000) (number->string n)]
|
|
[else
|
|
(string-append
|
|
(loop (quotient n 1000))
|
|
","
|
|
(pad-to-3 (modulo n 1000)))]))
|
|
"???"))
|
|
|
|
(define (pad-to-3 n)
|
|
(cond
|
|
[(<= n 9) (format "00~a" n)]
|
|
[(<= n 99) (format "0~a" n)]
|
|
[else (number->string n)]))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; GUI: Sorting ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(send sorting-list min-height 5)
|
|
(define sorting-text (send (send sorting-list new-item) get-editor))
|
|
(define sorting-text-from (make-object text%))
|
|
(send sorting-text-from insert "From")
|
|
(define sorting-text-subject (make-object text%))
|
|
(send sorting-text-subject insert "Subject")
|
|
(define sorting-text-uid (make-object text%))
|
|
(send sorting-text-uid insert "UID")
|
|
(define (add-sorting-es text width)
|
|
(let ([es (instantiate editor-snip% ()
|
|
(with-border? #f)
|
|
(editor text)
|
|
(top-margin 1)
|
|
(top-inset 1)
|
|
(bottom-margin 1)
|
|
(bottom-inset 1))])
|
|
(send sorting-text insert es)
|
|
(send es set-flags (remove 'handles-events (send es get-flags)))
|
|
es))
|
|
(send sorting-list set-line-count 1)
|
|
(define sorting-from-snip (add-sorting-es sorting-text-from FROM-WIDTH))
|
|
(send sorting-text insert (make-object vertical-line-snip%))
|
|
(define sorting-subject-snip (add-sorting-es sorting-text-subject SUBJECT-WIDTH))
|
|
(send sorting-text insert (make-object vertical-line-snip%))
|
|
(define sorting-uid-snip (add-sorting-es sorting-text-uid UID-WIDTH))
|
|
|
|
(when (AUTO-FILE-TABLE)
|
|
(make-object separator-menu-item% msg-menu)
|
|
(make-object menu-item% "Auto File" msg-menu
|
|
(lambda (i e)
|
|
(auto-file))))
|
|
|
|
(define (redisplay-current)
|
|
(when current-selected
|
|
(send header-list on-double-select current-selected)))
|
|
|
|
(define (sort-by-date)
|
|
(sort-by-fields (list (list "date" date-cmp)))
|
|
(reset-sorting-text-styles))
|
|
(define (sort-by-sender)
|
|
(sort-by from<?)
|
|
(reset-sorting-text-styles)
|
|
(identify-sorted sorting-text-from))
|
|
(define (sort-by-subject)
|
|
(sort-by subject<?)
|
|
(reset-sorting-text-styles)
|
|
(identify-sorted sorting-text-subject))
|
|
(define (sort-by-size)
|
|
(sort-by size<?)
|
|
(reset-sorting-text-styles)
|
|
(identify-sorted sorting-text-subject))
|
|
(define (sort-by-order-received)
|
|
(sort-by-uid)
|
|
(reset-sorting-text-styles)
|
|
(identify-sorted sorting-text-uid))
|
|
|
|
(define prev-field-list "")
|
|
(define prev-field-regexp "")
|
|
(define (sort-by-header-field)
|
|
(letrec ([d (new dialog%
|
|
[parent main-frame]
|
|
[label "Header Search"]
|
|
[stretchable-width #f]
|
|
[stretchable-height #f])]
|
|
[text-pane (new vertical-pane%
|
|
[parent d]
|
|
[alignment '(left center)]
|
|
[stretchable-height #f])]
|
|
[t1 (new message%
|
|
[parent text-pane]
|
|
[label "Sorts messages with matching fields before non-matching;"])]
|
|
[t2 (new message%
|
|
[parent text-pane]
|
|
[label "use a comma to separate multiple field names"])]
|
|
[text-change-callback
|
|
(lambda (txt e)
|
|
(check-enable-ok)
|
|
(when (and (eq? 'text-field-enter
|
|
(send e get-event-type))
|
|
(send ok is-enabled?))
|
|
(do-ok)))]
|
|
[field-text (new text-field%
|
|
[parent d]
|
|
[label "Header Field(s):"]
|
|
[callback text-change-callback]
|
|
[init-value prev-field-list])]
|
|
[regexp-text (new text-field%
|
|
[parent d]
|
|
[label "Value Regexp:"]
|
|
[callback text-change-callback]
|
|
[init-value prev-field-regexp])]
|
|
[buttons-panel (new horizontal-panel%
|
|
[parent d]
|
|
[stretchable-height #f]
|
|
[alignment '(right center)])]
|
|
[ok (new button%
|
|
[parent buttons-panel]
|
|
[label "Ok"]
|
|
[style '(border)]
|
|
[callback (lambda (b e)(do-ok))])]
|
|
[cancel (new button%
|
|
[parent buttons-panel]
|
|
[label "Cancel"]
|
|
[callback (lambda (b e)
|
|
(send d show #f))])]
|
|
[find-field-list #f]
|
|
[find-fields #f]
|
|
[find-regexp #f]
|
|
[ok? #f]
|
|
[check-enable-ok
|
|
(lambda ()
|
|
(set! find-field-list (send field-text get-value))
|
|
(set! find-fields (regexp-split #rx" *, *" find-field-list))
|
|
(set! find-regexp (send regexp-text get-value))
|
|
(send ok enable
|
|
(and (andmap (lambda (find-field)
|
|
(and (positive? (string-length find-field))
|
|
(regexp-match #rx"^[a-zA-Z0-9-]+$" find-field)))
|
|
find-fields)
|
|
(with-handlers ([void (lambda (x) #f)]) (regexp find-regexp)))))]
|
|
[do-ok (lambda ()
|
|
(set! ok? #t)
|
|
(send d show #f))])
|
|
(send d show #t)
|
|
(when ok?
|
|
(set! prev-field-list find-field-list)
|
|
(set! prev-field-regexp find-regexp)
|
|
(sort-by (field<? find-fields (regexp find-regexp) (make-hash-table 'equal)))
|
|
(reset-sorting-text-styles))))
|
|
|
|
(define no-sort-style-delta (make-object style-delta% 'change-normal))
|
|
(define sort-style-delta (make-object style-delta% 'change-bold))
|
|
(send sort-style-delta set-delta-foreground "blue")
|
|
(define tracking-style-delta (make-object style-delta%))
|
|
(send tracking-style-delta set-delta-background "Gray")
|
|
(define not-tracking-style-delta (make-object style-delta%))
|
|
(send not-tracking-style-delta set-delta-background "White")
|
|
(define (reset-sorting-text-styles)
|
|
(send sorting-text-from change-style no-sort-style-delta 0 (send sorting-text-from last-position))
|
|
(send sorting-text-uid change-style no-sort-style-delta 0 (send sorting-text-uid last-position))
|
|
(send sorting-text-subject change-style no-sort-style-delta 0 (send sorting-text-subject last-position)))
|
|
(define (identify-sorted text)
|
|
(send text change-style sort-style-delta 0 (send text last-position)))
|
|
(define (reset-sorting-tracking)
|
|
(send sorting-text-from change-style not-tracking-style-delta 0 (send sorting-text-from last-position))
|
|
(send sorting-text-uid change-style not-tracking-style-delta 0 (send sorting-text-uid last-position))
|
|
(send sorting-text-subject change-style not-tracking-style-delta 0 (send sorting-text-subject last-position)))
|
|
(define (set-sorting-tracking which)
|
|
(let ([text (case which
|
|
[(from) sorting-text-from]
|
|
[(subject) sorting-text-subject]
|
|
[(uid) sorting-text-uid])])
|
|
(send text change-style tracking-style-delta 0 (send text last-position))))
|
|
|
|
(reset-sorting-text-styles)
|
|
(identify-sorted sorting-text-uid)
|
|
|
|
(define re:date
|
|
(regexp
|
|
"([0-9]*)[ ]+([A-Za-z]+)[ ]+([0-9]+)[ ]+([0-9][0-9]):([0-9][0-9]):([0-9][0-9])"))
|
|
|
|
;; using the tz seems to require a date->seconds -- too expensive.
|
|
(define (date-cmp aid bid a b)
|
|
(define (month->number mon)
|
|
(string-lowercase! mon)
|
|
(case (string->symbol mon)
|
|
[(jan) 1]
|
|
[(feb) 2]
|
|
[(mar) 3]
|
|
[(apr) 4]
|
|
[(may) 5]
|
|
[(jun) 6]
|
|
[(jul) 7]
|
|
[(aug) 8]
|
|
[(sep) 9]
|
|
[(oct) 10]
|
|
[(nov) 11]
|
|
[(dec) 12]))
|
|
|
|
(define (pairwise-cmp l1 l2)
|
|
(cond
|
|
[(and (null? l1) (null? l2)) 'same]
|
|
[(or (null? l1) (null? l2)) (error 'pairwise-cmp "internal error; date lists mismatched")]
|
|
[(= (car l1) (car l2)) (pairwise-cmp (cdr l1) (cdr l2))]
|
|
[else (< (car l1) (car l2))]))
|
|
|
|
(define (get-date a)
|
|
(let* ([m (regexp-match re:date a)])
|
|
(if m
|
|
(let* ([datel (cdr m)]
|
|
[day (string->number (first datel))]
|
|
[month (month->number (second datel))]
|
|
[year (string->number (third datel))]
|
|
[hours (string->number (fourth datel))]
|
|
[minutes (string->number (fifth datel))]
|
|
[seconds (string->number (sixth datel))])
|
|
(list year month day
|
|
hours minutes seconds))
|
|
(list 0 0 0
|
|
0 0 0))))
|
|
|
|
(pairwise-cmp
|
|
(get-date a)
|
|
(get-date b)))
|
|
|
|
(define re:quote "[\"<>]")
|
|
;; from<? : message message -> boolean
|
|
;; compares messages by from lines, defaults to uid if froms are equal.
|
|
(define (from<? a b)
|
|
(string-cmp/default-uid (get-address a)
|
|
(get-address b)
|
|
a
|
|
b))
|
|
|
|
;; get-address : message -> string
|
|
(define (get-address msg)
|
|
(let ([frm (message-from msg)])
|
|
(if frm
|
|
(hash-table-get
|
|
address-memo-table
|
|
frm
|
|
(lambda ()
|
|
(let ([res
|
|
(with-handlers ([exn:fail? (lambda (x) "")])
|
|
(regexp-replace* re:quote
|
|
(car (extract-addresses
|
|
frm
|
|
'address))
|
|
""))])
|
|
(hash-table-put! address-memo-table frm res)
|
|
res)))
|
|
"")))
|
|
|
|
;; get-address : message -> string
|
|
(define address-memo-table (make-hash-table 'equal))
|
|
|
|
(define ((field<? field-names rx ht) a b)
|
|
(let ([a? (match-field a field-names rx ht)]
|
|
[b? (match-field b field-names rx ht)])
|
|
(cond
|
|
[(and a? (not b?)) #t]
|
|
[(and b? (not a?)) #f]
|
|
[else (< (message-uid a) (message-uid b))])))
|
|
|
|
(define (match-field msg field-names rx ht)
|
|
(hash-table-get
|
|
ht
|
|
msg
|
|
(lambda ()
|
|
(let ([header (get-header (message-uid msg))])
|
|
(let ([flds (map (lambda (field-name)
|
|
(extract-field field-name header))
|
|
field-names)])
|
|
(let ([res (ormap (lambda (fld)
|
|
(and fld
|
|
(regexp-match rx fld)
|
|
#t))
|
|
flds)])
|
|
(hash-table-put! ht msg res)
|
|
res))))))
|
|
|
|
(define re:re (regexp "^[rR][eE]: *(.*)"))
|
|
;; subject<? : message message -> boolean
|
|
;; compares messages by subject lines, defaults to uid if subjects are equal.
|
|
(define (subject<? a b)
|
|
(let ([simplify (lambda (msg)
|
|
(let ([s (message-subject msg)])
|
|
(if s
|
|
(let ([m (regexp-match re:re s)])
|
|
(if m
|
|
(cadr m)
|
|
s))
|
|
"")))])
|
|
(string-cmp/default-uid (simplify a) (simplify b) a b)))
|
|
|
|
(define (size<? a b)
|
|
(let ([sa (or (message-size a) 0)]
|
|
[sb (or (message-size b) 0)])
|
|
(if (= sa sb)
|
|
(< (message-uid a) (message-uid b))
|
|
(< sa sb))))
|
|
|
|
;; string-cmp : string string message message -> boolean
|
|
(define (string-cmp/default-uid str-a str-b a b)
|
|
(if (string-locale-ci=? str-a str-b)
|
|
(< (message-uid a) (message-uid b))
|
|
(string-locale-ci<? str-a str-b)))
|
|
|
|
(define (sort-by compare)
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(status "Sorting...")
|
|
(send header-list sort
|
|
(lambda (a b)
|
|
(let* ([aid (send a user-data)]
|
|
[bid (send b user-data)]
|
|
[ma (find-message aid)]
|
|
[mb (find-message bid)])
|
|
(compare ma mb))))
|
|
(status ""))
|
|
close-frame))
|
|
|
|
(define (sort-by-uid)
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(status "Sorting...")
|
|
(send header-list sort
|
|
(lambda (a b)
|
|
(let ([aid (send a user-data)]
|
|
[bid (send b user-data)])
|
|
(< aid bid))))
|
|
(status ""))
|
|
close-frame))
|
|
|
|
(define (sort-by-fields fields)
|
|
(let* ([ht (make-hash-table)]
|
|
[get-header/cached
|
|
(lambda (uid first-field)
|
|
(hash-table-get
|
|
ht
|
|
uid
|
|
(lambda ()
|
|
(let* ([h (get-header uid)]
|
|
[p (cons h
|
|
(and first-field
|
|
(extract-field
|
|
first-field
|
|
h)))])
|
|
(hash-table-put! ht uid p)
|
|
p))))])
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(status "Sorting...")
|
|
(send header-list sort
|
|
(lambda (a b)
|
|
(let ([aid (send a user-data)]
|
|
[bid (send b user-data)])
|
|
(let ([ah+f (get-header/cached aid (and (pair? fields)
|
|
(caar fields)))]
|
|
[bh+f (get-header/cached bid (and (pair? fields)
|
|
(caar fields)))])
|
|
(let loop ([fields fields][first? #t])
|
|
(if (null? fields)
|
|
(< aid bid)
|
|
(let ([c ((cadar fields)
|
|
aid bid
|
|
(if first?
|
|
(cdr ah+f)
|
|
(parse-encoded
|
|
(extract-field (caar fields) (car ah+f))))
|
|
(if first?
|
|
(cdr bh+f)
|
|
(parse-encoded
|
|
(extract-field (caar fields) (car bh+f)))))])
|
|
(if (eq? c 'same)
|
|
(loop (cdr fields) #f)
|
|
c))))))))
|
|
(status ""))
|
|
close-frame)))
|
|
|
|
(when (SORT)
|
|
(case (SORT)
|
|
[(date) (sort-by-date)]
|
|
[(subject) (sort-by-subject)]
|
|
[(from) (sort-by-sender)]
|
|
[(id) (void)])) ;; which is (sort-by-order-received)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; GUI: Finish Setup ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(send header-list focus)
|
|
|
|
(send (send header-list get-editor) begin-edit-sequence)
|
|
(for-each add-message mailbox)
|
|
(send (send header-list get-editor) end-edit-sequence)
|
|
|
|
(send main-frame create-status-line)
|
|
|
|
(send main-frame show #t)
|
|
(when (eq? (system-type) 'macosx)
|
|
(start-vsz/rss-thread))
|
|
(set! got-started? #t)
|
|
|
|
(unless (null? mailbox)
|
|
(let ([last (car (last-pair (send header-list get-items)))])
|
|
(send last select #t)
|
|
(queue-callback (lambda () (send last scroll-to)))))
|
|
|
|
(frame:reorder-menus main-frame)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Queued Message Sends ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; queue-directory : string
|
|
;; the directory where queue'd files are stored (created at this point)
|
|
(define queue-directory
|
|
(let ([dir (build-path (find-system-path 'pref-dir)
|
|
(if (eq? 'unix (system-type))
|
|
".sirmail-queue"
|
|
"SirMail Queue"))])
|
|
(unless (directory-exists? dir)
|
|
(make-directory* dir))
|
|
dir))
|
|
|
|
;; enqueued-messages? : -> bool
|
|
;; returns true if there are messages to send
|
|
(define (enqueued-messages?)
|
|
(not (= 0 (length (directory-list queue-directory)))))
|
|
|
|
;; send-queued-messsages : -> void
|
|
;; sends the files queued in `queue-directory'
|
|
(define (send-queued-messages)
|
|
(for-each send-queued-message (directory-list queue-directory)))
|
|
|
|
;; send-queued-message : string -> void
|
|
;; sends the email message in `filename' by opening a window and sending it a message
|
|
(define (send-queued-message filename)
|
|
(start-new-window
|
|
(lambda ()
|
|
(let ([full-filename (build-path queue-directory filename)])
|
|
(send (new-mailer full-filename "" "" "" "" "" null (length mailbox))
|
|
send-message)
|
|
(delete-file full-filename)))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Message Parsing ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define get-viewable-headers
|
|
(lambda (h)
|
|
((if mime-mode? parse-encoded values)
|
|
(if show-full-headers?
|
|
h
|
|
(let loop ([l (reverse (MESSAGE-FIELDS-TO-SHOW))]
|
|
[small-h empty-header])
|
|
(if (null? l)
|
|
small-h
|
|
(let ([v (extract-field (car l) h)])
|
|
(if v
|
|
(loop (cdr l) (insert-field
|
|
(car l)
|
|
v
|
|
small-h))
|
|
(loop (cdr l) small-h)))))))))
|
|
|
|
(define (parse-and-insert-body header body text-obj insert sep-width img-mode?)
|
|
(define (insert-separator)
|
|
(insert (format "\n~a\n" (make-string sep-width #\-))
|
|
(lambda (t s e)
|
|
(send t change-style green-delta (add1 s) (sub1 e)))))
|
|
|
|
(if mime-mode?
|
|
(let mime-loop ([msg (with-handlers ([exn:fail? (lambda (x)
|
|
(mime:make-message
|
|
#f
|
|
(mime:make-entity
|
|
'text
|
|
'plain
|
|
'charset
|
|
'encoding
|
|
(mime:make-disposition
|
|
'error
|
|
'filename 'creation
|
|
'modification 'read
|
|
'size 'params)
|
|
'params 'id
|
|
'description 'other 'fields
|
|
null
|
|
(lambda (o)
|
|
(fprintf o "MIME error: ~a"
|
|
(if (exn? x)
|
|
(exn-message x)
|
|
x))))
|
|
#f))])
|
|
(mime:mime-analyze (bytes-append (string->bytes/latin-1
|
|
header
|
|
(char->integer #\?))
|
|
body)))]
|
|
[skip-headers? #t])
|
|
(let* ([ent (mime:message-entity msg)]
|
|
[slurp-stream (lambda (ent o)
|
|
(with-handlers ([exn:fail? (lambda (x)
|
|
(fprintf o
|
|
"~n[decode error: ~a]~n"
|
|
(if (exn? x)
|
|
(exn-message x)
|
|
x)))])
|
|
((mime:entity-body ent) o)))]
|
|
[slurp (lambda (ent)
|
|
(let ([o (open-output-bytes)])
|
|
(slurp-stream ent o)
|
|
(get-output-bytes o)))]
|
|
[generic (lambda (ent)
|
|
(let ([fn (parse-encoded
|
|
(or (let ([disp (mime:entity-disposition ent)])
|
|
(and (not (equal? "" (mime:disposition-filename disp)))
|
|
(mime:disposition-filename disp)))
|
|
(let ([l (mime:entity-params ent)])
|
|
(let ([a (assoc "name" l)])
|
|
(and a (cdr a))))))]
|
|
[sz (mime:disposition-size (mime:entity-disposition ent))]
|
|
[content #f])
|
|
(let ([to-file
|
|
(lambda (fn)
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(break-ok)
|
|
(let ([v (slurp ent)])
|
|
(break-bad)
|
|
(unless content
|
|
(set! content v)))
|
|
(break-ok)
|
|
(with-output-to-file fn
|
|
(lambda ()
|
|
(write-bytes content))
|
|
'truncate/replace))
|
|
close-frame))])
|
|
(insert-separator)
|
|
(insert (format "[~a/~a~a~a]"
|
|
(mime:entity-type ent)
|
|
(mime:entity-subtype ent)
|
|
(if fn
|
|
(format " \"~a\"" fn)
|
|
"")
|
|
(if sz
|
|
(format " ~a bytes" sz)
|
|
""))
|
|
(lambda (t s e)
|
|
(send t set-clickback s e
|
|
(lambda (a b c)
|
|
(let ([fn (put-file "Save Attachement As"
|
|
main-frame
|
|
#f
|
|
fn)])
|
|
(when fn
|
|
(to-file fn))))
|
|
#f #f)
|
|
(send t change-style url-delta s e)))
|
|
(when (eq? (system-type) 'macosx)
|
|
(when fn
|
|
(let ([and-open
|
|
(lambda (dir)
|
|
(let ([safer-fn (normalize-path (build-path (find-system-path 'home-dir)
|
|
dir
|
|
(regexp-replace* #rx"[/\"|:<>\\]" fn "-")))])
|
|
(insert " " set-standard-style)
|
|
(insert (format "[~~/~a & open]" dir)
|
|
(lambda (t s e)
|
|
(send t set-clickback s e
|
|
(lambda (a b c)
|
|
(to-file safer-fn)
|
|
(parameterize ([current-input-port (open-input-string "")])
|
|
(system* "/usr/bin/open" (path->string safer-fn))))
|
|
#f #f)
|
|
(send t change-style url-delta s e)))))])
|
|
(and-open "Desktop")
|
|
(and-open "Temp")))))
|
|
(insert "\n" set-standard-style)
|
|
(lambda ()
|
|
(unless content
|
|
(set! content (slurp ent)))
|
|
content)))])
|
|
(case (mime:entity-type ent)
|
|
[(text) (let ([disp (mime:disposition-type (mime:entity-disposition ent))])
|
|
(cond
|
|
[(or (eq? disp 'error)
|
|
(and (eq? disp 'inline) (not no-mime-inline?)))
|
|
(cond
|
|
[(and html-mode?
|
|
(eq? 'html (mime:entity-subtype ent)))
|
|
;; If no text-obj supplied, make a temporary one for rendering:
|
|
(let ([target (or text-obj (make-object display-text%))])
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(break-ok)
|
|
(with-handlers ([void no-status-handler])
|
|
(status "Rendering HTML...")
|
|
(let-values ([(in out) (make-pipe)])
|
|
(slurp-stream ent out)
|
|
(close-output-port out)
|
|
(render-html-to-text in target img-mode? #f))
|
|
(status "")))
|
|
close-frame)
|
|
(unless text-obj
|
|
;; Copy text in target to `insert':
|
|
(insert (send target get-text) void)))]
|
|
[else
|
|
(let-values ([(bytes->string done)
|
|
(cond
|
|
[(and mime-mode?
|
|
(string? (mime:entity-charset ent))
|
|
(string-ci=? "UTF-8" (mime:entity-charset ent)))
|
|
(values bytes->string/utf-8 void)]
|
|
[(and mime-mode?
|
|
(string? (mime:entity-charset ent))
|
|
(bytes-open-converter (generalize-encoding
|
|
(mime:entity-charset ent))
|
|
"UTF-8"))
|
|
=> (lambda (c)
|
|
(values
|
|
(lambda (s alt)
|
|
(let loop ([l null][start 0])
|
|
(let-values ([(r got status) (bytes-convert c s start)])
|
|
(case status
|
|
[(complete)
|
|
(bytes->string/utf-8 (apply bytes-append (reverse (cons r l))) alt)]
|
|
[(aborts)
|
|
(loop (list* #"?" r l) (+ start got))]
|
|
[(error)
|
|
(loop (list* #"?" r l) (+ start got 1))]))))
|
|
(lambda ()
|
|
(bytes-close-converter c))))]
|
|
[else (values bytes->string/latin-1 void)])])
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(insert (bytes->string (crlf->lf/preserve-last (slurp ent)) #\?)
|
|
(lambda (t s e)
|
|
(when (SHOW-URLS) (hilite-urls t s e))
|
|
;;(handle-formatting e) ; too slow
|
|
(if (eq? disp 'error)
|
|
(send t change-style red-delta s e)))))
|
|
done))])]
|
|
[else
|
|
(generic ent)]))]
|
|
[(image)
|
|
(let ([get (generic ent)])
|
|
(let ([tmp-file (make-temporary-file "sirmail-mime-image-~a")])
|
|
(call-with-output-file tmp-file
|
|
(lambda (port)
|
|
(write-bytes (get) port))
|
|
'truncate)
|
|
(unless no-mime-inline?
|
|
(let ([bitmap (make-object bitmap% tmp-file)])
|
|
(when (send bitmap ok?)
|
|
(insert (make-object image-snip% bitmap) void)
|
|
(insert "\n" void))
|
|
(delete-file tmp-file)))))]
|
|
[(message)
|
|
(insert-separator)
|
|
(unless (or skip-headers?
|
|
(null? (mime:message-fields msg)))
|
|
(insert (string-crlf->lf
|
|
(get-viewable-headers
|
|
(let loop ([l (mime:message-fields msg)])
|
|
(if (null? l)
|
|
crlf
|
|
(string-append (car l)
|
|
crlf
|
|
(loop (cdr l)))))))
|
|
void))
|
|
(map (lambda (x) (mime-loop x #f)) (mime:entity-parts ent))]
|
|
[(multipart)
|
|
(cond
|
|
[(and (eq? 'alternative (mime:entity-subtype ent))
|
|
(= 2 (length (mime:entity-parts ent)))
|
|
(andmap (lambda (m)
|
|
(eq? 'text (mime:entity-type (mime:message-entity m))))
|
|
(mime:entity-parts ent))
|
|
(let ([l (map (lambda (m)
|
|
(mime:entity-subtype (mime:message-entity m)))
|
|
(mime:entity-parts ent))])
|
|
(and (member l '((plain html)
|
|
(html plain)
|
|
(plain enriched)
|
|
(enriched plain)))
|
|
l)))
|
|
=> (lambda (l)
|
|
(let ([pos (if (eq? (car l) 'plain)
|
|
(if prefer-text? 0 1)
|
|
(if prefer-text? 1 0))])
|
|
(mime-loop (list-ref (mime:entity-parts ent) pos) #f)))]
|
|
[else
|
|
(map (lambda (x) (mime-loop x #f)) (mime:entity-parts ent))])]
|
|
[else (generic ent)])))
|
|
;; Non-mime mode:
|
|
(insert (bytes->string/latin-1 (crlf->lf body)) void)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Biff ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define biff%
|
|
(class timer%
|
|
(inherit stop)
|
|
(define/override (notify)
|
|
(when can-poll?
|
|
(unless (send disconnected-msg is-shown?)
|
|
(with-handlers ([void
|
|
(lambda (x)
|
|
(stop)
|
|
(force-disconnect/status)
|
|
(status "Error connecting: ~s"
|
|
(if (exn? x)
|
|
(exn-message x)
|
|
x)))])
|
|
(let ([old-new-messages? new-messages?])
|
|
(as-background
|
|
enable-main-frame
|
|
(lambda (break-bad break-ok)
|
|
(check-for-new break-bad break-ok))
|
|
close-frame)
|
|
(when (and new-messages?
|
|
(not (eq? old-new-messages? new-messages?)))
|
|
(bell)))))))
|
|
(super-instantiate ())))
|
|
|
|
(define biff
|
|
(if (BIFF-DELAY)
|
|
(make-object biff%)
|
|
#f))
|
|
|
|
(define (start-biff)
|
|
(when biff
|
|
(send biff start (* 1000 (BIFF-DELAY)))))
|
|
|
|
(start-biff)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Mail Sending ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Mail-sending window is implemented in sendr.ss. This is
|
|
;; the set-up for opening such a window.
|
|
|
|
(define my-address
|
|
(with-handlers ([void (lambda (x) "<bad address>")])
|
|
(car (extract-addresses (MAIL-FROM) 'address))))
|
|
|
|
(define my-username-@
|
|
(let ([m (regexp-match "^([^@]*)@" my-address)])
|
|
(if m
|
|
(cadr m)
|
|
(string-append my-address "@"))))
|
|
|
|
(define (not-me? name-addr-full)
|
|
(let ([addr (cadr name-addr-full)])
|
|
(cond
|
|
[(string-ci=? addr my-address) #f]
|
|
[(and (SELF-ADDRESSES) (member addr (SELF-ADDRESSES))) #f]
|
|
[(and (> (string-length addr) (string-length my-username-@))
|
|
(string-ci=? my-username-@ (substring addr 0 (string-length my-username-@))))
|
|
(eq? (message-box
|
|
"Identity?"
|
|
(format "Are you ~a?" (caddr name-addr-full))
|
|
main-frame
|
|
'(yes-no))
|
|
'no)]
|
|
[else #t])))
|
|
|
|
(define (do-reply follow-up? quote-msg?)
|
|
(define selected (send header-list get-selected))
|
|
(unless selected
|
|
(bell))
|
|
(when selected
|
|
(unless (eq? selected current-selected)
|
|
(send header-list on-double-select selected))
|
|
(unless (eq? selected current-selected)
|
|
(bell))
|
|
(when (eq? selected current-selected)
|
|
(let* ([uid (send selected user-data)]
|
|
[h (get-header uid)]
|
|
[rendered-body (let ([e (send message get-editor)]
|
|
[start (string-length
|
|
(string-crlf->lf
|
|
(get-viewable-headers h)))])
|
|
(send e get-text start 'eof #t #t))])
|
|
(start-new-mailer
|
|
#f
|
|
(parse-encoded
|
|
(or (extract-field "Reply-To" h)
|
|
(extract-field "From" h)
|
|
""))
|
|
(if follow-up?
|
|
(let ([to (parse-encoded (extract-field "To" h))]
|
|
[cc (parse-encoded (extract-field "CC" h))])
|
|
(if (or to cc)
|
|
(let ([to (map
|
|
caddr
|
|
(filter
|
|
not-me?
|
|
(append
|
|
(if to
|
|
(extract-addresses to 'all)
|
|
null)
|
|
(if cc
|
|
(extract-addresses cc 'all)
|
|
null))))])
|
|
(if (null? to)
|
|
""
|
|
(assemble-address-field to)))
|
|
""))
|
|
"")
|
|
(let ([s (parse-encoded (extract-field "Subject" h))])
|
|
(cond
|
|
[(not s) ""]
|
|
[(regexp-match #rx"^[Rr][Ee][(]([0-9]+)[)]:(.*)$" s)
|
|
;; Other mailer is counting replies. We'll count, too.
|
|
=> (lambda (m)
|
|
(format "~a(~a):~a"
|
|
(substring s 0 2)
|
|
(add1 (string->number (caddr m)))
|
|
(cadddr m)))]
|
|
[(regexp-match "^[Rr][Ee]:" s) s]
|
|
[(regexp-match "^[Aa][Nn][Tt][Ww][Oo][Rr][Tt]:" s) s]
|
|
[else (string-append "Re: " s)]))
|
|
(let ([id (extract-field "Message-Id" h)]
|
|
[refs (extract-field "References" h)])
|
|
(format "~a~a"
|
|
(if id
|
|
(format "In-Reply-To: ~a\r\n" id)
|
|
"")
|
|
(if (or refs id)
|
|
(format "References: ~a\r\n"
|
|
(cond
|
|
[(and refs id)
|
|
(format "~a\r\n\t\t~a" refs id)]
|
|
[else (or refs id)]))
|
|
"")))
|
|
(if quote-in-reply?
|
|
(let ([date (parse-encoded (extract-field "Date" h))]
|
|
[name
|
|
(with-handlers ([exn:fail? (lambda (x) #f)])
|
|
(let ([from (parse-encoded (extract-field "From" h))])
|
|
(car (extract-addresses from 'name))))])
|
|
(string-append
|
|
(cond
|
|
[(and date name)
|
|
(format "At ~a, ~a wrote:\r" date name)]
|
|
[name
|
|
(format "Quoting ~a:\r" name)]
|
|
[else
|
|
(format "Quoting <unknown>:\r")])
|
|
"> "
|
|
(regexp-replace #rx"(?:\n> )*$"
|
|
(regexp-replace* #rx"\n" rendered-body "\n> ")
|
|
"")))
|
|
"")
|
|
null)))))
|
|
|
|
(define (do-forward)
|
|
(define selected (send header-list get-selected))
|
|
(unless selected
|
|
(bell))
|
|
(when selected
|
|
(let* ([uid (send selected user-data)]
|
|
[h (get-header uid)]
|
|
[body (get-body uid void void)])
|
|
(start-new-mailer
|
|
#f "" ""
|
|
(let ([s (extract-field "Subject" h)])
|
|
(if (and s (not (regexp-match "^[Ff][Ww][Dd]:" s)))
|
|
(string-append "Fwd: " s)
|
|
(or s "Fwd")))
|
|
"" ""
|
|
(list
|
|
(make-enclosure
|
|
"Forwarded Message"
|
|
(insert-field
|
|
"Content-Type" "message/rfc822"
|
|
(insert-field
|
|
"Content-Transfer-Encoding" "8bit"
|
|
(insert-field
|
|
"Content-Disposition" "inline"
|
|
empty-header)))
|
|
(lambda ()
|
|
(split-crlf
|
|
(bytes-append (string->bytes/latin-1 h (char->integer #\?))
|
|
body)))))))))
|
|
|
|
(define (start-new-mailer file to cc subject other-headers body enclosures)
|
|
(start-new-window
|
|
(lambda ()
|
|
(new-mailer file to cc subject other-headers body enclosures (length mailbox)))))
|
|
|
|
(define (start-new-mailer/send-message file to cc subject other-headers body enclosures)
|
|
(start-new-window
|
|
(lambda ()
|
|
(send (new-mailer file to cc subject other-headers body enclosures (length mailbox))
|
|
send-message))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Misc Formatting ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; handle-formatting : text -> void
|
|
(define (handle-formatting e)
|
|
(let loop ([line (send e last-line)])
|
|
(unless (zero? line)
|
|
(for-each
|
|
(lambda (regexp/action)
|
|
(handle-single-line/formatting
|
|
(car regexp/action)
|
|
(cadr regexp/action)
|
|
e
|
|
line))
|
|
regexps/actions)
|
|
(loop (- line 1)))))
|
|
|
|
(define (handle-single-line/formatting regexp action e line)
|
|
(let ([start (send e line-start-position line)]
|
|
[end (send e line-end-position line)])
|
|
(let loop ([string (send e get-text start end #f)]
|
|
[line-offset 0])
|
|
(cond
|
|
[(regexp-match-positions regexp string)
|
|
=>
|
|
(lambda (m)
|
|
(let ([before (cadr m)]
|
|
[during (caddr m)]
|
|
[after (cadddr m)])
|
|
(action e
|
|
(+ line-offset start (car during))
|
|
(+ line-offset start (cdr during)))
|
|
(loop (substring string (car before) (cdr before))
|
|
(+ (car before) line-offset))
|
|
(loop (substring string (car after) (cdr after))
|
|
(+ (car after) line-offset))))]
|
|
[else (void)]))))
|
|
|
|
;; emoticon-path (may not exist)
|
|
(define emoticon-path
|
|
(build-path (collection-path "sirmail") "emoticon"))
|
|
|
|
;; emoticon : string string -> (listof (list regexp (text number number -> void)))
|
|
(define (emoticon img . icons)
|
|
(let ([snip (make-object image-snip% (build-path emoticon-path img))])
|
|
(map
|
|
(lambda (icon)
|
|
(list (regexp (string-append "(.*)(" (quote-regexp-chars icon) ")(.*)"))
|
|
(lambda (e start end)
|
|
(send e insert (send snip copy) start end))))
|
|
icons)))
|
|
|
|
(define (quote-regexp-chars str)
|
|
(apply
|
|
string
|
|
(let loop ([chars (string->list str)])
|
|
(cond
|
|
[(null? chars) null]
|
|
[else (let ([char (car chars)])
|
|
(if (memq char regexp-special-chars)
|
|
(list* #\\ char (loop (cdr chars)))
|
|
(cons char (loop (cdr chars)))))]))))
|
|
|
|
(define regexp-special-chars (string->list "()*+?[].^\\|"))
|
|
|
|
;; all regexps must have three parenthesized sub-expressions
|
|
;; the first is unmatched text before the regexp, the second
|
|
;; is the matched tetx and the third is unmatched text after the regexp.
|
|
(define regexps/actions
|
|
(list*
|
|
(list (regexp "(.*)( \\*([^\\*]*)\\* )(.*)")
|
|
(lambda (e start end) (send e change-style bold-style-delta start end)))
|
|
(list (regexp "(.*) _([^_]*)_ (.*)")
|
|
(lambda (e start end) (send e change-style italic-style-delta start end)))
|
|
(if (directory-exists? emoticon-path)
|
|
(append
|
|
(emoticon "bigsmile.gif" ":D" ":-D")
|
|
(emoticon "cry.gif" ":')" ":'-)")
|
|
(emoticon "happy.gif" ":)" ":-)" ":>" ":->" "<-:" "<:" "(-:" "(:")
|
|
(emoticon "kiss.gif" "*:" ":*")
|
|
(emoticon "sad.gif" ":(" ":-(" ":<" ":-<" ">-:" ">:" "):" ")-:")
|
|
(emoticon "tongue.gif" ":P" ":-P")
|
|
(emoticon "wink.gif" ";)" ";-)" ";>" ";->"))
|
|
null)))
|
|
|
|
|
|
(define bold-style-delta (make-object style-delta% 'change-bold))
|
|
(define italic-style-delta (make-object style-delta% 'change-italic))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Mailbox memory graph (from messages in this mailbox)
|
|
;;
|
|
|
|
(define (show-memory-graph)
|
|
;; grab the current value of the mailbox
|
|
(let ([mailbox mailbox]
|
|
[mbox-eventspace (current-eventspace)])
|
|
|
|
(status "Collecting memory graph record...")
|
|
;; ht : [symbol -o> (listof (cons seconds bytes))]
|
|
(parameterize ([current-eventspace (make-eventspace)])
|
|
(queue-callback
|
|
(lambda ()
|
|
(let ([ht (make-hash-table)])
|
|
(let loop ([mailbox mailbox])
|
|
(cond
|
|
[(empty? mailbox) (void)]
|
|
[else
|
|
(let* ([message (car mailbox)]
|
|
[uid (message-uid message)]
|
|
[header (get-header uid)]
|
|
[key
|
|
(string->symbol
|
|
(format "~a" (extract-field "X-Mailer" header)))]
|
|
[uptime-str (extract-field "X-Uptime" header)])
|
|
(when uptime-str
|
|
(let ([uptime (parse-uptime uptime-str)])
|
|
(when uptime
|
|
(hash-table-put!
|
|
ht
|
|
key
|
|
(cons
|
|
uptime
|
|
(hash-table-get ht key (lambda () '()))))))))
|
|
(loop (cdr mailbox))]))
|
|
|
|
(let ([info
|
|
(sort
|
|
(hash-table-map ht (lambda (x y) (list (symbol->string x) y)))
|
|
(lambda (x y) (string<=? (car x) (car y))))])
|
|
(parameterize ([current-eventspace mbox-eventspace])
|
|
(queue-callback
|
|
(lambda ()
|
|
(status "Showing graph"))))
|
|
(make-memory-graph-window info))))))))
|
|
|
|
;; eventspace: graph eventspace
|
|
(define (parse-uptime str)
|
|
(let* ([sep-bytes (regexp-match #rx"([0-9,]*) bytes" str)]
|
|
[bytes (and sep-bytes
|
|
(string->number
|
|
(regexp-replace* #rx"," (cadr sep-bytes) "")))]
|
|
[seconds
|
|
(cond
|
|
[(regexp-match day-hour-regexp str)
|
|
=>
|
|
(combine (* 24 60 60) (* 60 60))]
|
|
[(regexp-match hour-minute-regexp str)
|
|
=>
|
|
(combine (* 60 60) 60)]
|
|
[(regexp-match minute-second-regexp str)
|
|
=>
|
|
(combine 60 1)]
|
|
[else #f])])
|
|
(if (and bytes seconds)
|
|
(cons seconds bytes)
|
|
#f)))
|
|
|
|
;; eventspace: graph eventspace
|
|
(define (combine m1 m2)
|
|
(lambda (match)
|
|
(let ([first (cadr match)]
|
|
[second (caddr match)])
|
|
(+ (* (string->number first) m1)
|
|
(* (string->number second) m2)))))
|
|
|
|
;; info : (listof (list string (listof (cons number number)))) -> void
|
|
;; eventspace: new graph eventspace
|
|
(define (make-memory-graph-window info)
|
|
(define frame (new frame:basic%
|
|
(label "Memory Histogram")
|
|
(width 500)
|
|
(height 600)))
|
|
(define canvas (new canvas%
|
|
(paint-callback
|
|
(lambda (c dc)
|
|
(draw-graph dc text)))
|
|
(parent (send frame get-area-container))))
|
|
(define text (new text%))
|
|
(define editor-canvas (new editor-canvas%
|
|
(parent (send frame get-area-container))
|
|
(editor text)
|
|
(stretchable-height #f)
|
|
(line-count 6)))
|
|
|
|
(define colors '("Green"
|
|
"DarkOliveGreen"
|
|
"ForestGreen"
|
|
"MediumTurquoise"
|
|
"SteelBlue"
|
|
"Teal"
|
|
"CadetBlue"
|
|
"Indigo"
|
|
"Purple"
|
|
"Fuchsia"
|
|
"Black"
|
|
"DarkRed"
|
|
"HotPink"
|
|
"OrangeRed"
|
|
"SaddleBrown"))
|
|
|
|
(define original-colors colors)
|
|
|
|
(define (draw-graph dc text)
|
|
(let ([max-x 0]
|
|
[max-y 0]
|
|
[left-scale 0])
|
|
(for-each
|
|
(lambda (key-pairs)
|
|
(for-each
|
|
(lambda (pair)
|
|
(set! max-x (max (car pair) max-x))
|
|
(set! max-y (max (cdr pair) max-y)))
|
|
(cadr key-pairs)))
|
|
info)
|
|
|
|
(let-values ([(cw ch) (send canvas get-client-size)])
|
|
(let* ([text-height (let-values ([(w h _1 _2) (send dc get-text-extent "9")])
|
|
h)]
|
|
[draw-y-label
|
|
(lambda (frac)
|
|
(let ([str (format "~a" (quotient (* frac max-y) (* 1024 1024)))]
|
|
[y (max (* ch (- 1 frac)) text-height)])
|
|
(let-values ([(w h _1 _2) (send dc get-text-extent str)])
|
|
(set! left-scale (max left-scale w))
|
|
(send dc draw-line 0 (+ y (floor (/ h 2))) cw (+ y (floor (/ h 2))))
|
|
(send dc draw-text str 0 y))))])
|
|
(draw-y-label 1)
|
|
(draw-y-label 3/4)
|
|
(draw-y-label 1/2)
|
|
(draw-y-label 1/4)
|
|
(draw-y-label 0)
|
|
(send dc draw-line left-scale 0 left-scale ch)))
|
|
|
|
(set! colors original-colors)
|
|
(for-each
|
|
(lambda (key-pairs)
|
|
(let ([key (car key-pairs)]
|
|
[pairs (cadr key-pairs)])
|
|
(set! colors (cdr colors))
|
|
(send dc set-pen (send the-pen-list find-or-create-pen (car colors) 1 'solid))
|
|
(send dc set-brush (send the-brush-list find-or-create-brush (car colors) 'solid))
|
|
(for-each
|
|
(lambda (pair)
|
|
(plot-pair dc (car pair) (cdr pair) left-scale max-x max-y))
|
|
pairs)))
|
|
info)))
|
|
|
|
(define (plot-pair dc x y left-scale max-x max-y)
|
|
(let-values ([(cw ch) (send canvas get-client-size)])
|
|
(let* ([w (- cw left-scale)]
|
|
[h ch]
|
|
[dc-x (+ left-scale (* x (/ w max-x)))]
|
|
[dc-y (- ch (* y (/ h max-y)))])
|
|
(send dc draw-rectangle dc-x dc-y 3 3))))
|
|
|
|
(send text begin-edit-sequence)
|
|
(for-each (lambda (key-pairs)
|
|
(let ([key (car key-pairs)]
|
|
[pairs (cadr key-pairs)])
|
|
(set! colors (cdr colors))
|
|
(let ([before (send text last-position)])
|
|
(send text insert (format "~a msgs ~a ~a"
|
|
(length pairs)
|
|
key
|
|
(car colors)))
|
|
(let ([after (send text last-position)])
|
|
(send text insert "\n")
|
|
(let ([sd (make-object style-delta%)])
|
|
(send sd set-delta-foreground (car colors))
|
|
(send text change-style sd before after))))))
|
|
info)
|
|
(send text end-edit-sequence)
|
|
|
|
; (set-cdr! (last-pair colors) colors) ;; FIXME: need a cyclic list
|
|
(send frame show #t))
|
|
|
|
(define (make-and-regexp first second)
|
|
(regexp (format "([0-9]+) ~as? and ([0-9]+) ~as?" first second)))
|
|
(define day-hour-regexp (make-and-regexp "day" "hour"))
|
|
(define hour-minute-regexp (make-and-regexp "hour" "minute"))
|
|
(define minute-second-regexp (make-and-regexp "minute" "second"))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Hiliting URLS ;;
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; hilite-urls : text -> void
|
|
;; highligts all of the urls (strings beginning with `http:', `https:' or `ftp:')
|
|
;; in the buffer to be able to click on them.
|
|
(define (hilite-urls e start end)
|
|
(define (hilite-urls/prefix prefix)
|
|
(let loop ([pos start])
|
|
(when (< pos end)
|
|
(let ([start-pos (send e find-string prefix 'forward pos 'eof #t #f)])
|
|
(when start-pos
|
|
(let ([eou-pos (let loop ([eou-pos start-pos])
|
|
(cond
|
|
[(= eou-pos (send e last-position)) eou-pos]
|
|
[(char-whitespace? (send e get-character eou-pos))
|
|
;; Back up past ., ,, >, ", and ):
|
|
(let loop ([eou-pos eou-pos])
|
|
(if (memq (send e get-character (sub1 eou-pos))
|
|
'(#\" #\. #\, #\> #\)))
|
|
(loop (sub1 eou-pos))
|
|
eou-pos))]
|
|
[else (loop (+ eou-pos 1))]))])
|
|
(send e change-style url-delta start-pos eou-pos)
|
|
(send e set-clickback start-pos eou-pos
|
|
(lambda (e start-pos eou-pos)
|
|
(send-url (send e get-text start-pos eou-pos))))
|
|
(loop eou-pos)))))))
|
|
(hilite-urls/prefix "http:")
|
|
(hilite-urls/prefix "https:")
|
|
(hilite-urls/prefix "ftp:"))))
|