1027 lines
46 KiB
Racket
1027 lines
46 KiB
Racket
|
|
;; 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.ss"
|
|
"pref.ss"
|
|
"spell.ss")
|
|
|
|
(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 <full>-<address> 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 <full>-<address> 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.ss 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)])))
|