553 lines
19 KiB
Racket
553 lines
19 KiB
Racket
(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?))))
|
|
|