380 lines
11 KiB
Scheme
380 lines
11 KiB
Scheme
|
|
(unit/sig mzlib:imap^
|
|
(import)
|
|
|
|
(define debug-via-stdio? #f)
|
|
|
|
(define eol (if debug-via-stdio?
|
|
'linefeed
|
|
'return-linefeed))
|
|
|
|
(define crlf (string #\return #\linefeed))
|
|
|
|
(define (tag-eq? a b)
|
|
(or (eq? a b)
|
|
(and (symbol? a)
|
|
(symbol? b)
|
|
(string-ci=? (symbol->string a)
|
|
(symbol->string b)))))
|
|
|
|
(define field-names
|
|
(list
|
|
(list 'uid (string->symbol "UID"))
|
|
(list 'header (string->symbol "RFC822.HEADER"))
|
|
(list 'body (string->symbol "RFC822.TEXT"))
|
|
(list 'size (string->symbol "RFC822.SIZE"))
|
|
(list 'flags (string->symbol "FLAGS"))))
|
|
|
|
(define flag-names
|
|
(list
|
|
(list 'seen (string->symbol "\\Seen"))
|
|
(list 'answered (string->symbol "\\Answered"))
|
|
(list 'flagged (string->symbol "\\Flagged"))
|
|
(list 'deleted (string->symbol "\\Deleted"))
|
|
(list 'draft (string->symbol "\\Draft"))
|
|
(list 'recent (string->symbol "\\Recent"))
|
|
|
|
(list 'noinferiors (string->symbol "\\Noinferiors"))
|
|
(list 'noselect (string->symbol "\\Noselect"))
|
|
(list 'marked (string->symbol "\\Marked"))
|
|
(list 'unmarked (string->symbol "\\Unmarked"))))
|
|
|
|
(define (imap-flag->symbol f)
|
|
(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a)))
|
|
flag-names)
|
|
f))
|
|
|
|
(define (symbol->imap-flag s)
|
|
(let ([a (assoc s flag-names)])
|
|
(if a
|
|
(cadr a)
|
|
s)))
|
|
|
|
(define (log-warning . args)
|
|
; (apply printf args)
|
|
(void))
|
|
(define log log-warning)
|
|
|
|
(define make-msg-id
|
|
(let ([id 0])
|
|
(lambda ()
|
|
(begin0
|
|
(format "a~a " id)
|
|
(set! id (add1 id))))))
|
|
|
|
(define (starts-with? l n)
|
|
(and (>= (string-length l) (string-length n))
|
|
(string=? n (substring l 0 (string-length n)))))
|
|
|
|
(define (skip s n)
|
|
(substring s
|
|
(if (number? n) n (string-length n))
|
|
(string-length s)))
|
|
|
|
(define (splice l sep)
|
|
(if (null? l)
|
|
""
|
|
(format "~a~a"
|
|
(car l)
|
|
(apply
|
|
string-append
|
|
(map
|
|
(lambda (n) (format "~a~a" sep n))
|
|
(cdr l))))))
|
|
|
|
(define (imap-read s r)
|
|
(let loop ([s s]
|
|
[r r]
|
|
[accum null]
|
|
[eol-k (lambda (accum) (reverse! accum))]
|
|
[eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))])
|
|
(cond
|
|
[(string=? "" s) (eol-k accum)]
|
|
[(char-whitespace? (string-ref s 0))
|
|
(loop (skip s 1) r accum eol-k eop-k)]
|
|
[else
|
|
(case (string-ref s 0)
|
|
[(#\") (let ([m (regexp-match "\"([^\"]*)\"(.*)" s)])
|
|
(if m
|
|
(loop (caddr m) r (cons (cadr m) accum) eol-k eop-k)
|
|
(error 'imap-read "didn't find end of quoted string in: ~a" s)))]
|
|
[(#\)) (eop-k (skip s 1) accum)]
|
|
[(#\() (letrec ([next-line
|
|
(lambda (accum)
|
|
(loop (read-line r eol) r
|
|
accum
|
|
next-line
|
|
finish-parens))]
|
|
[finish-parens
|
|
(lambda (s laccum)
|
|
(loop s r
|
|
(cons (reverse! laccum) accum)
|
|
eol-k eop-k))])
|
|
(loop (skip s 1) r null next-line finish-parens))]
|
|
[(#\{) (let ([m (regexp-match "{([0-9]+)}(.*)" s)])
|
|
(cond
|
|
[(not m) (error 'imap-read "couldn't read {} number: ~a" s)]
|
|
[(not (string=? (caddr m) "")) (error 'imap-read "{} not at end-of-line: ~a" s)]
|
|
[else (loop "" r
|
|
(cons (read-string (string->number (cadr m)) r)
|
|
accum)
|
|
eol-k eop-k)]))]
|
|
[else (let ([m (regexp-match "([^ (){}]+)(.*)" s)])
|
|
(if m
|
|
(loop (caddr m) r
|
|
(cons (let ([v (cadr m)])
|
|
(if (regexp-match "^[0-9]*$" v)
|
|
(string->number v)
|
|
(string->symbol (cadr m))))
|
|
accum)
|
|
eol-k eop-k)
|
|
(error 'imap-read "failure reading atom: ~a" s)))])])))
|
|
|
|
(define (imap-send r w cmd info-handler)
|
|
(let ([id (make-msg-id)])
|
|
(log "sending ~a~a~n" id cmd)
|
|
(fprintf w "~a~a~a" id cmd crlf)
|
|
(let loop ()
|
|
(let ([l (read-line r eol)])
|
|
; (log "raw-reply: ~s~n" l)
|
|
(cond
|
|
[(starts-with? l id)
|
|
(let ([reply (imap-read (skip l id) r)])
|
|
(log "response: ~a~n" reply)
|
|
reply)]
|
|
[(starts-with? l "* ")
|
|
(let ([info (imap-read (skip l 2) r)])
|
|
(log "info: ~s~n" info)
|
|
(info-handler info))
|
|
(loop)]
|
|
[(starts-with? l "+ ")
|
|
(error 'imap-send "unexpected continuation request: ~a" l)]
|
|
[else
|
|
(log-warning "warning: unexpected response for ~a: ~a" id l)
|
|
(loop)])))))
|
|
|
|
(define (str->arg s)
|
|
(if (or (regexp-match " " s)
|
|
(string=? s ""))
|
|
(format "\"~a\"" s)
|
|
s))
|
|
|
|
(define (check-ok reply)
|
|
(unless (and (pair? reply)
|
|
(tag-eq? (car reply) 'OK))
|
|
(error 'check-ok "server error: ~s" reply)))
|
|
|
|
(define-struct imap-connection (r w))
|
|
|
|
(define imap-port-number (make-parameter 143))
|
|
|
|
(define (imap-connect server username password inbox)
|
|
; => imap count-k recent-k
|
|
(let-values ([(r w) (if debug-via-stdio?
|
|
(begin
|
|
(printf "stdin == ~a~n" server)
|
|
(values (current-input-port) (current-output-port)))
|
|
(tcp-connect server (imap-port-number)))])
|
|
(with-handlers ([void
|
|
(lambda (x)
|
|
(close-input-port r)
|
|
(close-output-port w)
|
|
(raise x))])
|
|
|
|
(check-ok (imap-send r w "NOOP" void))
|
|
(let ([reply (imap-send r w (format "LOGIN ~a ~a"
|
|
(str->arg username)
|
|
(str->arg password))
|
|
void)])
|
|
(if (and (pair? reply) (tag-eq? 'NO (car reply)))
|
|
(error "username or password rejected by server")
|
|
(check-ok reply)))
|
|
|
|
(let ([imap (make-imap-connection r w)])
|
|
(let-values ([(init-count init-recent)
|
|
(imap-reselect imap inbox)])
|
|
(values imap
|
|
init-count
|
|
init-recent))))))
|
|
|
|
(define (imap-reselect imap inbox)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(let ([init-count 0]
|
|
[init-recent 0])
|
|
(check-ok (imap-send r w (format "SELECT ~a" (str->arg inbox))
|
|
(lambda (i)
|
|
(when (and (list? i) (= 2 (length i)))
|
|
(cond
|
|
[(tag-eq? (cadr i) 'EXISTS)
|
|
(set! init-count (car i))]
|
|
[(tag-eq? (cadr i) 'RECENT)
|
|
(set! init-recent (car i))])))))
|
|
(values init-count init-recent))))
|
|
|
|
(define (imap-status imap inbox flags)
|
|
(unless (and (list? flags)
|
|
(andmap (lambda (s)
|
|
(memq s '(messages recent uidnext uidvalidity unseen)))
|
|
flags))
|
|
(raise-type-error 'imap-status "list of status flag symbols" flags))
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(let ([results null])
|
|
(check-ok (imap-send r w (format "STATUS ~a ~a" (str->arg inbox) flags)
|
|
(lambda (i)
|
|
(when (and (list? i) (= 3 (length i))
|
|
(tag-eq? (car i) 'STATUS))
|
|
(set! results (caddr i))))))
|
|
(map
|
|
(lambda (f)
|
|
(let loop ([l results])
|
|
(cond
|
|
[(or (null? l) (null? (cdr l))) #f]
|
|
[(tag-eq? f (car l)) (cadr l)]
|
|
[else (loop (cdr l))])))
|
|
flags))))
|
|
|
|
(define (imap-disconnect imap)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(check-ok (imap-send r w "LOGOUT" void))
|
|
(close-input-port r)
|
|
(close-output-port w)))
|
|
|
|
(define (imap-force-disconnect imap)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(close-input-port r)
|
|
(close-output-port w)))
|
|
|
|
(define (imap-get-messages imap msgs field-list)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(when (or (not (list? msgs))
|
|
(not (andmap integer? msgs)))
|
|
(raise-type-error 'imap-get-messages "non-empty message list" msgs))
|
|
(when (or (null? field-list)
|
|
(not (list? field-list))
|
|
(not (andmap (lambda (f) (assoc f field-names)) field-list)))
|
|
(raise-type-error 'imap-get-messages "non-empty field list" field-list))
|
|
|
|
(if (null? msgs)
|
|
null
|
|
(let ([results null])
|
|
(imap-send r w (format "FETCH ~a (~a)"
|
|
(splice msgs ",")
|
|
(splice (map (lambda (f) (cadr (assoc f field-names))) field-list) " "))
|
|
(lambda (i)
|
|
(when (and (list? i) (<= 2 (length i))
|
|
(tag-eq? (cadr i) 'FETCH))
|
|
(set! results (cons i results)))))
|
|
(map
|
|
(lambda (msg)
|
|
(let ([m (assoc msg results)])
|
|
(unless m
|
|
(error 'imap-get-messages "no result for message ~a" msg))
|
|
(let ([d (caddr m)])
|
|
(map
|
|
(lambda (f)
|
|
(let ([fld (cadr (assoc f field-names))])
|
|
(let loop ([d d])
|
|
(cond
|
|
[(null? d) #f]
|
|
[(null? (cdr d)) #f]
|
|
[(tag-eq? (car d) fld) (cadr d)]
|
|
[else (loop (cddr d))]))))
|
|
field-list))))
|
|
msgs)))))
|
|
|
|
(define (imap-store imap mode msgs flags)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(check-ok
|
|
(imap-send r w
|
|
(format "STORE ~a ~a ~a"
|
|
(splice msgs ",")
|
|
(case mode
|
|
[(+) "+FLAGS.SILENT"]
|
|
[(-) "-FLAGS.SILENT"]
|
|
[(!) "FLAGS.SILENT"]
|
|
[else (raise-type-error
|
|
'imap-store
|
|
"mode: '!, '+, or '-")])
|
|
flags)
|
|
void))))
|
|
|
|
(define (imap-copy imap msgs dest-mailbox)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(check-ok
|
|
(imap-send r w
|
|
(format "COPY ~a ~a"
|
|
(splice msgs ",")
|
|
(str->arg dest-mailbox))
|
|
void))))
|
|
|
|
(define (imap-expunge imap)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(check-ok (imap-send r w "EXPUNGE" void))))
|
|
|
|
|
|
(define (imap-mailbox-exists? imap mailbox)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)]
|
|
[exists? #f])
|
|
(check-ok (imap-send r w
|
|
(format "LIST \"\" ~s" (str->arg mailbox))
|
|
(lambda (i)
|
|
(when (and (pair? i)
|
|
(tag-eq? (car i) 'LIST))
|
|
(set! exists? #t)))))
|
|
exists?))
|
|
|
|
(define (imap-create-mailbox imap mailbox)
|
|
(let ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)])
|
|
(check-ok
|
|
(imap-send r w
|
|
(format "CREATE ~a" (str->arg mailbox))
|
|
void))))
|
|
|
|
(define (imap-get-hierarchy-delimiter imap)
|
|
(let* ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)]
|
|
[result #f])
|
|
(check-ok
|
|
(imap-send r w "LIST \"\" \"\""
|
|
(lambda (x)
|
|
(set! result (caddr x)))))
|
|
result))
|
|
|
|
(define imap-list-child-mailboxes
|
|
(case-lambda
|
|
[(imap mailbox)
|
|
(imap-list-child-mailboxes imap mailbox (imap-get-hierarchy-delimiter imap))]
|
|
[(imap mailbox delimiter)
|
|
(let* ([r (imap-connection-r imap)]
|
|
[w (imap-connection-w imap)]
|
|
[mailbox-name (and mailbox (format "~a~a" mailbox delimiter))]
|
|
[pattern (if mailbox
|
|
(format "~a%" mailbox-name)
|
|
"%")]
|
|
[sub-folders null])
|
|
(check-ok
|
|
(imap-send r w (format "LIST \"\" ~a" (str->arg pattern))
|
|
(lambda (x)
|
|
(let ([flags (cadr x)]
|
|
[name (let ([s (cadddr x)])
|
|
(if (symbol? s)
|
|
(symbol->string s)
|
|
s))])
|
|
(unless (and mailbox-name
|
|
(string=? name mailbox-name))
|
|
(set! sub-folders
|
|
(cons
|
|
(list flags name)
|
|
sub-folders)))))))
|
|
(reverse sub-folders))])))
|