remove `sirmail'
SirMail is moving to its own repo: https://github.com/mflatt/sirmail Install with raco pkg install sirmail
This commit is contained in:
Matthew Flatt
parent
deb3c87c32
commit
3e505af4f9
|
|
@ -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 *)
|
||||
|
|
|
|||
|
|
@ -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 ":<portno>" suffix on the host name to connect to
|
||||
port <portno>.
|
||||
|
||||
- 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: [<type>:][<user>@]<host>[:<portno>] where <type> 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.
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 1.0 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 1009 B |
Binary file not shown.
|
Before Width: | Height: | Size: 985 B |
Binary file not shown.
|
Before Width: | Height: | Size: 987 B |
Binary file not shown.
|
Before Width: | Height: | Size: 985 B |
Binary file not shown.
|
Before Width: | Height: | Size: 1009 B |
Binary file not shown.
|
Before Width: | Height: | Size: 1.0 KiB |
|
|
@ -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};
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 246 B |
|
|
@ -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))
|
||||
|
|
@ -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")))
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
(module main scheme/base
|
||||
(require "sirmail.rkt"))
|
||||
|
|
@ -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?))))
|
||||
|
|
@ -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};
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 246 B |
|
|
@ -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 <sirmail@racket-lang.org>" 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?))))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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)
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,2 +0,0 @@
|
|||
SrMl
|
||||
(This code is registered with Apple.)
|
||||
Binary file not shown.
Binary file not shown.
|
Before Width: | Height: | Size: 1.4 KiB |
|
|
@ -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)))
|
||||
|
|
@ -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])))
|
||||
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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};
|
||||
Binary file not shown.
|
Before Width: | Height: | Size: 822 B |
|
|
@ -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)))
|
||||
Loading…
Reference in New Issue
Block a user