diff --git a/collects/meta/props b/collects/meta/props index 334499bd9b..1982759412 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -973,10 +973,6 @@ path/s is either such a string or a list of them. "collects/sgl" responsible (jay) "collects/sgl/examples/alpha.rkt" drdr:command-line (mzc *) "collects/sgl/examples/gears.rkt" drdr:command-line (mzc "-k" *) -"collects/sirmail" responsible (mflatt) -"collects/sirmail/main.rkt" drdr:command-line (mzc *) -"collects/sirmail/recover.rkt" drdr:command-line (racket "-f" *) -"collects/sirmail/sirmail.rkt" drdr:command-line (mzc *) "collects/slatex" responsible (sstrickl) "collects/slatex/pdf-slatex-launcher.rkt" drdr:command-line (mzc *) "collects/slatex/slatex-launcher.rkt" drdr:command-line (mzc *) diff --git a/collects/sirmail/doc.txt b/collects/sirmail/doc.txt deleted file mode 100644 index 4aa3409e41..0000000000 --- a/collects/sirmail/doc.txt +++ /dev/null @@ -1,133 +0,0 @@ - -_SirMail_ is a _IMAP_ mail client. The current version has a number of -rough edges, but it is quite useful to the authors. - -Caveat: All marks (used for deletion and copying) are local to the -client. SirMail doesn't use the \Deleted IMAP flag until it is ready -to delete marked messages. Also, it pays no attention to \Deleted -flags when synchronizing. However, SirMail removes a \Delete flags -from a mailbox before purging marked messages. This prevents SirMail -from accidentally removing messages that you didn't mark within -SirMail (on the local machine). - -Terminology: The GUI uses the term "Folder" everywhere instead of -"Mailbox". The latter term matches the IMAP specification. - ------------------------------------------------------------- - -Configure SirMail options by visiting Edit | Preferences in a -mail-reading or mail-sending window. If the current (or default) -options do not allow SirMail to start up, you get just the preferences -dialog, and you must try running again after setting the preferences. - -Reading panel: - - - Username: The username to use when logging into the server. - - - IMAP Server: The IMAP server's host name (incoming mail). - Use a ":" suffix on the host name to connect to - port . - - - Local Directory: The pathname of an existing directory where - SirMail should store downloaded messages. Defaults to - (build-path (find-system-path 'home-dir) "SirMail") - - - Folder List Root: Names a mailbox to use as the root in the mailbox - folder list window. If this option is not provided, the folder list - window is not available. - - - Auto-File Table File: The file should contain an expression that - reads as a value of the shape - - (list-of (list mailbox-name-string - (list-of (list field-string regexp-string)))) - - which specifies where messages should be autofiled based on - regular expression matching of various headers in the email. For - any email, if it has a header named `field-string' that matches - `regexp-string', it is filed into `mailbox-name-string'. - - - Shown Header Fields: Names header fields to to (in order_ when - reading a message. - -Sending panel: - - - Mail From: The user's email address. - - - SMTP Server: The SMTP server's host name (outgoing mail). General - syntax: [:][@][:] where is "tcp" - (the default) or "ssl". Supply multiple SMTP hosts by separating - the addresses with a comma; the "File" menu of mail-sending frame - will let you choose a specific server. - - - Default To Domain: If a destination address that isn't declared as - an alias doesn't include a domain name, SirMail automatically - appends this as the domain. (For instance, say you tend to work - at cs.brown.edu and tend to send most of your mail to cs.brown.edu - users. However, your SMTP server is an ISP you use from home. By - default, the server will attempt to deliver the (un-aliased) - address `foo' to foo@your-isp.com. Setting the Default To - Domain to `cs.brown.edu' will deliver this to foo@cs.brown.edu - instead, irrespective of what SMTP server you use. - - - Save Sent Files: Check this if you want a copy of messages you - sent to be saved in an archive, the set it to a directory where - SirMail should save outgoing messages. - - - Aliases File: SirMail uses this file to resolve shortcut mail - addresses when sending mail. The file should contain an expression - that reads as a value of the shape - - (list-of (list string (union string (list-of string)))) - - specifying a mapping from names to one or more email - addresses. These names can be used in the "To", "cc", or "bcc" - headers of your email address. - - Aliases are expanded recursively. - - - Self Addresses: Strings naming your email addresses so followups do - not go to yourself. - - -Internal options that still need preference-panel support: - - - biff-delay-seconds: (union #f number); when number specifies how long - between SirMail waits before polling the mailbox. Only polls when - connected. - - - sort-by: (union #f 'date 'subject 'from 'id); specifies the - initial sorting of opened mailboxes. - 'id indicates sorting by order received and #f means no sorting. - These should produce the same ordering, but 'id is probably a bit slower. - - - show-urls: (union 'on 'off), defaults to 'on - If this is 'on, it highlights urls in the text. Clicking on the - urls will open a web browser, pointing it at that url. - -------------------------------------------------------------------- - -Implementation Note: - -The format of a "mailboxes" file is a list of entries, where each -entry is a list of at least two elements: - - The first element is the local directory for the mailbox's messages. - - The second element is the mailbox name for the IMAP server. - - The rest are overriding options. For example, there's no easy way to - move my Rice mailboxes to Utah, so I just access them from Rice on the - rare occasions when I need them. For each of my Rice mailboxes, the - "mailboxes" entry contains all the configuration options that apply to - Rice. Nothing in SirMail ever writes new options into "mailboxes"; I - add them by hand, and SirMail preserves them. - -The overriding-options feature was a quick hack for what I needed, and -it should be replaced eventually. There's a lot of duplication of -information in the current format. - - -For an individual folder, if your "mailbox" file gets corrupted, you -can run the "recover.ss" script with the mail folder's directory as -the current directory. diff --git a/collects/sirmail/emoticon/bigsmile.gif b/collects/sirmail/emoticon/bigsmile.gif deleted file mode 100644 index be0ff37842..0000000000 Binary files a/collects/sirmail/emoticon/bigsmile.gif and /dev/null differ diff --git a/collects/sirmail/emoticon/cry.gif b/collects/sirmail/emoticon/cry.gif deleted file mode 100644 index 73e6d4dd0a..0000000000 Binary files a/collects/sirmail/emoticon/cry.gif and /dev/null differ diff --git a/collects/sirmail/emoticon/happy.gif b/collects/sirmail/emoticon/happy.gif deleted file mode 100644 index f42a6c456d..0000000000 Binary files a/collects/sirmail/emoticon/happy.gif and /dev/null differ diff --git a/collects/sirmail/emoticon/kiss.gif b/collects/sirmail/emoticon/kiss.gif deleted file mode 100644 index dd48636e25..0000000000 Binary files a/collects/sirmail/emoticon/kiss.gif and /dev/null differ diff --git a/collects/sirmail/emoticon/sad.gif b/collects/sirmail/emoticon/sad.gif deleted file mode 100644 index 187d1f3fbe..0000000000 Binary files a/collects/sirmail/emoticon/sad.gif and /dev/null differ diff --git a/collects/sirmail/emoticon/tongue.gif b/collects/sirmail/emoticon/tongue.gif deleted file mode 100644 index f13f18a25c..0000000000 Binary files a/collects/sirmail/emoticon/tongue.gif and /dev/null differ diff --git a/collects/sirmail/emoticon/wink.gif b/collects/sirmail/emoticon/wink.gif deleted file mode 100644 index f498912328..0000000000 Binary files a/collects/sirmail/emoticon/wink.gif and /dev/null differ diff --git a/collects/sirmail/folder-mask.xbm b/collects/sirmail/folder-mask.xbm deleted file mode 100644 index ab330b4c6d..0000000000 --- a/collects/sirmail/folder-mask.xbm +++ /dev/null @@ -1,6 +0,0 @@ -#define mred_width 16 -#define mred_height 16 -static char mred_bits[] = { - 0x00,0x00,0x1e,0x00,0x3f,0x00,0xff,0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xfe,0x7f, - 0x00,0x00}; diff --git a/collects/sirmail/folder.bmp b/collects/sirmail/folder.bmp deleted file mode 100644 index 6227e286ec..0000000000 Binary files a/collects/sirmail/folder.bmp and /dev/null differ diff --git a/collects/sirmail/folderr.rkt b/collects/sirmail/folderr.rkt deleted file mode 100644 index c4019564b3..0000000000 --- a/collects/sirmail/folderr.rkt +++ /dev/null @@ -1,469 +0,0 @@ -(module folderr mzscheme - (require mzlib/unit - mzlib/class - framework - mred/mred-sig) - - (require mzlib/list - mzlib/etc) - - (require "sirmails.rkt" - "pref.rkt") - - (require net/imap-sig) - - (require mrlib/hierlist/hierlist-sig) - - (require openssl/mzssl) - - (provide folder@) - (define-unit folder@ - (import sirmail:environment^ - sirmail:shutdown-folder^ - sirmail:options^ - mred^ - imap^ - hierlist^) - (export) - - (define (show-error x frame) - (message-box "Error" - (if (exn? x) - (exn-message x) - (format "Strange exception: ~s" x)) - frame - '(ok stop))) - - (define mailbox-cache-file (build-path (LOCAL-DIR) "folder-window-mailboxes")) - - (define (imap-open-connection) - (let ([passwd - (or (get-PASSWORD) - (let ([p (get-text-from-user "Password" - (format "Password for ~a:" (USERNAME)) - frame - "" - '(password))]) - (unless p (raise-user-error 'connect "connection cancelled")) - p))]) - (let-values ([(server port-no) - (parse-server-name (IMAP-SERVER) (if (get-pref 'sirmail:use-ssl?) 993 143))]) - (begin0 - (if (get-pref 'sirmail:use-ssl?) - (let-values ([(in out) (ssl-connect server port-no)]) - (imap-connect* in out (USERNAME) passwd mailbox-name)) - (parameterize ([imap-port-number port-no]) - (imap-connect server (USERNAME) - passwd - mailbox-name))) - (unless (get-PASSWORD) - (set-PASSWORD passwd)))))) - - (define imap-mailbox-name-mixin - (lambda (list%) - (class list% - (field - [full-mailbox-name 'unknown-full-mailbox-name] - [is-selectable? #f]) - [define/public set-full-mailbox-name - (lambda (fm) - (set! full-mailbox-name fm))] - [define/public get-full-mailbox-name - (lambda () - full-mailbox-name)] - [define/public set-selectable - (lambda (x) (set! is-selectable? x))] - [define/public selectable? - (lambda () is-selectable?)] - (super-instantiate ())))) - - (define imap-mailbox-list-mixin - (lambda (list%) - (class list% - (field - [mailbox-name 'unknown-mailbox-name]) - [define/public get-mailbox-name - (lambda () - mailbox-name)] - [define/public set-mailbox-name - (lambda (m) - (set! mailbox-name m))] - (super-instantiate ())))) - - ;; mailbox-folder = (make-deep-folder (union #f bytes) - ;; (union #f string) - ;; bool - ;; nested-mailbox-folder) - ;; nested-mailbox-folder = - ;; (union (make-flat-folder bytes (union #f string) bool) - ;; (make-deep-folder bytes (union #f string) bool (listof mailbox-folder))) - (define-struct folder (name short-name selectable?)) - (define-struct (deep-folder folder) (children)) - (define-struct (flat-folder folder) ()) - - ;; refresh-mailboxes : -> void - (define (refresh-mailboxes) - (let ([mailboxes (fetch-mailboxes)]) - (when mailboxes - (write-mailbox-folder mailboxes) - (update-gui mailboxes)))) - - ;; write-mailbox-folder : mailbox-folder -> void - (define (write-mailbox-folder mbf) - (let ([raw-datum - (let loop ([mbf mbf]) - (cond - [(flat-folder? mbf) (list (folder-name mbf) - (folder-short-name mbf))] - [(deep-folder? mbf) - (list (folder-name mbf) - (folder-short-name mbf) - (folder-selectable? mbf) - (map loop (deep-folder-children mbf)))] - [else (error 'write-mailbox-folder "unknown mailbox folder: ~e" - mbf)]))]) - (call-with-output-file mailbox-cache-file - (lambda (port) - (write raw-datum port)) - 'truncate 'text))) - - ;; read-mailbox-folder : -> mailbox-folder - (define (read-mailbox-folder) - (let* ([root-box (ROOT-MAILBOX-FOR-LIST)] - [default - (make-deep-folder (and root-box (string->bytes/utf-8 root-box)) - root-box - #f ;; arbitrary - null)]) - (if (file-exists? mailbox-cache-file) - (let/ec k - (let ([raw-datum (call-with-input-file mailbox-cache-file read 'text)]) - (let loop ([rd raw-datum]) - (cond - [(and (= 2 (length rd)) - (or (not (car rd)) (bytes? (car rd))) - (or (not (car rd)) (string? (cadr rd)))) - (make-flat-folder (car rd) (cadr rd) #t)] - [(and (= 3 (length rd)) - (or (not (car rd)) (bytes? (car rd))) - (or (not (car rd)) (string? (cadr rd))) - (list? (caddr rd))) - (make-deep-folder (car rd) - (cadr rd) - #f - (map loop (caddr rd)))] - [(and (= 4 (length rd)) - (or (not (car rd)) (bytes? (car rd))) - (or (not (cadr rd)) (string? (cadr rd))) - (boolean? (caddr rd)) - (list? (cadddr rd))) - (make-deep-folder (car rd) - (cadr rd) - (caddr rd) - (map loop (cadddr rd)))] - [else (k default)])))) - default))) - - - ;; fetch-mailboxes : -> (union #f mailbox-folder) - ;; gets the current mailbox list from the server - (define (fetch-mailboxes) - (with-custodian-killing-stop-button - "Updating folder list..." - (lambda () - (let-values ([(imap msg-count recent-count) (imap-open-connection)] - [(root-box) (ROOT-MAILBOX-FOR-LIST)]) - (make-deep-folder - (and root-box (string->bytes/utf-8 root-box)) - root-box - #f ;; arbitrary - (let loop ([mailbox-name (and root-box (string->bytes/utf-8 root-box))]) - (let ([mailbox-name-length (if mailbox-name - (bytes-length mailbox-name) - 0)] - [get-child-mailbox-name (lambda (item) (second item))] - [child-mailboxes (imap-list-child-mailboxes imap mailbox-name)]) - (map (lambda (item) - (let* ([child-mailbox-name (get-child-mailbox-name item)] - [child-mailbox-flags (first item)] - [symbols (map imap-flag->symbol child-mailbox-flags)] - [flat-mailbox? (or (member 'noinferiors symbols) - (member 'hasnochildren symbols))] - [selectable? (not (member 'noselect symbols))] - [child-name-length (bytes-length child-mailbox-name)] - [strip-prefix? - (and (> child-name-length mailbox-name-length) - mailbox-name - (bytes=? - (subbytes child-mailbox-name 0 mailbox-name-length) - mailbox-name))] - [short-name - (bytes->string/utf-8 - (if strip-prefix? - (subbytes child-mailbox-name - ;; strip separator (thus add1) - (add1 mailbox-name-length) - child-name-length) - child-mailbox-name))]) - (if flat-mailbox? - (make-flat-folder child-mailbox-name short-name #t) - (make-deep-folder - child-mailbox-name - short-name - selectable? - (loop child-mailbox-name))))) - (sort - child-mailboxes - (lambda (x y) - (string<=? (bytes->string/utf-8 (get-child-mailbox-name x)) - (bytes->string/utf-8 (get-child-mailbox-name y))))))))))))) - - (define imap-mailbox-mixin - (compose - imap-mailbox-list-mixin - imap-mailbox-name-mixin)) - - (define imap-top-list% - (class (imap-mailbox-list-mixin hierarchical-list%) - (field - [selected-mailbox #f]) - [define/public get-selected-mailbox - (lambda () - selected-mailbox)] - (define/override on-select - (lambda (i) - (send frame set-status-text "") - (set! selected-mailbox (and i - (send i selectable?) - (send i get-full-mailbox-name))) - (super on-select i))) - (define/override on-double-select - (lambda (i) - (when (and i (send i selectable?)) - (let ([mail-box (send i get-full-mailbox-name)]) - (send frame set-status-text (format "Opening ~a" mail-box)) - (setup-mailboxes-file mail-box) - (open-mailbox (bytes->string/utf-8 mail-box)))) - (super on-double-select i))) - (super-instantiate ()))) - - (define (update-gui orig-mbf) - (define (add-child hl mbf) - (let* ([deep? (deep-folder? mbf)] - [new-item (if deep? - (send hl new-list imap-mailbox-mixin) - (send hl new-item imap-mailbox-name-mixin))] - [text (send new-item get-editor)]) - (send new-item set-full-mailbox-name (or (folder-name mbf) #"")) - (send new-item set-selectable (folder-selectable? mbf)) - (when deep? - (send new-item set-mailbox-name (or (folder-name mbf) #""))) - (send text insert (or (folder-short-name mbf) "")) - new-item)) - (send (send top-list get-editor) begin-edit-sequence) - (for-each (lambda (x) (send top-list delete-item x)) - (send top-list get-items)) - (for-each (lambda (mbf) - (let loop ([hl top-list] - [mbf mbf]) - (let ([new-item (add-child hl mbf)]) - (when (deep-folder? mbf) - (for-each (lambda (child) (loop new-item child)) - (deep-folder-children mbf)))))) - (cons (make-flat-folder (string->bytes/utf-8 mailbox-name) mailbox-name #t) - (deep-folder-children orig-mbf))) - (send (send top-list get-editor) end-edit-sequence)) - - (define folders-frame% - (class frame:basic% - (define/override (on-size w h) - (put-pref 'sirmail:folder-window-w w) - (put-pref 'sirmail:folder-window-h h)) - (define/override (on-move x y) - (put-pref 'sirmail:folder-window-x x) - (put-pref 'sirmail:folder-window-y y)) - (define/augment (on-close) - (inner (void) on-close) - (shutdown-folders-window)) - (define/override (on-message msg) - (let ([s (and (list? msg) - (number? (car msg)) - (number? (cadr msg)) - (let ([gx (car msg)] - [gy (cadr msg)]) - (let-values ([(x y) (send top-list screen->client gx gy)]) - (let ([lxb (box 0)] - [lyb (box 0)]) - (let loop ([ed (send top-list get-editor)]) - (set-box! lxb x) - (set-box! lyb y) - (send ed global-to-local lxb lyb) - (let* ([on-it-b (box #f)] - [pos (send ed find-position (unbox lxb) (unbox lyb) #f on-it-b)]) - (and (unbox on-it-b) - (let ([snip (send ed find-snip pos 'after-or-none)]) - (cond - [(is-a? snip hierarchical-item-snip%) - (let ([item (send snip get-item)]) - (send item get-full-mailbox-name))] - [(is-a? snip hierarchical-list-snip%) - (let ([ed (send snip get-content-buffer)]) - (or (loop ed) - (let ([i (send snip get-item)]) - (and (send i selectable?) - (send i get-full-mailbox-name)))))] - [else #f])))))))))]) - (send frame set-status-text (if s - (format "Dragging to ~a" s) - "")) - s)) - (define/public (get-mailbox-name) - (send top-list get-selected-mailbox)) - (super-instantiate ()))) - - (define icon (make-object bitmap% (build-path (collection-path "sirmail") - "folder.bmp"))) - (define icon-mask (make-object bitmap% (build-path (collection-path "sirmail") - "folder-mask.xbm"))) - (define frame (make-object folders-frame% "Folders" #f - (get-pref 'sirmail:folder-window-w) - (get-pref 'sirmail:folder-window-h) - (max 0 (get-pref 'sirmail:folder-window-x)) - (max 0 (get-pref 'sirmail:folder-window-y)))) - (define top-panel (instantiate horizontal-panel% ((send frame get-area-container)) - [alignment '(right center)] - [stretchable-height #f])) - - (define re:setup-mailboxes (regexp "^([^/]*)/(.*)$")) - (define (setup-mailboxes-file bytes-mailbox-name) - (define mailbox-name (bytes->string/utf-8 bytes-mailbox-name)) - (define mailboxes-file (build-path (LOCAL-DIR) "mailboxes")) - (define mailboxes - (with-handlers ([exn:fail? (lambda (x) '(("Inbox" #"inbox")))]) - (with-input-from-file mailboxes-file - read))) - - (define mailbox-loc (assoc mailbox-name mailboxes)) - - (unless mailbox-loc - - (let ([fns (let loop ([str mailbox-name]) - (cond - [(regexp-match re:setup-mailboxes str) - => - (lambda (m) - (cons (cadr m) - (loop (caddr m))))] - [else - (if (string=? str "") - null - (list str))]))]) - - (unless (null? fns) - (let ([mailbox-dir - (let loop ([fns (if (string=? (car fns) "") - (cdr fns) - fns)] - [local-dir 'same] - [fs-dir (LOCAL-DIR)]) - (cond - [(null? fns) local-dir] - [else (let ([new-fs-dir (build-path fs-dir (car fns))]) - (unless (directory-exists? new-fs-dir) - (make-directory new-fs-dir)) - (loop (cdr fns) - (build-path local-dir (car fns)) - new-fs-dir))]))]) - - (with-output-to-file (build-path (LOCAL-DIR) "mailboxes") - (lambda () (write - (append mailboxes - (list (list mailbox-name - (path->bytes mailbox-dir)))))) - 'truncate)))))) - - - (define refresh-mailbox-button - (instantiate button% () - (label "Update Folder List") - (parent top-panel) - (callback (lambda (x y) - (refresh-mailboxes))))) - - (define stop-thread #f) - (define stop-button - (instantiate button% () - (label "Stop") - (parent top-panel) - (callback (lambda (x y) - (when stop-thread - (break-thread stop-thread)))))) - - (send stop-button enable #f) - - (define (with-custodian-killing-stop-button what thunk) - (let ([c (make-custodian)] - [result #f]) - (dynamic-wind - (lambda () - (send frame set-status-text what) - (send (send frame get-menu-bar) enable #f) - (send top-list enable #f) - (send refresh-mailbox-button enable #f) - (send stop-button enable #t)) - (lambda () - (parameterize ([current-custodian c]) - (set! stop-thread (thread (lambda () - (with-handlers ([values (lambda (x) - (set! result x))]) - (set! result (thunk)))))) - (yield stop-thread))) - (lambda () - (send frame set-status-text "") - (custodian-shutdown-all c) - (send (send frame get-menu-bar) enable #t) - (send top-list enable #t) - (send refresh-mailbox-button enable #t) - (send stop-button enable #f))) - (if (exn? result) - (raise result) - result))) - - - (define top-list (make-object imap-top-list% (send frame get-area-container))) - - (when (and (send icon ok?) (send icon-mask ok?)) - (send frame set-icon icon icon-mask 'both)) - - (define file-menu (make-object menu% "&File" (send frame get-menu-bar))) - (make-object menu-item% "&Add Folder..." file-menu - (lambda (i e) - (let ([t (get-text-from-user "New Folder" "New folder name:" frame)]) - (when t - (when (with-custodian-killing-stop-button - (format "Creating ~a" t) - (lambda () - (let-values ([(imap x y) (imap-open-connection)]) - (imap-create-mailbox imap t)) - #t)) - (refresh-mailboxes)))))) - (make-object separator-menu-item% file-menu) - (make-object menu-item% "Close" file-menu - (lambda (i e) - (send frame close))) - - (frame:reorder-menus frame) - - (send frame show #t) - (send frame min-width 350) - (send frame min-height 450) - (send frame create-status-line) - (send top-list set-mailbox-name (ROOT-MAILBOX-FOR-LIST)) - (update-gui (read-mailbox-folder)) - - (uncaught-exception-handler - (lambda (x) - (show-error x frame) - ((error-escape-handler)))) - - frame)) diff --git a/collects/sirmail/info.rkt b/collects/sirmail/info.rkt deleted file mode 100644 index 741f0d0425..0000000000 --- a/collects/sirmail/info.rkt +++ /dev/null @@ -1,6 +0,0 @@ -#lang setup/infotab - -(define mred-launcher-libraries (list "sirmail.rkt")) -(define mred-launcher-names (list "SirMail")) -(define compile-omit-paths '("recover.rkt")) -(define requires '(("mred") ("openssl"))) diff --git a/collects/sirmail/main.rkt b/collects/sirmail/main.rkt deleted file mode 100644 index 5a6bde9158..0000000000 --- a/collects/sirmail/main.rkt +++ /dev/null @@ -1,2 +0,0 @@ -(module main scheme/base - (require "sirmail.rkt")) diff --git a/collects/sirmail/optionr.rkt b/collects/sirmail/optionr.rkt deleted file mode 100644 index 147e15fbdd..0000000000 --- a/collects/sirmail/optionr.rkt +++ /dev/null @@ -1,94 +0,0 @@ -(module optionr mzscheme - (require mzlib/unit - mzlib/string) - - (require net/imap-sig - mred/mred-sig - framework) - - (require "sirmails.rkt" - "pref.rkt") - - (define shared-password #f) - - ;; The option@ unit gets instanted afresh for every window, but - ;; it defers practically all of its work to the "pref.rkt" module - ;; (which is only instantiated once). - - (provide option@) - (define-unit option@ - (import sirmail:environment^ - imap^ - mred^) - (export sirmail:options^) - - (define (parse-server-name s default-port) - (let ([m (regexp-match "^([^:]*):([^:]*)$" s)]) - (if (and m (string->number (caddr m))) - (values (cadr m) (string->number (caddr m))) - (values s default-port)))) - - (define (parse-server-name+user+type s default-port) - (let ([m (regexp-match #rx"^(ssl|tcp):.*:.*" s)]) - (let-values ([(ssl? s) (if m - (values (string=? "ssl" (substring s 0 3)) - (substring s 4)) - (values #f s))]) - (let ([m (regexp-match #rx"^(.*)@(.*)$" s)]) - (let-values ([(user s) (if m - (values (cadr m) (caddr m)) - (values #f s))]) - (let-values ([(server port) (parse-server-name s default-port)]) - (values ssl? user server port))))))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Preferences ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - (define (MAIL-FROM) (get-pref 'sirmail:mail-from)) - (define (USERNAME) (get-pref 'sirmail:username)) - (define (DEFAULT-DOMAIN) (get-pref 'sirmail:default-to-domain)) - (define (IMAP-SERVER) (get-pref 'sirmail:imap-server)) - (define (LOCAL-DIR) (get-pref 'sirmail:local-directory)) - (define (SAVE-SENT) (get-pref 'sirmail:sent-directory)) - - (define (SMTP-SERVERS) (let ([s (get-pref 'sirmail:smtp-server)]) - (regexp-split ", *" s))) - (define current-SMTP-SERVER (car (SMTP-SERVERS))) - (define (SMTP-SERVER) (let ([l (SMTP-SERVERS)]) - (if (member current-SMTP-SERVER l) - current-SMTP-SERVER - (car l)))) - (define (set-SMTP-SERVER! s) (set! current-SMTP-SERVER s)) - - - (define PASSWORD (get-pref 'sirmail:password)) - (define (get-PASSWORD) (or PASSWORD shared-password)) - (define (set-PASSWORD p) (set! shared-password p)) - - (define (BIFF-DELAY) (get-pref 'sirmail:biff-delay)) - - (define (ALIASES) (let ([f (get-pref 'sirmail:aliases-file)]) - (with-handlers ([exn:fail? (lambda (x) null)]) - (with-input-from-file f read)))) - - (define (SELF-ADDRESSES) (get-pref 'sirmail:self-addresses)) - - (define (AUTO-FILE-TABLE) (let ([f (get-pref 'sirmail:auto-file-table-file)]) - (and f - (with-handlers ([exn:fail? (lambda (x) null)]) - (with-input-from-file f read))))) - - (define (SORT) (get-pref 'sirmail:initial-sort)) - - (define (MESSAGE-FIELDS-TO-SHOW) (get-pref 'sirmail:fields-to-show)) - - (define (ROOT-MAILBOX-FOR-LIST) (get-pref 'sirmail:root-mailbox-folder)) - (define (ARCHIVE-MAILBOX) (get-pref 'sirmail:archive-mailbox-folder)) - - (define (USE-EXTERNAL-COMPOSER?) (get-pref 'sirmail:use-extenal-composer?)) - - (define (WARN-DOWNLOAD-SIZE) (get-pref 'sirmail:warn-download-size)) - - (define (SHOW-URLS) (get-pref 'sirmail:show-urls?)))) diff --git a/collects/sirmail/postmark-mask.xbm b/collects/sirmail/postmark-mask.xbm deleted file mode 100644 index 8852591826..0000000000 --- a/collects/sirmail/postmark-mask.xbm +++ /dev/null @@ -1,6 +0,0 @@ -#define mred_width 16 -#define mred_height 16 -static char mred_bits[] = { - 0x00,0x00,0x00,0x00,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff, - 0xff,0xff}; diff --git a/collects/sirmail/postmark.bmp b/collects/sirmail/postmark.bmp deleted file mode 100644 index c7bee59a04..0000000000 Binary files a/collects/sirmail/postmark.bmp and /dev/null differ diff --git a/collects/sirmail/pref.rkt b/collects/sirmail/pref.rkt deleted file mode 100644 index d9374aef69..0000000000 --- a/collects/sirmail/pref.rkt +++ /dev/null @@ -1,552 +0,0 @@ -(module pref mzscheme - - (require mzlib/class - framework - mred - mzlib/list - mzlib/string - mzlib/etc - net/head) - - ;; IMPORTANT! All preferences operations outside this - ;; file should go through the following exports. - ;; DO NOT use preferences:... elsewhere. - (provide get-pref put-pref - show-pref-dialog - add-preferences-menu-items) - - (define (string-or-false? x) (or (not x) (string? x))) - (define (ip-string? x) (and (string? x) - (positive? (string-length x)))) - (define (abs-path-or-false? x) - (or (not x) - (and (path? x) (absolute-path? x)))) - - (define (un/marshall-path pref) - (preferences:set-un/marshall pref - (lambda (x) - (if (path? x) - (path->bytes x) - x)) - (lambda (x) - (cond - [(bytes? x) (bytes->path x) ] - [(not x) x] - [else 'badvalue])))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Preference Definitions ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - - (preferences:set-default 'sirmail:mail-from "SirMail User " string?) - (preferences:set-default 'sirmail:username "username" string?) - (preferences:set-default 'sirmail:password #f string-or-false?) - (preferences:set-default 'sirmail:default-to-domain "racket-lang.org" ip-string?) - - (preferences:set-default 'sirmail:imap-server "imap.racket-lang.org" ip-string?) - (preferences:set-default 'sirmail:use-ssl? #f boolean?) - (preferences:set-default 'sirmail:server-certificate #f abs-path-or-false?) - (preferences:set-default 'sirmail:smtp-server "sendmail.racket-lang.org" ip-string?) - - (preferences:set-default 'sirmail:local-directory - (build-path (find-system-path 'home-dir) - "SirMail") - (lambda (x) - (and (path? x) - (absolute-path? x)))) - (un/marshall-path 'sirmail:local-directory) - (preferences:set-default 'sirmail:sent-directory - (build-path (find-system-path 'home-dir) - "SentMail") - (lambda (x) - (or (not x) - (and (path? x) - (absolute-path? x))))) - (un/marshall-path 'sirmail:sent-directory) - (preferences:set-default 'sirmail:root-mailbox-folder #f string-or-false?) - - (preferences:set-default 'sirmail:archive-mailbox-folder #f string-or-false?) - - (preferences:set-default 'sirmail:initial-sort 'id - (lambda (x) (memq x '(id date subject from)))) - (preferences:set-default 'sirmail:biff-delay - 60 - (lambda (x) - (or (not x) - (and (number? x) - (exact? x) - (integer? x) - (positive? x))))) - (preferences:set-default 'sirmail:warn-download-size 32000 - (lambda (x) (or (not x) (and (number? x) (real? x))))) - (preferences:set-default 'sirmail:external-composer 'xemacs - (lambda (x) (memq x '(xemacs gnu-emacs)))) - (preferences:set-default 'sirmail:use-extenal-composer? #f boolean?) - (preferences:set-default 'sirmail:show-urls? #t boolean?) - (preferences:set-default 'sirmail:show-gc-icon #f boolean?) - (preferences:set-default 'sirmail:always-happy #f boolean?) - (preferences:set-default 'sirmail:wrap-lines #f boolean?) - (preferences:set-default 'sirmail:prefer-text #t boolean?) - - (preferences:set-default 'sirmail:aliases-file - (build-path (find-system-path 'home-dir) ".sirmail.aliases") - abs-path-or-false?) - (un/marshall-path 'sirmail:aliases-file) - (preferences:set-default 'sirmail:auto-file-table-file (build-path (find-system-path 'home-dir) ".sirmail.auto-file") - abs-path-or-false?) - (un/marshall-path 'sirmail:auto-file-table-file) - - (preferences:set-default 'sirmail:self-addresses null - (lambda (x) (and (list? x) (andmap string? x)))) - (preferences:set-default 'sirmail:fields-to-show '("From" "To" "CC" "Subject" "Date" "X-Mailer" "X-Uptime") - (lambda (x) (and (list? x) (andmap string? x)))) - (preferences:set-default 'sirmail:bcc #f - (λ (x) (or (not x) (string? x)))) - - (let ([fw 560] - [fh 600]) - (let-values ([(display-width display-height) (get-display-size)]) - (preferences:set-default 'sirmail:frame-width - (min display-height fh) - (lambda (x) (and (number? x) (<= 0 x 32768)))) - (preferences:set-default 'sirmail:frame-height - (min display-width fw) - (lambda (x) (and (number? x) (<= 0 x 32768)))))) - - (define (xywh-okay? n) - (and (number? n) - (<= 0 n 10000))) - (preferences:set-default 'sirmail:folder-window-w 200 xywh-okay?) - (preferences:set-default 'sirmail:folder-window-h 400 xywh-okay?) - (preferences:set-default 'sirmail:folder-window-x 0 xywh-okay?) - (preferences:set-default 'sirmail:folder-window-y 0 xywh-okay?) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Preference Manager ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define prefs-eventspace (make-eventspace)) - - (define (in-preferences-eventspace thunk) - (let ([val #f] - [s (make-semaphore)]) - (parameterize ([current-eventspace prefs-eventspace]) - (queue-callback - (lambda () - (with-handlers ([void (lambda (x) - ;; Assume all raised values are exns - (set! val x))]) - (set! val (thunk))) - (semaphore-post s)))) - (semaphore-wait s) - (if (exn? val) - (raise val) - val))) - - (define (get-pref id) - (in-preferences-eventspace (lambda () - (preferences:get id)))) - - (define (put-pref id val) - (in-preferences-eventspace (lambda () - (preferences:set id val)))) - - (define (add-preferences-menu-items edit-menu) - (make-object separator-menu-item% edit-menu) - (make-object menu-item% "Preferences" edit-menu - (lambda (x y) (in-preferences-eventspace preferences:show-dialog)))) - - (define (show-pref-dialog) - (in-preferences-eventspace - (lambda () - (preferences:show-dialog) - (yield 'wait)))) - - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Preference Dialog ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define needs-check null) - - - (define (set-hilite e on?) - (send e change-style - (send (make-object style-delta%) set-delta-background (if on? "yellow" "white")) - 0 (send e last-position))) - - ;; make-text-field : string panel number symbol boolean - ;; ((union #f string) (union #f top-level-window<%>) string -> boolean) - ;; (any -> string) - ;; (string -> any) - ;; [ (union #f string) ] - ;; -> void - ;; sets up a text field for a preference - ;; The 3rd-to-last argument checks the validity of the field content.If - ;; a string is provided, then a top-level-window<%> is also provded, and - ;; the checking function should tell the user why the field-value string - ;; is bad if it is bad. - ;; the last two arguments convert between the string representation (as shown in the text field) - ;; and the preferences's actual Scheme value. - (define make-text-field - (opt-lambda (label panel width-num pref optional? check-value val->str str->val [post-label #f]) - (define p0 (and (or optional? post-label) - (instantiate horizontal-panel% (panel) [stretchable-height #f]))) - (define e (and optional? - (make-object check-box% label p0 - (lambda (c e) - (let ([on? (send c get-value)]) - (send t enable on?) - (if on? - (t-cb t e) - (begin - ;; remove all need-check registrations, if any: - (let loop () - (let ([a (assq t needs-check)]) - (when a - (set! needs-check (remq a needs-check)) - (loop)))) - (preferences:set pref #f)))))))) - (define t-cb (lambda (t e) - (let* ([s (send t get-value)]) - (if (check-value #f #f s) - (preferences:set pref (str->val s)) - (begin - (set! needs-check (cons (list t label check-value) needs-check)) - (set-hilite (send t get-editor) #t)))))) - (define t (make-object text-field% - (if optional? #f label) - (or p0 panel) - t-cb - (make-string width-num #\X))) - (when post-label - (send t stretchable-width #f) - (make-object message% post-label p0)) - - (send t set-value (let ([v (preferences:get pref)]) - (if v - (val->str v) - ""))) - (when optional? - (send e set-value (preferences:get pref))) - (when e - (send t enable (send e get-value))) - (preferences:add-callback pref (lambda (name val) - (set-hilite (send t get-editor) #f) - (when e - (send e set-value val) - (send t enable val)) - (when val - (let ([sval (val->str val)]) - (unless (equal? sval (send t get-value)) - (send t set-value sval)))))) - - (or p0 t))) - - (define (check-unsaved-pref?) - (and (andmap (lambda (a) - ((caddr a) (cadr a) (send (car a) get-top-level-window) (send (car a) get-value))) - needs-check) - (begin - (set! needs-check null) - #t))) - - (define make-file/directory-button - (lambda (dir? button-label parent pref enabler) - (define p0 (and enabler - (instantiate horizontal-panel% (parent) [stretchable-height #f]))) - (define e (and enabler - (make-object check-box% enabler p0 - (lambda (c e) - (let ([on? (send c get-value)]) - (send p enable on?) - (preferences:set - pref - (and on? - (string->path (send field get-value))))))))) - (define p (instantiate horizontal-panel% ((or p0 parent)) - [stretchable-height #f])) - (define (set-it v) - (preferences:set pref v)) - (define field (make-object text-field% button-label p - ;; For now, just counteract edits: - (lambda (t e) - (send field set-value (path->string (preferences:get pref)))) - (path->string - (or (preferences:get pref) - (current-directory))))) - (when e - (send e set-value (preferences:get pref)) - (send p enable (send e get-value))) - (preferences:add-callback pref (lambda (name val) - (when e - (send e set-value val) - (send p enable val)) - (when val - (send field set-value (path->string val))))) - (make-object button% "Set..." p (lambda (b e) - (let ([v ((if dir? get-directory get-file) - (or enabler button-label))]) - (when v - (set-it v))))) - p0)) - - (define make-boolean - (opt-lambda (label p pref [extra-action void]) - (define c - (make-object check-box% label p (lambda (c e) - (let ([v (send c get-value)]) - (extra-action v) - (preferences:set pref v))))) - (send c set-value (preferences:get pref)) - (preferences:add-callback pref (lambda (name val) - (send c set-value val))))) - - (define (is-host-address? s) - (regexp-match "^([-a-zA-Z0-9]+[.])*[-a-zA-Z0-9]+$" s)) - - (define (is-host-address+port? s) - (or (is-host-address? s) - (let ([m (regexp-match "^(.*):([0-9]+)$" s)]) - (and m - (<= 1 (string->number (caddr m)) 65535) - (is-host-address? (cadr m)))))) - - (define (is-host-address+port+user? s) - (or (is-host-address+port? s) - (let ([m (regexp-match "^(?:[-+a-zA-Z0-9_.]+)@(.*)$" s)]) - (and m - (is-host-address+port? (cadr m)))))) - - (define (is-host-address+port+user+type? s) - (or (is-host-address+port+user? s) - (let ([m (regexp-match "^(?:ssl|tcp):(.*)$" s)]) - (and m - (is-host-address+port+user? (cadr m)))))) - - (define (is-host-address+port+user+type-list? s) - (let ([l (regexp-split ", *" s)]) - (andmap is-host-address+port+user+type? l))) - - (define (check-address ok? who tl s port-ok? multi?) - (or (ok? s) - (begin - (when who - (message-box - "Preference Error" - (format (string-append - "The ~a value must be a~a host IP address~a~a~a.\n" - "An IP address is an string containing a combination of " - "period (.), dash (-), A-Z, a-Z, and 0-9. " - "Also the period cannot appear at the very beginning or end.\n" - "~a" - "You provided\n\n ~a\n\nwhich is not legal.") - who - (if multi? " comma-separated list of" "") - (if multi? " es" "") - (if (and multi? port-ok?) " each" "") - (if port-ok? " with an optional port number" "") - (if port-ok? - (string-append - "An optional port number is specified by adding a " - "colon (:) followed by a number between 1 and 65535.\n") - "") - s) - tl - '(ok stop))) - #f))) - - (define (check-host-address who tl s) - (check-address is-host-address? who tl s #f #f)) - (define (check-host-address/port who tl s) - (check-address is-host-address+port? who tl s #t #f)) - (define (check-host-address/port/user/type/multi who tl s) - (check-address is-host-address+port+user+type-list? who tl s #t #t)) - - ;; check-biff-delay : (union #f string) (union #f parent) string -> boolean - ;; checks to see if the string in the biff delay field makes - ;; sense as an exact integer between 1 and 3600 - (define (check-biff-delay who tl s) - (let ([n (string->number s)]) - (or (and (number? n) - (integer? n) - (exact? n) - (<= 1 n 3600)) - (begin - (when who - (message-box - "Preference Error" - (format (string-append - "The biff delay must be an exact integer between 1 and 3600.\n" - "You provided:\n" - " ~a") - s) - tl - '(ok stop))) - #f)))) - - - ;; check-message-size : (union #f string) (union #f parent) string -> boolean - ;; checks to see if the string in the download-max-size field makes - ;; sense as an exact positive integer - (define (check-message-size who tl s) - (let ([n (string->number s)]) - (or (and (number? n) - (integer? n) - (exact? n) - (positive? n)) - (begin - (when who - (message-box - "Preference Error" - (format (string-append - "The message size must be an exact, positive integer.\n" - "You provided:\n" - " ~a") - s) - tl - '(ok stop))) - #f)))) - - (define (check-user-address who tl s) - (with-handlers ([exn:fail? - (lambda (x) - (when who - (message-box - "Preference Error" - (format "The ~a value you provided is not a legal mail address: ~a" - who s) - tl - '(ok stop))) - #f)]) - (unless (= 1 (length (extract-addresses s 'all))) - (error "multiple addresses")) - #t)) - - (define (check-simple-user-address who tl s) - (and (check-user-address who tl s) - (car (extract-addresses s 'address)))) - - (define (check-id who tl s) #t) - - (define (make-text-list label parent pref check-item) - (let ([p (make-object group-box-panel% label parent)]) - (define l (make-object list-box% #f (or (preferences:get pref) null) p - (lambda (l e) - (send delete enable (pair? (send l get-selections)))) - '(multiple))) - (define hp (instantiate horizontal-panel% (p) - [stretchable-height #f] - [alignment '(center center)])) - (define add (make-object button% "Add" hp (lambda (b e) - (let loop ([init ""]) - (let ([v (get-text-from-user (format "Add to ~a" label) - (format "Add to ~a" label) - (send parent get-top-level-window) - init)]) - (when v - (let ([revised (check-item (format "item for ~a" label) - (send b get-top-level-window) v)]) - (if revised - (begin - (send l append (if (string? revised) revised v)) - (set-prefs)) - (loop v))))))))) - (define delete (make-object button% "Delete" hp (lambda (b e) - (let ([d (send l get-selections)]) - (for-each (lambda (i) - (send l delete i)) - (sort d >)) - (set-prefs))))) - (define (set-prefs) - (send delete enable (pair? (send l get-selections))) - (preferences:set - pref - (let ([n (send l get-number)]) - (let loop ([i 0]) - (if (= i n) - null - (cons (send l get-string i) - (loop (add1 i)))))))) - (send delete enable #f) - (preferences:add-callback pref (lambda (name val) - (send l clear) - (for-each (lambda (i) - (send l append i)) - val) - (send delete enable (pair? (send l get-selections))))))) - - (define (make-addresses-preferences-panel parent) - (let ([p (instantiate vertical-panel% (parent))]) - - (make-text-field "Mail From" p 20 'sirmail:mail-from #f check-user-address (lambda (x) x) (lambda (x) x)) - (make-text-field "SMTP Server" p 20 'sirmail:smtp-server #f check-host-address/port/user/type/multi - (lambda (x) x) (lambda (x) x)) - - (make-file/directory-button #t #f p - 'sirmail:sent-directory - "Save Sent Files") - - - (make-text-field "Default \"To\" domain" p 20 'sirmail:default-to-domain #f check-host-address (lambda (x) x) (lambda (x) x)) - (make-text-field "BCC line" p 20 'sirmail:bcc #t void (lambda (x) x) (lambda (x) x)) - (make-file/directory-button #f #f p - 'sirmail:aliases-file - "Aliases File") - - (make-text-list "Self Addresses" p 'sirmail:self-addresses check-simple-user-address) - - (make-boolean "Enable compose-with-Emacs" p 'sirmail:use-extenal-composer?) - - p)) - - (define (make-mbox-preferences-panel parent) - (let ([p (instantiate vertical-panel% (parent) - (alignment '(left center)))]) - - (make-text-field "Username" p 10 'sirmail:username #f check-id (lambda (x) x) (lambda (x) x)) - (let ([sp (instantiate group-box-panel% ("IMAP Server" p) - [alignment '(left center)])] - [cert #f]) - (make-text-field "Server" sp 20 'sirmail:imap-server #f check-host-address/port (lambda (x) x) (lambda (x) x)) - (make-boolean "Encrypt connection using SSL" sp 'sirmail:use-ssl? - (lambda (on?) (send cert enable on?))) - (set! cert (make-file/directory-button #f #f sp - 'sirmail:server-certificate - "Verify SSL with certificates")) - (make-text-field "Archive folder" sp 20 'sirmail:archive-mailbox-folder #t void (lambda (x) x) (lambda (x) x)) - (make-text-field "Folder list root" sp 20 'sirmail:root-mailbox-folder #t void (lambda (x) x) (lambda (x) x)) - - (send cert enable (preferences:get 'sirmail:use-ssl?))) - - (make-file/directory-button #t "Local directory" p - 'sirmail:local-directory - #f) - - (make-text-field "Check mail every" p 5 'sirmail:biff-delay #t check-biff-delay number->string string->number - "seconds") - - (make-text-field "Verify download of messages larger than" p 10 - 'sirmail:warn-download-size #t - check-message-size number->string string->number - "bytes") - - (make-file/directory-button #f #f p - 'sirmail:auto-file-table-file - "Auto-file table file") - - (make-boolean "Show GC icon" p 'sirmail:show-gc-icon) - (make-boolean "Always happy to get mail" p 'sirmail:always-happy) - - (make-text-list "Shown Header Fields" p 'sirmail:fields-to-show void) - - p)) - - (in-preferences-eventspace - (lambda () - (preferences:add-panel "Reading" make-mbox-preferences-panel) - (preferences:add-panel "Sending" make-addresses-preferences-panel) - (preferences:add-editor-checkbox-panel) - (preferences:add-can-close-dialog-callback check-unsaved-pref?)))) - diff --git a/collects/sirmail/readr.rkt b/collects/sirmail/readr.rkt deleted file mode 100644 index 5a648b14b8..0000000000 --- a/collects/sirmail/readr.rkt +++ /dev/null @@ -1,3245 +0,0 @@ -;; 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.rkt". -;; - -(module readr mzscheme - (require mzlib/unit - mzlib/class - mzlib/file - mred/mred-sig - framework - mzlib/process) - - (require mzlib/string - mzlib/list - mzlib/thread - "spell.rkt") - - (require "sirmails.rkt") - - (require "pref.rkt") - - (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) - - (require (only racket/base log-error)) - - ;; Constant for messages without a title: - (define no-subject-string "") - - (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 () - (printf "(\n") - (for-each (lambda (l) - (write l) - (newline)) - (cons uid-validity (map vector->list mailbox))) - (printf ")\n")) - '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) - ""))) - 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 selected-text-color (get-highlight-text-color)) - (define selected-pen (send the-pen-list find-or-create-pen (or selected-text-color "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 (if (pair? draw-caret) - selected-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)))] - [fg+mode (and (pair? draw-caret) - (cons (send dc get-text-foreground) - (send dc get-text-mode)))]) - (when fg+mode - (when selected-text-color - (send dc set-text-foreground selected-text-color)) - (send dc set-text-mode 'transparent)) - (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) - (when fg+mode - (send dc set-text-foreground (car fg+mode)) - (send dc set-text-mode (cdr fg+mode)))) - - (let ([p (send dc get-pen)]) - (send dc set-pen (if (pair? draw-caret) - selected-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)) - ""))) - (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) "")]) - (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 "<>") - (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 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.rkt -- be sure to propagate 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 fromseconds -- 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 boolean - ;; compares messages by from lines, defaults to uid if froms are equal. - (define (from 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 boolean - ;; compares messages by subject lines, defaults to uid if subjects are equal. - (define (subject 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 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.rkt. This is - ;; the set-up for opening such a window. - - (define my-address - (with-handlers ([void (lambda (x) "")]) - (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 :\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:")))) diff --git a/collects/sirmail/recover.rkt b/collects/sirmail/recover.rkt deleted file mode 100644 index 3e4fef4064..0000000000 --- a/collects/sirmail/recover.rkt +++ /dev/null @@ -1,29 +0,0 @@ -#lang scheme - -(require mzlib/list net/head) - -(define msgs - (sort (filter (lambda (x) (regexp-match #rx"^[0-9]*$" (path->string x))) (directory-list)) - (lambda (a b) (< (string->number (path->string a)) - (string->number (path->string b)))))) - -(define mailbox - (let loop ([msgs msgs][p 1]) - (if (null? msgs) - null - (let ([msg (car msgs)] - [rest (loop (cdr msgs) (add1 p))]) - (let ([header (with-input-from-file msg - (lambda () (read-string (file-size msg))))]) - (cons (list - (string->number (path->string msg)) - p - (file-exists? (format "~abody" msg)) - (extract-field "From" header) - (extract-field "Subject" header) - null - #f) - rest)))))) - -(with-output-to-file "mailbox" (lambda () (write mailbox) (newline)) - #:exists 'truncate) diff --git a/collects/sirmail/sendr.rkt b/collects/sirmail/sendr.rkt deleted file mode 100644 index 34784f6b78..0000000000 --- a/collects/sirmail/sendr.rkt +++ /dev/null @@ -1,1025 +0,0 @@ -;; This module implements the mail-composing window. The `new-mailer' -;; function creates a compose-window instance. - -(module sendr scheme/base - (require scheme/tcp - scheme/unit - scheme/class - scheme/string - mred/mred-sig - framework) - - (require scheme/file - mzlib/process - openssl/mzssl) - - (require "sirmails.rkt" - "pref.rkt" - "spell.rkt") - - (require net/imap-sig - net/smtp-sig - net/head-sig - net/base64-sig - net/qp-sig) - - (require mrlib/hierlist/hierlist-sig) - - (define smtp-passwords (make-hash)) - - (provide send@) - (define-unit send@ - (import sirmail:exit^ - sirmail:utils^ - sirmail:options^ - sirmail:read^ - (prefix env: sirmail:environment^) - mred^ - imap^ - smtp^ - head^ - base64^ - qp^ - hierlist^) - (export sirmail:send^) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Constants ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (show-error x main-frame) - (show-error-message-box x main-frame)) - - (define FRAME-WIDTH 560) - (define FRAME-HEIGHT 600) - (let-values ([(display-width display-height) (get-display-size)]) - (set! FRAME-HEIGHT (min display-height FRAME-HEIGHT)) - (set! FRAME-WIDTH (min display-width FRAME-WIDTH))) - - (define FORWARD-LIST-HEIGHT 50) - - (define return-bitmap - (with-handlers ([void (lambda () #f)]) - (let ([bm (make-object bitmap% - (build-path - (collection-path "icons") - "return.xbm"))]) - (and (send bm ok?) bm)))) - - (define send-icon (make-object bitmap% (build-path (collection-path "sirmail") - "stamp.bmp"))) - (define send-icon-mask (make-object bitmap% (build-path (collection-path "sirmail") - "stamp-mask.xbm"))) - (unless (and (send send-icon ok?) - (send send-icon-mask ok?)) - (set! send-icon #f)) - - (define SEPARATOR (make-string 75 #\=)) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Address Parsing ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Returns a list of -
pairs - (define (resolve-alias addr) - (cond - [(assoc addr (ALIASES)) - => (lambda (m) - (let ([resolve - (lambda (n) - (let ([l (sm-extract-addresses n)]) - (unless (> (length l) 0) - (error 'resolve-alias "alias is not an address: ~a" n)) - l))]) - (if (list? (cadr m)) - (apply append (map resolve (cadr m))) - (resolve (cadr m)))))] - [(DEFAULT-DOMAIN) (let ([addr (format "~a@~a" addr (DEFAULT-DOMAIN))]) - (list (cons addr addr)))] - [else (list (cons addr addr))])) - - ;; Returns a list of -
pairs - (define (sm-extract-addresses s) - (let ([addrs (extract-addresses s 'all)]) - (apply - append - (map - (lambda (a) - (let ([name (car a)] - [address (cadr a)] - [full (caddr a)]) - (if (and (string=? address full) - (not (regexp-match "@" full))) - (resolve-alias full) - (list (cons full address))))) - addrs)))) - - (define (remove-fields l h) - (if (null? l) - h - (remove-fields (cdr l) (remove-field (car l) h)))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Enclosures ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define-struct enclosure (name ; identifies enclosure in the GUI - subheader ; header for enclosure - data-thunk) ; gets enclosure data as bytes (already encoded) - #:mutable) - - ;; Create a message with enclosures. - ;; `header' is a message header created with the head.rkt library - ;; `body-lines' is a list of strings and byte strings - ;; `enclosures' is a list of `enclosure' structs - (define (enclose header body-lines enclosures) - (define qp-body-lines? - (ormap (lambda (l) - (or ((string-length l) . > . 1000) - (regexp-match? #rx"[^\0-\177]" l))) - body-lines)) - (define (encode-body-lines) - (if qp-body-lines? - (map - bytes->string/utf-8 - (regexp-split #rx"\r\n" - (qp-encode (string->bytes/utf-8 - (string-join body-lines "\r\n"))))) - body-lines)) - (define (add-body-encoding-headers header) - (insert-field - "Content-Type" - "text/plain; charset=UTF-8" - (insert-field - "Content-Transfer-Encoding" - (if qp-body-lines? "quoted-printable" "7bit") - header))) - (if (null? enclosures) - (values (insert-field - "MIME-Version" - "1.0" - (add-body-encoding-headers - header)) - (encode-body-lines)) - (let* ([enclosure-datas - (map (lambda (e) ((enclosure-data-thunk e))) enclosures)] - [boundary - ;; Generate something that isn't there: - (let loop () - (let* ([b (format "---~a~a~a-----" (random 10000) (random 10000) (random 10000))] - [m (regexp b)]) - (if (or (ormap (lambda (bl) - (regexp-match-positions m bl)) - body-lines) - (ormap - (lambda (enc data) - (or (regexp-match-positions m (enclosure-subheader enc)) - (ormap (lambda (bl) - (regexp-match-positions m bl)) - data))) - enclosures enclosure-datas)) - (loop) - b)))]) - (let ([mime-header (insert-field - "MIME-Version" - "1.0" - (insert-field - "Content-Type" - (data-lines->data - (list - "multipart/mixed;" - (format "boundary=~s" - boundary))) - empty-header))]) - (values (append-headers header mime-header) - (append - (list - "This is a multi-part message in MIME format." - (format "--~a" boundary)) - (header->lines - (add-body-encoding-headers - empty-header)) - (encode-body-lines) - (apply - append - (map - (lambda (enc data) - (cons - (format "--~a" boundary) - (append - (header->lines - (enclosure-subheader enc)) - data))) - enclosures enclosure-datas)) - (list - (format "--~a--" boundary)))))))) - - (define (get-enclosure-type-and-encoding filename mailer-frame auto?) - (let ([types '("application/postscript" - "text/plain" - "text/plain; charset=UTF-8" - "text/html" - "image/jpeg" - "image/gif" - "image/png" - "application/octet-stream")] - [encodings '("7bit" - "quoted-printable" - "base64")] - [d (instantiate dialog% ("Enclosure" mailer-frame) - [alignment '(left center)])]) - (make-object message% (string-append - "File: " - (let ([filename (path->string filename)]) - (let ([l (string-length filename)]) - (if (l . < . 58) - filename - (string-append - (substring filename 0 5) - "..." - (substring filename (- l 50) l)))))) - d) - (let ([type-list (make-object choice% "Type:" types d void)] - [encoding-list (make-object choice% "Encoding:" encodings d void)] - [inline-check (make-object check-box% "Inline in recipient's view" d void)] - [button-panel (instantiate horizontal-pane% (d) - [alignment '(right center)] - [stretchable-height #f])] - [ok? auto?]) - (let-values ([(ok cancel) (gui-utils:ok/cancel-buttons - button-panel - (lambda (b e) - (set! ok? #t) - (send d show #f)) - (lambda (b e) - (send d show #f)))]) - (let ([default (lambda (t e inline?) - (letrec ([findpos (lambda (l s) - (if (string=? (car l) s) - 0 - (add1 (findpos (cdr l) s))))]) - (send type-list set-selection (findpos types t)) - (send encoding-list set-selection (findpos encodings e)) - (send inline-check set-value inline?)))] - [suffix (let ([m (regexp-match #rx"[.](.*)$" (path->string filename))]) - (and m (cadr m)))]) - (case (if suffix (string->symbol (string-locale-downcase suffix)) '???) - [(txt ss scm) (default "text/plain" "quoted-printable" #f)] - [(htm html) (default "text/html" "quoted-printable" #f)] - [(ps) (default "application/postscript" "base64" #f)] - [(jpeg jpg) (default "image/jpeg" "base64" #t)] - [(png) (default "image/png" "base64" #t)] - [(gif) (default "image/gif" "base64" #t)] - [else (default "application/octet-stream" "base64" #f)])) - (unless auto? - (send d show #t)) - (if ok? - (values (list-ref types (send type-list get-selection)) - (list-ref encodings (send encoding-list get-selection)) - (send inline-check get-value)) - (values #f #f #f)))))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Composer Instance ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; new-mailer : ... -> frame[with send-message method] - (define (new-mailer file to cc subject other-headers body enclosures message-count) - (define f% (class frame:basic% - (inherit get-menu-bar set-icon get-eventspace accept-drop-files) - [define/public (send-message) - (send-msg)] - (define/augment (can-close?) - (and (send (get-menu-bar) is-enabled?) - (or (not (send message-editor is-modified?)) - (eq? 'yes - (confirm-box - "Warning" - "The message is not saved or sent. Close anyway?" - this))) - (inner #t can-close?))) - (define/augment (on-close) - (send message-editor on-close) - (inner (void) on-close) - (exit-sirmail "mailer close")) - (define/override (on-drop-file f) - (add-enclosure-file f #t)) - (super-instantiate ()) - (accept-drop-files #t) - (when send-icon - (set-icon send-icon send-icon-mask)))) - (define mailer-frame (make-object f% "Send Mail" #f FRAME-WIDTH FRAME-HEIGHT)) - - (define mb (send mailer-frame get-menu-bar)) - (define file-menu (make-object menu% "File" mb)) - (define edit-menu (make-object menu% "Edit" mb)) - (define composer-menu (and (USE-EXTERNAL-COMPOSER?) - (make-object menu% "Composer" mb))) - (define button-pane (make-object horizontal-pane% (send mailer-frame get-area-container))) - (define title-message (make-object message% "Compose message" button-pane)) - (define button-pane-spacer (make-object vertical-pane% button-pane)) - (define cancel-button - (make-object button% "Stop" button-pane - (lambda (b e) (cancel-button-todo)))) - (define cancel-button-todo void) - - (define external-composer-button - (and (USE-EXTERNAL-COMPOSER?) - (make-object - button% - "External Composer" - button-pane - (lambda (button control-event) - (let ([t (make-temporary-file "sirmail~a")]) - - (send message-editor save-file t 'text #t) - - ; To get rid of the Standard Output window: Set - ; the current output & error ports to something - ; else. Or use `process' instead. Warning: be sure - ; to test in error circumstances (eg, when the - ; external program can't be found). - - (system - (case external-composer - [(xemacs) - (string-append "gnuclient +5 " t)] - [(gnu-emacs) - (string-append "emacsclient +5 " t)])) - - (send message-editor load-file t 'guess #t) - - (with-handlers - ([exn:fail:filesystem? - (lambda (exn) - (message-box "Error Deleting Temporary File" - (string-append - "Attempted to delete the " - "temporary file " - "`" t "'" - "but couldn't find it.") - #f - '(ok)))]) - (delete-file t))))))) - - (define c (new canvas:color% - [parent (send mailer-frame get-area-container)] - [style '(auto-hscroll)])) - (define message-editor-super% - (color:text-mixin - (editor:backup-autosave-mixin - (text:foreground-color-mixin - text:standard-style-list%)))) - (define message-editor (make-object (class message-editor-super% - (inherit reset-region) - - (define immutable-start 0) - (define immutable-end 0) - - (define/override (set-modified mod?) - (send mailer-frame modified mod?) - (super set-modified mod?)) - (define/public (set-no-change-region start end) - (set! immutable-start start) - (set! immutable-end end) - (reset-region end 'end)) - - (define/augment (can-insert? start len) - (and (or (<= start immutable-start) - (>= start immutable-end)) - (inner #t can-insert? start len))) - (define/augment (after-insert start len) - (when (<= start immutable-start) - (set! immutable-start (+ immutable-start len)) - (set! immutable-end (+ immutable-end len)) - (reset-region immutable-end 'end)) - (inner (void) after-insert start len)) - - (define/augment (can-delete? start len) - (and (or (<= (+ start len) immutable-start) - (>= start immutable-end)) - (inner #t can-delete? start len))) - (define/augment (after-delete start len) - (when (<= start immutable-start) - (set! immutable-start (- immutable-start len)) - (set! immutable-end (- immutable-end len)) - (reset-region immutable-end 'end)) - (inner (void) after-delete start len)) - - (super-new)))) - (define enclosure-list (make-object hierarchical-list% (send mailer-frame get-area-container))) - - (define plain-cursor (make-object cursor% 'arrow)) - (define arrow+watch-cursor (make-object cursor% 'arrow+watch)) - - (define (enable on? refocus cancel-proc) - (let ([w (send mailer-frame get-focus-window)]) - (set! cancel-button-todo cancel-proc) - (send mb enable on?) - (send c enable on?) - (send cancel-button enable (not on?)) - (let* ([cursor (if on? plain-cursor arrow+watch-cursor)]) - (send mailer-frame set-cursor cursor) - (send (send c get-editor) set-cursor (if on? #f cursor) #t)) - (when (and on? refocus) - (send refocus focus)) - w)) - - (define (send-msg) - (define-values (smtp-ssl? smtp-auth-user smtp-server-to-use smtp-port-to-use) - (parse-server-name+user+type (SMTP-SERVER) 25)) - (define smtp-auth-passwd (and smtp-auth-user - (or (hash-ref smtp-passwords (cons smtp-auth-user smtp-server-to-use) - (lambda () #f)) - (let ([p (get-pw-from-user smtp-auth-user mailer-frame)]) - (unless p (raise-user-error 'send "send canceled")) - p)))) - (send-message - (send message-editor get-text) - smtp-ssl? - smtp-server-to-use - smtp-port-to-use - smtp-auth-user smtp-auth-passwd - (map (lambda (i) (send i user-data)) - (send enclosure-list get-items)) - enable - (lambda () (send mailer-frame set-status-text "Sending mail...")) - (lambda () (send mailer-frame set-status-text "Building enclosures...")) - (lambda () (send mailer-frame set-status-text "")) - (lambda () - (send mailer-frame on-close) - (send mailer-frame show #f)) - (lambda () - (let loop () - (when (eq? (message-box "Save?" "Save message before killing?" #f '(yes-no caution)) - 'yes) - (let ([f (put-file)]) - (if f - (send message-editor save-file f 'text) - (loop)))))) - message-count) - (when smtp-auth-passwd - (hash-set! smtp-passwords (cons smtp-auth-user smtp-server-to-use) - smtp-auth-passwd))) - - ;; enq-msg : -> void - ;; enqueues a message for a later send - (define (enq-msg) - (let ([filename (get-fresh-queue-filename)]) - (send message-editor save-file filename 'text)) - - (when (send mailer-frame can-close?) - (send mailer-frame on-close) - (send mailer-frame show #f))) - - ;; get-fresh-queue-filename : -> string - (define (get-fresh-queue-filename) - (build-path queue-directory - (format "enq~a" (+ 1 (length (directory-list queue-directory)))))) - - (define (add-enclosure-file file auto?) - (let-values ([(type encoding inline?) (get-enclosure-type-and-encoding file mailer-frame auto?)]) - (when (and type encoding) - (let ([i (send enclosure-list new-item)] - [enc (make-enclosure - (path->string file) - (let ([fn (clean-filename - (with-handlers ([void (lambda (x) "unknown")]) - (let-values ([(base name dir?) (split-path file)]) - (path->string name))))]) - (insert-field - "Content-Type" - (data-lines->data - (list - (string-append type ";") - (format "name=~s" fn))) - (insert-field - "Content-Transfer-Encoding" encoding - (insert-field - "Content-Disposition" - (data-lines->data - (list - (format "~a; " (if inline? 'inline 'attachment)) - (format "filename=~s" fn))) - empty-header)))) - (lambda () - (let ([content (with-input-from-file file - (lambda () - (read-bytes (file-size file))))]) - (case (string->symbol encoding) - [(base64) (split-crlf (base64-encode content))] - [(quoted-printable) (split-crlf (qp-encode (lf->crlf content)))] - [(7bit) (split-lf (crlf->lf content))]))))]) - (send (send i get-editor) insert (enclosure-name enc)) - (send i user-data enc) - (let ([p (send mailer-frame get-area-container)]) - (unless (memq enclosure-list (send p get-children)) - (send p add-child enclosure-list))))))) - - (define external-composer (get-pref 'sirmail:external-composer)) - - (frame:reorder-menus mailer-frame) - (send button-pane stretchable-height #f) - (send cancel-button enable #f) - - (send enclosure-list stretchable-height #f) - (send enclosure-list min-height FORWARD-LIST-HEIGHT) - (when (null? enclosures) - (send (send mailer-frame get-area-container) delete-child enclosure-list)) - (for-each - (lambda (enc) - (let ([i (send enclosure-list new-item)]) - (send (send i get-editor) insert (enclosure-name enc)) - (send i user-data enc))) - enclosures) - - (when (USE-EXTERNAL-COMPOSER?) - (letrec ([switch (lambda (item e) - (if (send item is-checked?) - (begin - ;; Disable others: - (send xemacs check (eq? xemacs item)) - (send gnu-emacs check (eq? gnu-emacs item)) - ;; Update flags - (set! external-composer - (cond - [(send xemacs is-checked?) - 'xemacs] - [(send gnu-emacs is-checked?) - 'gnu-emacs])) - (put-pref 'sirmail:external-composer external-composer)) - ;; Turn it back on - (send item check #t)))] - [xemacs (make-object checkable-menu-item% "XEmacs" composer-menu switch)] - [gnu-emacs (make-object checkable-menu-item% "GNU Emacs" composer-menu switch)]) - (send - (case external-composer - [(xemacs) xemacs] - [(gnu-emacs) gnu-emacs]) - check #t))) - - (make-object menu-item% "Save" file-menu - (lambda (i ev) (send message-editor save-file #f 'text))) - (make-object menu-item% "Send" file-menu (lambda (i ev) (send-msg))) - (make-object menu-item% "Enqueue message" file-menu (lambda (i ev) (enq-msg))) - (make-object separator-menu-item% file-menu) - (make-object menu-item% "Add Enclosure..." file-menu - (lambda (i env) - (let ([file (get-file "Get Enclosure" mailer-frame)]) - (when file - (add-enclosure-file file #f))))) - - (make-object separator-menu-item% file-menu) - (make-object (class menu% - (inherit get-items) - (define/override (on-demand) - (for-each (lambda (i) (send i delete)) (get-items)) - (let ([server (SMTP-SERVER)] - [servers (SMTP-SERVERS)]) - (for-each - (lambda (s) - (let ([i (make-object checkable-menu-item% s this - (lambda (i e) - (for-each (lambda (i) (send i check #f)) (get-items)) - (set-SMTP-SERVER! s) - (send i check #t)))]) - (when (string=? s server) - (send i check #t)))) - servers))) - (super-make-object "SMTP Server" file-menu))) - (make-object separator-menu-item% file-menu) - (make-object menu-item% "Close" file-menu - (lambda (i e) - (when (send mailer-frame can-close?) - (send mailer-frame on-close) - (send mailer-frame show #f))) - (if (eq? (system-type) 'windows) #f #\W)) - (append-editor-operation-menu-items edit-menu #t) - ;; Strip menu key bindings - (for-each - (lambda (i) - (when (is-a? i selectable-menu-item<%>) - (send i set-shortcut #f))) - (send edit-menu get-items)) - - (make-object separator-menu-item% edit-menu) - (send (instantiate menu-item% ("Delete Enclosure" edit-menu) - [callback (lambda (i e) - (let ([i (send enclosure-list get-selected)]) - (send enclosure-list delete-item i)))] - [demand-callback (lambda (m) - (send m enable (send enclosure-list get-selected)))]) - enable #f) - (instantiate menu-item% ("Clone Message" edit-menu) - [callback (lambda (i e) - (let ([p (open-input-text-editor message-editor)] - [s (make-semaphore)]) - (env:start-new-window - (lambda () - (new-mailer p "" "" "" "" "" - (map (lambda (i) (send i user-data)) - (send enclosure-list get-items)) - message-count) - (semaphore-post s))) - (semaphore-wait s)))] - [shortcut #\=]) - - (add-preferences-menu-items edit-menu) - - (let ([km (send message-editor get-keymap)]) - (send km add-function "reflow-paragraph" - (lambda (e ev) (reflow-paragraph - e - (add1 (send e find-string SEPARATOR - 'forward 0 'eof #f))))) - (send km map-function ":m:q" "reflow-paragraph") - (send km map-function ":a:q" "reflow-paragraph") - (special-option-key #t) - - (add-text-keymap-functions km) - (keymap:setup-global km) - - (send km add-function "send-message" - (lambda (w e) (send-msg))) - (send km map-function ":m:return" "send-message") - (send km map-function ":a:return" "send-message")) - - (make-fixed-width c message-editor #t return-bitmap) - (send message-editor set-paste-text-only #t) - (send message-editor set-max-undo-history 'forever) - (send c set-editor message-editor) - - (activate-spelling message-editor) - - (send message-editor begin-edit-sequence) - (if file - ;; Resume/clone a composition... - (begin - (if (port? file) - (send message-editor insert-port file) - (send message-editor load-file file)) - (let ([pos (send message-editor - find-string (string-append "\n" SEPARATOR "\n") - 'forward 0)]) - (when pos - (send message-editor set-no-change-region - pos - (+ pos 2 (string-length SEPARATOR)))))) - ;; Build message skeleton - (begin - (send message-editor insert "To: ") - (send message-editor insert (string-crlf->lf to)) - (send message-editor insert #\newline) - (unless (string=? cc "") - (send message-editor insert "CC: ") - (send message-editor insert (string-crlf->lf cc)) - (send message-editor insert #\newline)) - (send message-editor insert "Subject: ") - (send message-editor insert (string-crlf->lf subject)) - (send message-editor insert #\newline) - (let ([bcc-header (get-pref 'sirmail:bcc)]) - (when bcc-header - (send message-editor insert "bcc: ") - (send message-editor insert bcc-header) - (send message-editor insert #\newline))) - (send message-editor insert (string-crlf->lf other-headers)) - (send message-editor insert "X-Mailer: SirMail under GRacket ") - (send message-editor insert (version)) - (send message-editor insert " (") - (send message-editor insert (path->string (system-library-subpath))) - (send message-editor insert ")") - (let ([start-no-change (send message-editor last-position)]) - (send message-editor insert #\newline) - (send message-editor insert SEPARATOR) - (send message-editor insert #\newline) - (send message-editor set-no-change-region - start-no-change - (send message-editor last-position))) - (let ([message-start (send message-editor last-position)]) - (send message-editor insert body) - (if (string=? to "") - (send message-editor set-position (send message-editor paragraph-end-position 0)) - (send message-editor set-position message-start))) - (send message-editor change-style - (send (send message-editor get-style-list) - find-named-style - (editor:get-default-color-style-name)) - 0 - (send message-editor last-position)))) - - (send message-editor clear-undos) - (send message-editor set-modified #f) - (send message-editor scroll-to-position 0) - (send message-editor end-edit-sequence) - - (send c focus) - - (send mailer-frame create-status-line) - - (send mailer-frame show #t) - - (uncaught-exception-handler - (lambda (x) - (show-error x mailer-frame) - ((error-escape-handler)))) - - mailer-frame) - - - ;; clean-filename : string -> string - ;; builds a filename from a name by sripping out bad chars. - (define (clean-filename name) - (regexp-replace* "[ /:\\\"'`?*%<>$|\u0100-\U10FFFF]" name "_")) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Message Send ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (send-message message-str - ssl? - smtp-server - smtp-port auth-user auth-pw - enclosures - enable - status-message-starting - status-message-enclosures - status-message-clear - status-done - save-before-killing - message-count) - (let ([re (regexp (format "~a\n" SEPARATOR))]) - (let ([m (regexp-match-positions re message-str)]) - (if m - (let ([header (string-append - (string-lf->crlf (substring message-str 0 (caar m))) - (build-uptime-field message-count) - "\r\n" - empty-header)] - [body-lines (regexp-split - #rx"\n" - (substring message-str (cdar m) (string-length message-str)))]) - (validate-header (regexp-replace* #rx"[^\x0-\xFF]" header "_")) - (let* ([to* (sm-extract-addresses (extract-field "To" header))] - [to (map encode-for-header (map car to*))] - [cc* (sm-extract-addresses (extract-field "CC" header))] - [cc (map encode-for-header (map car cc*))] - [bcc* (sm-extract-addresses (extract-field "BCC" header))] - [bcc (map encode-for-header (map car bcc*))] - [from (let ([l (extract-addresses (MAIL-FROM) 'full)]) - (unless (= 1 (length l)) - (error 'send "bad mail-from configuration: ~a" (MAIL-FROM))) - (car l))] - [simple-from (let ([l (extract-addresses (MAIL-FROM) 'address)]) - (unless (= 1 (length l)) - (error 'send "bad mail-from configuration: ~a" (MAIL-FROM))) - (car l))] - [subject (encode-for-header (extract-field "Subject" header))] - [prop-header (remove-fields '("To" "CC" "BCC" "Subject") header)] - [std-header (standard-message-header from to cc bcc subject)] - [new-header (append-headers std-header prop-header)] - [tos (map cdr (append to* cc* bcc*))]) - - (validate-header new-header) - - (as-background - enable - (lambda (break-bad break-ok) - (if (null? enclosures) - (status-message-starting) - (status-message-enclosures)) - (with-handlers ([void (lambda (x) - (status-message-clear) - (raise x))]) - (break-ok) - (let-values ([(new-header body-lines) (enclose new-header body-lines enclosures)]) - (break-bad) - (unless (null? enclosures) - (status-message-starting)) - (when (SAVE-SENT) - (let* ([chop (lambda (s) - (let ([l (string-length s)]) - (clean-filename (substring s 0 (min l 10)))))] - [to (if (null? tos) "noone" (chop (car tos)))] - [subj (if subject (chop subject) "nosubj")]) - (let loop ([n 1]) - (let ([fn (build-path (SAVE-SENT) (format "~a_~a_~a" to subj n))]) - (if (file-exists? fn) - (loop (add1 n)) - (with-output-to-file fn - (lambda () - (display (string-crlf->lf header)) - (map (lambda (body-line) - (display body-line) - (newline)) - body-lines)))))))) - (break-ok) - (smtp-sending-end-of-message break-bad) - (smtp-send-message smtp-server - simple-from - tos - new-header - body-lines - #:port-no smtp-port - #:tcp-connect (if ssl? ssl-connect tcp-connect) - #:auth-user auth-user - #:auth-passwd auth-pw)))) - save-before-killing)) - (status-done)) - (message-box - "Error" - (format "Lost \"~a\" separator" SEPARATOR)))))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Meta-Q Reflowing ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define reflow-wordbreak-map - (make-object editor-wordbreak-map%)) - (send reflow-wordbreak-map set-map #\- '(line)) - (define (reflow-paragraph edit start-min) - (let ([wbm (send edit get-wordbreak-map)]) - (dynamic-wind - (lambda () - (send edit set-wordbreak-map reflow-wordbreak-map) - (send edit begin-edit-sequence)) - (lambda () - (let* ([p (max start-min (send edit get-start-position))] - [min-line (send edit position-paragraph start-min)] - [end-line (send edit position-paragraph p)]) - ;; Find start and end lines that form a paragraph: - (let* ([start-l - (let loop ([start-l end-line]) - (if (or (<= start-l min-line) - (= (send edit paragraph-start-position start-l) - (add1 (send edit paragraph-start-position (sub1 start-l))))) - start-l - (loop (sub1 start-l))))] - [end-l - (let loop ([end-l start-l]) - (if (or (= end-l (send edit last-paragraph)) - (= (send edit paragraph-end-position end-l) - (sub1 (send edit paragraph-end-position (add1 end-l))))) - end-l - (loop (add1 end-l))))]) - ;; Remember start and end positions, and determine the paragraph prefix: - (let ([orig-start (send edit paragraph-start-position start-l)] - [end (send edit paragraph-end-position end-l)] - [second-line-prefix - (if (= start-l end-l) - "" - (let ([p (send edit paragraph-start-position (add1 start-l))]) - (let loop ([pe p]) - (case (send edit get-character pe) - [(#\space #\tab #\>) (loop (add1 pe))] - [else (send edit get-text p pe)]))))]) - ;; Adjust starting position by skipping spaces on the first line: - (let ([start - (let ([start-end (send edit paragraph-end-position start-l)]) - (let loop ([start orig-start]) - (cond - [(= start-end start) orig-start] - [(memq (send edit get-character start) '(#\space #\tab)) - (loop (add1 start))] - [else start])))]) - ;; Remove all line breaks, double spaces, tabs, and prefixes, - ;; producing a revised start and end position: - (let-values ([(start end) - (let loop ([start start] - [end end] - ;; l is the list of patterns to delete: - [l (list (string-append (string #\newline) - second-line-prefix) - (string #\newline) - (string #\tab) - (string #\space #\space))]) - ;; Look for the first thing in l: - (let ([p (send edit find-string (car l) - 'forward start end)]) - (if (or p (pair? (cdr l))) - (if p - ;; Found an instance; replace it with a single space, - ;; and look again - (let ([len (string-length (car l))]) - (send edit insert " " p (+ p len)) - (loop start (- end len -1) l)) - ;; Didn't find an instance; start looking for the - ;; next thing in our list - (loop start end (cdr l))) - ;; Nothing else to find, so we're done removing things - (values start end))))]) - ;; At this point the paragraph should be on a single line. - ;; Insert good line breaks to wrap the paragraph: - (let ([line-break (string-append (string #\newline) - second-line-prefix)] - [slp-len (string-length second-line-prefix)]) - (let loop ([start start] - [len (- start orig-start)] - ;; Actually, remove ending space before we start: - [end (if (or (= end start) - (not (char=? - #\space - (send edit get-character - (sub1 end))))) - end - (begin - (send edit delete (sub1 end) end) - (sub1 end)))]) - (unless (>= start end) - ;; Find end of the current word: - (let ([ebox (box start)]) - (send edit find-wordbreak #f ebox 'line) - (let* ([p (unbox ebox)] - [wlen (- p start)]) - (cond - ;; If it's the first word on the line, or if it fits, - ;; no line break - [(or (zero? len) (< (+ len wlen) 72)) - (loop p (+ len wlen) end)] - ;; If the next thing is a space, then replace the space with a - ;; newline and prefix - [(char=? #\space (send edit get-character start)) - (send edit insert line-break start (add1 start)) - (loop (+ p slp-len) (+ wlen -1 slp-len) - (+ slp-len end))] - ;; Otherwise, insert a newline and prefix - [else - (send edit insert line-break start) - (loop (+ p 1 slp-len) (+ wlen slp-len) - (+ end 1 slp-len))])))))))))))) - (lambda () - (send edit end-edit-sequence) - (send edit set-wordbreak-map wbm))) - #t))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Uptime ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (build-uptime-field msg-count) - (string-append "X-Uptime: " - (how-long-ago (- (current-seconds) invoked-time)) - ", using " - (how-much-memory) - " bytes" - (if (number? msg-count) (format " (s: ~A)" msg-count) ""))) - - (define invoked-time (current-seconds)) - - (define (how-long-ago diff) - (let-values ([(seconds minutes hours days) (apply values (how-long-ago-list diff))]) - (cond - [days - (string-append - (build-ele days "day") - " and " - (build-ele hours "hour"))] - [hours - (string-append - (build-ele hours "hour") - " and " - (build-ele minutes "minute"))] - [minutes - (string-append - (build-ele minutes "minute") - " and " - (build-ele seconds "second"))] - [else - (build-ele seconds "second")]))) - - (define (build-ele count name) - (cond - [(or (not count) (zero? count)) - (format "0 ~as" name)] - [(= count 1) - (format "1 ~a" name)] - [else - (format "~a ~as" count name)])) - - (define (how-long-ago-list diff) - (let loop ([divs '(60 60 24)] - [diff diff]) - (cond - [(null? divs) - (if (zero? diff) - (list #f) - (list diff))] - [else (let ([div (car divs)]) - (if (<= diff 0) - (cons #f (loop (cdr divs) 0)) - (cons (modulo diff div) - (loop (cdr divs) - (quotient diff div)))))]))) - - (define (how-much-memory) - (let loop ([n (current-memory-use)]) - (cond - [(< n 1000) (format "~a" n)] - [else (format "~a,~a" - (loop (quotient n 1000)) - (pad-3 (modulo n 1000)))]))) - - (define (pad-3 n) - (cond - [(< n 10) (format "00~a" n)] - [(< n 100) (format "0~a" n)] - [else (format "~a" n)]))) diff --git a/collects/sirmail/sirmail.creator b/collects/sirmail/sirmail.creator deleted file mode 100644 index 4be7d98a20..0000000000 --- a/collects/sirmail/sirmail.creator +++ /dev/null @@ -1,2 +0,0 @@ -SrMl -(This code is registered with Apple.) diff --git a/collects/sirmail/sirmail.icns b/collects/sirmail/sirmail.icns deleted file mode 100644 index fa680e4a99..0000000000 Binary files a/collects/sirmail/sirmail.icns and /dev/null differ diff --git a/collects/sirmail/sirmail.ico b/collects/sirmail/sirmail.ico deleted file mode 100644 index ac07b9bd3f..0000000000 Binary files a/collects/sirmail/sirmail.ico and /dev/null differ diff --git a/collects/sirmail/sirmail.rkt b/collects/sirmail/sirmail.rkt deleted file mode 100644 index f957bb988c..0000000000 --- a/collects/sirmail/sirmail.rkt +++ /dev/null @@ -1,198 +0,0 @@ -;; SirMail: Simple Imap Reader for Mail -;; (with a mail composer, too) - -(module sirmail mzscheme - (require mzlib/unit - mzlib/class - mred/mred-sig - mred - framework - mzlib/list) - - (require "sirmails.rkt" - "pref.rkt" - "sirmailr.rkt") - - (require net/imap-sig - net/smtp-sig - net/head-sig - net/base64-sig - net/mime-sig - net/qp-sig - net/imap - net/smtp - net/head - net/base64 - net/mime - net/qp) - - (require mrlib/hierlist/hierlist-sig - mrlib/hierlist) - - ;; For testing purposes, cause GC accounting to be - ;; enabled: - (current-memory-use (current-custodian)) - - ;; Constants: - (define inbox-name "Inbox") - (define default-mailbox-options null) - - ;; ------------------------------------------------------------ - ;; Every window (reader or sender) is in it's own - ;; eventspace. Each should terminate by calling `exit'. - ;; We install an exit handler so that we only actually - ;; exit when the last window is closed. - - (define prim-exit (exit-handler)) - (define exit-eventspaces null) - (define exit-sema (make-semaphore 1)) - (define (exit-sirmail where) - (let ([evtsp (current-eventspace)]) - ;; Lock is because a separate process might be calling exit - ;; or starting up - (semaphore-wait exit-sema) - (set! exit-eventspaces (remq evtsp exit-eventspaces)) - (when (null? exit-eventspaces) - (prim-exit 0)) - (semaphore-post exit-sema))) - - ;; This function is called to start a new window: - (define (start-new-window thunk) - (define evtsp (make-eventspace)) - (parameterize ([current-eventspace evtsp]) - (semaphore-wait exit-sema) - (set! exit-eventspaces (cons evtsp exit-eventspaces)) - (semaphore-post exit-sema) - (queue-callback - (lambda () - (exit-handler (lambda (x) (exit-sirmail "a"))) - (let ([eeh (error-escape-handler)]) - (error-escape-handler - (lambda () - (unless (pair? (get-top-level-windows)) - ;; Didn't start up... - (exit-sirmail "b")) - (eeh)))) - (thunk) - (yield 'wait) - (exit-sirmail "c"))))) - - ;; Reader windows ----------------------------------------------------------- - - ;; This function uses `start-new-window' to open a reader window. - ;; A reader window is implemented by an instance of the sirmail@ unit. - (define open-mailbox - (case-lambda - [(mailbox-name) (open-mailbox mailbox-name default-mailbox-options)] - [(mailbox-name mailbox-options) - (start-new-window - (lambda () - (invoke-unit sirmail@ - (import sirmail:environment^ - mred^ - imap^ - smtp^ - head^ - base64^ - mime^ - qp^ - hierlist^))))])) - - ;; There's only one Folders window ---------------------------------------- - - (require "optionr.rkt" - "folderr.rkt") - - (define folders-window #f) - (define folders-lock (make-semaphore 1)) - - (define (with-folders-lock t) - (dynamic-wind - (lambda () (semaphore-wait folders-lock)) - t - (lambda () (semaphore-post folders-lock)))) - - (define (open-folders-window) - (with-folders-lock - (lambda () - (if folders-window - (send folders-window show #t) - (let ([shutdown-folders-window - (lambda () - (with-folders-lock - (lambda () - (set! folders-window #f) - (exit-sirmail "d"))))] - [mailbox-name inbox-name] - [mailbox-options default-mailbox-options]) - (start-new-window - (lambda () - (set! folders-window - (let () - (define-compound-unit/infer together@ - (import [env : sirmail:environment^] - [s : sirmail:shutdown-folder^] - [mred : mred^] - [imap : imap^] - [hierlist : hierlist^]) - (export) - (link option@ folder@)) - (invoke-unit together@ - (import - sirmail:environment^ - sirmail:shutdown-folder^ - mred^ - imap^ - hierlist^))))))))))) - - (define (get-active-folder) - (with-folders-lock - (lambda () - (and folders-window - (send folders-window get-mailbox-name))))) - - ;; Set Quit handler to try closing all windows -------------------- - - (define asking-for-quit? #f) - - (application-quit-handler - (lambda () - (if asking-for-quit? - (let ([l (get-top-level-windows)]) - (when (pair? l) - ;; Createa thread because it's probably a dialog... - (thread (lambda () (send (car l) show #t))))) - (dynamic-wind - (lambda () (set! asking-for-quit? #t)) - (lambda () - (when (= 1 (message-box/custom - "Confirm Quit" - "Really quit?" - "Quit" "Cancel" #f - #f '(default=1) - 2)) - (let ([l (begin - (semaphore-wait exit-sema) - (begin0 - exit-eventspaces - (semaphore-post exit-sema)))]) - (for-each - (lambda (evtsp) - (parameterize ([current-eventspace evtsp]) - (queue-callback - (lambda () - (let ([f (get-top-level-edit-target-window)]) - (when (and f (f . is-a? . frame%)) - (when (send f can-close?) - (send f on-close) - (send f show #f))))) - #f))) - l)))) - (lambda () (set! asking-for-quit? #f)))))) - - ;; We start by opening "Inbox" ---------------------------------------- - - (open-mailbox inbox-name) - - ;; Wait for an explicit exit - (yield (make-semaphore))) diff --git a/collects/sirmail/sirmailr.rkt b/collects/sirmail/sirmailr.rkt deleted file mode 100644 index a0058cf3ca..0000000000 --- a/collects/sirmail/sirmailr.rkt +++ /dev/null @@ -1,40 +0,0 @@ -(module sirmailr mzscheme - (require mzlib/unit - mred/mred-sig) - - (require "sirmails.rkt") - - (require net/imap-sig - net/smtp-sig - net/head-sig - net/base64-sig - net/mime-sig - net/qp-sig) - - (require mrlib/hierlist/hierlist-sig) - - (require "utilr.rkt" - "optionr.rkt" - "readr.rkt" - "sendr.rkt") - - ;; The sirmail@ unit implements a single reader window. See - ;; "sirmail.rkt" for its use: - (provide sirmail@) - (define-compound-unit/infer sirmail@ - (import (ENV : sirmail:environment^) - mred^ - imap^ - smtp^ - head^ - base64^ - mime^ - qp^ - hierlist^) - (export) - - (link util@ - option@ - read@ - [() send@ ENV]))) - diff --git a/collects/sirmail/sirmails.rkt b/collects/sirmail/sirmails.rkt deleted file mode 100644 index 12519bbf74..0000000000 --- a/collects/sirmail/sirmails.rkt +++ /dev/null @@ -1,96 +0,0 @@ - -(module sirmails mzscheme - (require mzlib/unit) - - (provide sirmail:exit^ - sirmail:environment^) - - (define-signature sirmail:exit^ - (exit-sirmail)) - - (define-signature sirmail:environment^ extends sirmail:exit^ - (mailbox-name - mailbox-options - open-folders-window - get-active-folder - - open-mailbox - start-new-window)) - - (provide sirmail:utils^) - (define-signature sirmail:utils^ - (crlf - split - splice - split-crlf - split-crlf/preserve-last - split-lf - crlf->lf - crlf->lf/preserve-last - lf->crlf - string-crlf->lf - string-lf->crlf - header->lines - enumerate - find - string->regexp - - show-error-message-box - - as-background - - make-fixed-width - - confirm-box - - get-pw-from-user - - generalize-encoding - parse-encoded - encode-for-header)) - - (provide sirmail:send^) - (define-signature sirmail:send^ - (new-mailer - (struct enclosure (name subheader data-thunk)))) - - (provide sirmail:options^) - (define-signature sirmail:options^ - (IMAP-SERVER - USERNAME - get-PASSWORD - set-PASSWORD - - LOCAL-DIR - - MAIL-FROM - ALIASES - DEFAULT-DOMAIN - SMTP-SERVER - SMTP-SERVERS - set-SMTP-SERVER! - SAVE-SENT - - ROOT-MAILBOX-FOR-LIST - ARCHIVE-MAILBOX - - MESSAGE-FIELDS-TO-SHOW - WARN-DOWNLOAD-SIZE - AUTO-FILE-TABLE - BIFF-DELAY - SELF-ADDRESSES - SORT - SHOW-URLS - - USE-EXTERNAL-COMPOSER? - - parse-server-name - parse-server-name+user+type)) - - (provide sirmail:read^) - (define-signature sirmail:read^ - (queue-directory)) - - (provide sirmail:shutdown-folder^) - (define-signature sirmail:shutdown-folder^ - (shutdown-folders-window))) diff --git a/collects/sirmail/spell.rkt b/collects/sirmail/spell.rkt deleted file mode 100644 index 4bc3082dd6..0000000000 --- a/collects/sirmail/spell.rkt +++ /dev/null @@ -1,229 +0,0 @@ -(module spell mzscheme - (require parser-tools/lex - (prefix : parser-tools/lex-sre) - mzlib/class - mzlib/string - mzlib/list - framework - mzlib/contract - mzlib/file - mzlib/process) - - (provide/contract [activate-spelling ((is-a?/c color:text<%>) . -> . void?)] - [word-count (-> number?)]) - - (define-lex-abbrevs - ;; Treat only letters with casing for spelling. This avoids - ;; Chinese, for example, where the concept of spelling doesn't - ;; really apply. - (cased-alphabetic (:or lower-case upper-case title-case)) - (extended-alphabetic (:or cased-alphabetic #\')) - (word (:: (:* extended-alphabetic) (:+ cased-alphabetic) (:* extended-alphabetic))) - (paren (char-set "()[]{}"))) - - (define get-word - (lexer - ((:+ whitespace) - (values lexeme 'white-space #f (position-offset start-pos) (position-offset end-pos))) - (paren - (values lexeme 'other (string->symbol lexeme) (position-offset start-pos) (position-offset end-pos))) - ((:+ (:~ (:or cased-alphabetic whitespace paren))) - (values lexeme 'other #f (position-offset start-pos) (position-offset end-pos))) - (word - (let ((ok (spelled-correctly? lexeme))) - (values lexeme (if ok 'other 'error) #f (position-offset start-pos) (position-offset end-pos)))) - ((eof) - (values lexeme 'eof #f #f #f)))) - - (define (activate-spelling t) - (send t start-colorer - (lambda (s) (format "framework:syntax-color:scheme:~a" s)) - get-word - `((|(| |)|) - (|[| |]|) - (|{| |}|)))) - - (define ask-chan (make-channel)) - (define word-count-chan (make-channel)) - - ;; spelled-correctly? : string -> boolean - (define (spelled-correctly? word) - (sync - (nack-guard-evt - (lambda (failed) - (let ([result (make-channel)]) - (channel-put ask-chan (list result failed word)) - result))))) - - (define (word-count) - (let ([c (make-channel)]) - (channel-put word-count-chan c) - (channel-get c))) - - (thread - (lambda () - (let ([bad-dict (make-hash-table 'equal)]) - (let loop ([computed? #f] - [dict #f]) - (sync - (handle-evt - ask-chan - (lambda (lst) - (let-values ([(answer-chan give-up-chan word) (apply values lst)]) - (let ([computed-dict (if computed? - dict - (fetch-dictionary))]) - (sync - (handle-evt - (channel-put-evt answer-chan (check-word computed-dict bad-dict word)) - (lambda (done) - (loop #t computed-dict))) - (handle-evt - give-up-chan - (lambda (done) - (loop #t computed-dict)))))))) - (handle-evt - word-count-chan - (lambda (ans) - (let ([count (if dict (hash-table-count dict) 0)]) - (thread (lambda () (channel-put ans count)))) - (loop computed? dict)))))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;; - ;;; The code below all runs in the above thread (only) - ;;; - - (define extra-words '("sirmail" "mred" "drscheme" "mzscheme" "plt")) - - (define (clean-up to-send) - ;; Drop characters that ispell or aspell may treat as word - ;; delimiters. We can to keep ' in a word, but double or leading - ;; '' counts as a delimiter, so end by replacing those. - (regexp-replace* #rx"^'" - (regexp-replace* #rx"''+" - (list->string - (map (lambda (b) - (if (and ((char->integer b) . <= . 127) - (or (char-alphabetic? b) - (char-numeric? b) - (eq? b #\'))) - b - #\x)) - (string->list to-send))) - "x") - "")) - - (define has-ispell? 'dontknow) - (define ispell-prog #f) - (define ispell-in #f) - (define ispell-out #f) - (define ispell-err #f) - (define (ispell-word word) - (when (eq? has-ispell? 'dontknow) - (let ([existing (or (find-executable-path (if (eq? (system-type) 'windows) - "ispell.exe" - "ispell") - #f) - (ormap (lambda (ispell) - (ormap (lambda (x) - (let ([x (build-path x ispell)]) - (and (file-exists? x) x))) - '("/sw/bin" - "/usr/bin" - "/bin" - "/usr/local/bin" - "/opt/local/bin"))) - '("ispell" "aspell")) - (find-executable-path (if (eq? (system-type) 'windows) - "aspell.exe" - "aspell") - #f))]) - (if (not existing) - (set! has-ispell? #f) - (begin - (set! has-ispell? #t) - (set! ispell-prog existing))))) - (cond - [has-ispell? - (unless (and ispell-in ispell-out ispell-err) - (let-values ([(out in pid err status) (apply values (process* ispell-prog "-a"))]) - (let ([version-line (read-line out)]) - (debug "< ~s\n" version-line)) - - (set! ispell-in in) - (set! ispell-out out) - (set! ispell-err err))) - - (let ([to-send (format "^~a\n" (clean-up word))]) - (debug "> ~s\n" to-send) - (display to-send ispell-in) - (flush-output ispell-in)) - - (let* ([answer-line (read-line ispell-out 'any)] - [_ (debug "< ~s\n" answer-line)] - [blank-line (read-line ispell-out 'any)] - [_ (debug "< ~s\n" blank-line)]) - (unless (equal? blank-line "") - (eprintf "expected blank line from ispell, got (word ~s):\n~a\nrestarting ispell\n\n" - word - blank-line) - (close-output-port ispell-in) - (close-input-port ispell-out) - (close-input-port ispell-err) - (set! ispell-in #f) - (set! ispell-out #f) - (set! ispell-err #f)) - (not (not (regexp-match #rx"^[\\+\\-\\*]" answer-line))))] - [else #f])) - - (define (debug str . args) - (when (getenv "PLTISPELL") - (apply printf str args))) - - ;; fetch-dictionary : -> (union #f hash-table) - ;; computes a dictionary, if any of the possible-file-names exist - ;; for now, just return an empty table. Always use ispell - (define (fetch-dictionary) (make-hash-table 'equal)) - - (define (fetch-dictionary/not-used) - (let* ([possible-file-names '("/usr/share/dict/words" - "/usr/share/dict/connectives" - "/usr/share/dict/propernames" - "/usr/dict/words")] - [good-file-names (filter file-exists? possible-file-names)]) - (and (not (null? good-file-names)) - (let ([d (make-hash-table 'equal)]) - (for-each (lambda (word) (hash-table-put! d word #t)) extra-words) - (for-each - (lambda (good-file-name) - (call-with-input-file* good-file-name - (lambda (i) - (let loop () - (let ((word (read-line i))) - (unless (eof-object? word) - (hash-table-put! d word #t) - (loop))))))) - good-file-names) - d)))) - - ;; check-word : hash-table hash-table string -> boolean - (define (check-word dict bad-dict word) - (let* ([word-ok (lambda (w) (hash-table-get dict w (lambda () #f)))] - [word-bad (lambda (w) (hash-table-get bad-dict w (lambda () #f)))] - [subword-ok (lambda (reg) - (let ([m (regexp-match reg word)]) - (and m - (word-ok (cadr m)))))]) - (if dict - (cond - [(word-ok word) #t] - [(word-ok (string-lowercase! (string-copy word))) #t] - [(word-bad word) #f] - [else - (let ([ispell-ok (ispell-word word)]) - (if ispell-ok - (hash-table-put! dict word #t) - (hash-table-put! bad-dict word #t)) - ispell-ok)]) - #t)))) diff --git a/collects/sirmail/stamp-mask.xbm b/collects/sirmail/stamp-mask.xbm deleted file mode 100644 index 0fc71419cb..0000000000 --- a/collects/sirmail/stamp-mask.xbm +++ /dev/null @@ -1,6 +0,0 @@ -#define mred_width 16 -#define mred_height 16 -static char mred_bits[] = { - 0x66,0x66,0xff,0xff,0xff,0xff,0xfe,0x7f,0xfe,0x7f,0xff,0xff,0xff,0xff,0xfe, - 0x7f,0xfe,0x7f,0xff,0xff,0xff,0xff,0xfe,0x7f,0xfe,0x7f,0xff,0xff,0xff,0xff, - 0x66,0x66}; diff --git a/collects/sirmail/stamp.bmp b/collects/sirmail/stamp.bmp deleted file mode 100644 index 7f69252ea4..0000000000 Binary files a/collects/sirmail/stamp.bmp and /dev/null differ diff --git a/collects/sirmail/utilr.rkt b/collects/sirmail/utilr.rkt deleted file mode 100644 index 0ff7bf25a3..0000000000 --- a/collects/sirmail/utilr.rkt +++ /dev/null @@ -1,266 +0,0 @@ -(module utilr mzscheme - (require mzlib/unit - mzlib/class - mred/mred-sig - net/qp-sig - net/base64-sig - (prefix unihead: net/unihead) - mzlib/etc - mzlib/string) - - (require "sirmails.rkt") - - (provide util@) - (define-unit util@ - (import mred^ - base64^ - qp^) - (export sirmail:utils^) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Utilities ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define crlf (string #\return #\linefeed)) - - (define (split s re) - (regexp-split re s)) - - (define (drop-last-if-empty orig-l) - (let loop ([l orig-l][accum null]) - (cond - [(null? l) orig-l] - [(null? (cdr l)) - (if (equal? #"" (car l)) - (reverse accum) - orig-l)] - [else (loop (cdr l) (cons (car l) accum))]))) - - (define (splice l sep) - (if (null? l) - #"" - (let ([p (open-output-bytes)]) - (let loop ([l l]) - (write-bytes (car l) p) - (unless (null? (cdr l)) - (display sep p) - (loop (cdr l)))) - (get-output-bytes p)))) - - (define (split-crlf/preserve-last s) - (split s #rx#"\r\n")) - - (define (split-crlf s) - (drop-last-if-empty (split-crlf/preserve-last s))) - - (define (split-lf s) - (drop-last-if-empty (split s #rx#"\n"))) - - (define (crlf->lf s) - (splice (split-crlf s) #"\n")) - - (define (crlf->lf/preserve-last s) - (splice (split-crlf/preserve-last s) #"\n")) - - (define (lf->crlf s) - (splice (split-lf s) #"\r\n")) - - (define (string-crlf->lf s) - (regexp-replace* #rx"\r\n" s "\n")) - - (define (string-lf->crlf s) - (regexp-replace* #rx"\n" s "\r\n")) - - (define (header->lines s) - (regexp-split #rx"\r\n" - ;; We don't want the extra empty line at the end: - (substring s 0 (- (string-length s) 2)))) - - (define (enumerate n) - (let loop ([n n][a null]) - (if (zero? n) - a - (loop (sub1 n) (cons n a))))) - - (define (find i l) - (let loop ([l l][pos 0]) - (if (null? l) - #f - (if (eq? (car l) i) - pos - (loop (cdr l) (add1 pos)))))) - - (define (string->regexp s) - (regexp-quote s)) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (show-error-message-box x main-frame) - (let ([sp (open-output-string)]) - ;; use error display handler in case - ;; errortrace (or something else) is - ;; installed - (parameterize ([current-output-port sp] - [current-error-port sp]) - ((error-display-handler) - (if (exn? x) - (exn-message x) - (format "uncaught exn: ~s" x)) - x)) - (message-box "Error" - (get-output-string sp) - main-frame - '(ok stop)))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (break-really-hard? set-d!) - (let* ([d (make-object dialog% "Danger")] - [p (make-object vertical-pane% d)] - [bp (make-object horizontal-pane% d)] - [result #f]) - (send bp stretchable-width #f) - (send bp stretchable-height #f) - (make-object message% "Breaking now is dangerous." p) - (make-object message% "It requires killing the window." p) - (make-object message% "" p) - (make-object message% "Are you sure you want to kill?" p) - (make-object button% "&Kill" bp (lambda (b e) - (set! result #t) - (send d show #f))) - (make-object button% "Cancel" bp (lambda (b e) (send d show #f))) - (set-d! d) - (send d show #t) - result)) - - ;; as-background: (bool window<%> braek-thunk ->) - ;; (break-ok-thunk break-not-ok-thunk -> X) - ;; (-> Y) -> X - ;; Runs a task in the background. - ;; The `enable' function is called with #f as the first argument - ;; near the start of the background task. The `break-thunk' can be - ;; called to interrupt the task. The `enable' function might - ;; not get called at all if the task is fast enough. - ;; The `go' function performs the task (in a thread created by - ;; as-background); it receives thunks that it can call to - ;; indicate when breaks are "safe". If the user tries to break - ;; at a non-safe point, the user is warned; if the user - ;; proceeds, things are killed and `exit' is called. If - ;; the user breaks at a safe point, a break signal is sent - ;; to the thread for the background task. - ;; The `pre-kill' thunk is called before things are killed - ;; for a non-"safe" break. - (define (as-background enable go pre-kill) - (let* ([v #f] - [exn #f] - [break-ok? #f] - [breaking-dialog #f] - [adjust-break (make-semaphore 1)] - [change-break-ok (lambda (ok?) - (lambda () - (semaphore-wait adjust-break) - (set! break-ok? ok?) - (let ([waiting? (and ok? breaking-dialog)]) - (when waiting? - (send breaking-dialog show #f) - (set! breaking-dialog #f)) - (semaphore-post adjust-break) - (when waiting? - (break-thread (current-thread))))))] - [s (make-semaphore 0)] - [t (thread (lambda () - (with-handlers ([void (lambda (x) - (set! exn x))]) - (set! v (call-with-values - (lambda () (go (change-break-ok #f) - (change-break-ok #t))) - list)) - ((change-break-ok #f))) - (when breaking-dialog - (send breaking-dialog show #f)) - (semaphore-post s)))]) - ;; If the operation is fast enough, no need to disable then yield then enable, - ;; which makes the screen flash and causes events to get dropped. 1/4 second - ;; seems "fast enough". - (unless (sync/timeout 0.25 s) - (let ([v (enable #f #f - (lambda () - (semaphore-wait adjust-break) - (if break-ok? - (break-thread t) - (let ([v (break-really-hard? (lambda (d) - (set! breaking-dialog d) - (semaphore-post adjust-break)))]) - (semaphore-wait adjust-break) - (set! breaking-dialog #f) - (semaphore-post adjust-break) - (when v - (pre-kill) - (kill-thread t) - (exit))))))]) - (yield s) - (enable #t v void))) - (if exn - (raise exn) - (apply values v)))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; the actual fixed width font is already set by - ;; the editor:standard-style-list-mixin - (define (make-fixed-width c e wrap? wrap-bm) - (let ([s (send (send e get-style-list) - find-named-style "Standard")]) - (send e set-tabs null 8 #f) - (let ([font (send s get-font)] - [dc (send c get-dc)] - [wbox (box 0)] - [hbox (box 0)]) - (send e get-view-size wbox hbox) - (let-values ([(w h) (send c get-size)] - [(1w 1h d a) (send dc get-text-extent "X" font)]) - (let ([80chars (+ (* 1w 80) - 2 ; +2 for caret - (if wrap-bm - (send wrap-bm get-width) - 0))]) - (when wrap? - (when wrap-bm - (send e set-autowrap-bitmap wrap-bm)) - (send e set-max-width 80chars)) - (send c min-width - (inexact->exact (round (+ 80chars (- w (unbox wbox))))))))))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define confirm-box - (opt-lambda (title message [parent #f] [style null]) - (if (= 1 (message-box/custom - title - message - "&Yes" - "&No" - #f - parent - (append (if (memq 'app style) null '(caution)) - '(default=1)) - 2)) - 'yes - 'no))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (get-pw-from-user username parent) - (get-text-from-user "Password" - (format "Password for ~a:" username) - parent - "" - '(password))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Decoding `from' names ;; - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define generalize-encoding unihead:generalize-encoding) - (define parse-encoded unihead:decode-for-header) - (define encode-for-header unihead:encode-for-header)))