Phase 3: add folder and header listing commands
ober
5367b885748929b63442ce97b4a8ebfd457fd10c
--- a/README.md +++ b/README.md @@ -12,12 +12,14 @@ first implementation path. ## Current Status -Phase 2 is in progress: +Phase 3 is in progress: - CLI entry point. - Environment config helper. - Bridge IMAP connectivity probe. - Structured IMAP response parser. +- Folder listing. +- Header-only message listing. - Smoke tests. - Makefile. - Project plan. --- a/protonmail/cli.ss +++ b/protonmail/cli.ss @@ -48,6 +48,65 @@ (define (cmd-version) (println version)) + (define (require-complete-config cfg) + (unless (config-complete? cfg) + (die 2 + "Bridge config is incomplete; set PROTON_BRIDGE_USER and PROTON_BRIDGE_PASSWORD"))) + + (define (run-network-command thunk) + (let ([result (guard (e [#t e]) + (thunk))]) + (if (condition? result) + (die 1 (string-append "error: " (condition-message result))) + result))) + + (define (cmd-folders) + (let ([cfg (config-from-environment)]) + (require-complete-config cfg) + (let ([folders (run-network-command + (lambda () (imap-list-folders cfg)))]) + (for-each println folders)))) + + (define (option-ref args name default) + (let loop ([xs args]) + (cond + [(null? xs) default] + [(string=? (car xs) name) + (if (pair? (cdr xs)) + (cadr xs) + (die 2 (string-append "missing value for " name)))] + [else (loop (cdr xs))]))) + + (define (option-number args name default) + (let* ([raw (option-ref args name #f)] + [n (and raw (string->number raw))]) + (cond + [(not raw) default] + [(and n (integer? n) (> n 0)) n] + [else (die 2 (string-append "invalid number for " name))]))) + + (define (print-summary-row s) + (println + (string-append + (assoc-value 'uid s "") + "\t" + (assoc-value 'date s "") + "\t" + (assoc-value 'from s "") + "\t" + (assoc-value 'subject s "")))) + + (define (cmd-list args) + (let* ([cfg (config-from-environment)] + [folder (option-ref args "--folder" "INBOX")] + [limit (option-number args "--limit" 20)]) + (require-complete-config cfg) + (let ([summaries (run-network-command + (lambda () + (imap-list-message-summaries cfg folder limit)))]) + (println "UID\tDate\tFrom\tSubject") + (for-each print-summary-row summaries)))) + (define (cmd-doctor) (let ([cfg (config-from-environment)]) (println "protonmail-read doctor") @@ -98,6 +157,8 @@ (print-help)] [(string=? (car args) "version") (cmd-version)] [(string=? (car args) "doctor") (cmd-doctor)] + [(string=? (car args) "folders") (cmd-folders)] + [(string=? (car args) "list") (cmd-list (cdr args))] [else (die 2 (string-append "unknown command: " (car args)))]))) --- a/protonmail/imap/client.ss +++ b/protonmail/imap/client.ss @@ -4,6 +4,8 @@ (library (protonmail imap client) (export imap-probe + imap-list-folders + imap-list-message-summaries imap-quote imap-final-ok?) @@ -17,7 +19,9 @@ partition make-date make-time) (protonmail config) - (protonmail imap transport)) + (protonmail imap parser) + (protonmail imap transport) + (protonmail mail header)) (define (make-client tr greeting) (vector tr greeting 0)) @@ -56,15 +60,34 @@ (get-output-string out))) (define (imap-command c command) + (map imap-entry-line (imap-command-entries c command))) + + (define (make-imap-entry line response literal tail) + (vector 'imap-entry line response literal tail)) + + (define (imap-entry-line e) (vector-ref e 1)) + (define (imap-entry-response e) (vector-ref e 2)) + (define (imap-entry-literal e) (vector-ref e 3)) + + (define (imap-command-entries c command) (let* ([tag (next-tag c)] [wire (string-append tag " " command)]) (transport-write-line (client-transport c) wire) - (let loop ([lines '()]) + (let loop ([entries '()]) (let ([line (transport-read-line (client-transport c))]) - (let ([new-lines (cons line lines)]) + (let* ([response (imap-parse-line line)] + [literal-len (imap-response-literal-length response)] + [literal (if literal-len + (transport-read-bytes (client-transport c) literal-len) + #f)] + [tail (if literal-len + (transport-read-line (client-transport c)) + #f)] + [entry (make-imap-entry line response literal tail)] + [new-entries (cons entry entries)]) (if (string-prefix? tag line) - (reverse new-lines) - (loop new-lines))))))) + (reverse new-entries) + (loop new-entries))))))) (define (imap-final-ok? lines) (let ([line (last lines)]) @@ -117,11 +140,28 @@ [else (loop (cdr xs) n)]))) (define (imap-probe cfg) + (imap-with-session cfg + (lambda (client) + (let ([list-lines (require-ok 'imap-list + (imap-command client "LIST \"\" \"*\""))]) + (list + (cons 'mode (transport-mode (client-transport client))) + (cons 'greeting (client-greeting client)) + (cons 'mailbox-count (count-list-lines list-lines))))))) + + (define (safe-close-client client) + (guard (e [#t #f]) + (transport-close (client-transport client)))) + + (define (safe-logout client) + (guard (e [#t #f]) + (imap-command client "LOGOUT"))) + + (define (imap-with-session cfg proc) (let ([client #f]) (guard (e [#t (when client - (guard (close-error [#t #f]) - (transport-close (client-transport client)))) + (safe-close-client client)) (raise e)]) (set! client (open-client cfg)) (require-ok 'imap-capability @@ -133,15 +173,93 @@ (imap-quote (config-user cfg)) " " (imap-quote (config-password cfg))))) - (let ([list-lines (require-ok 'imap-list - (imap-command client "LIST \"\" \"*\""))]) - (require-ok 'imap-logout - (imap-command client "LOGOUT")) - (let ([result (list - (cons 'mode (transport-mode (client-transport client))) - (cons 'greeting (client-greeting client)) - (cons 'mailbox-count (count-list-lines list-lines)))]) - (transport-close (client-transport client)) - result))))) + (let ([result (proc client)]) + (safe-logout client) + (safe-close-client client) + result)))) + + (define (nth xs n default) + (cond + [(null? xs) default] + [(= n 0) (car xs)] + [else (nth (cdr xs) (- n 1) default)])) + + (define (list-line->folder line) + (let ([r (imap-parse-line line)]) + (if (and (eq? 'untagged (imap-response-kind r)) + (string? (imap-response-name r)) + (string=? "LIST" (imap-response-name r))) + (nth (imap-response-data r) 2 #f) + #f))) + + (define (filter-map f xs) + (let loop ([rest xs] [acc '()]) + (cond + [(null? rest) (reverse acc)] + [else + (let ([v (f (car rest))]) + (loop (cdr rest) (if v (cons v acc) acc)))]))) + + (define (imap-list-folders cfg) + (imap-with-session cfg + (lambda (client) + (let ([lines (require-ok 'imap-list + (imap-command client "LIST \"\" \"*\""))]) + (filter-map list-line->folder lines))))) + + (define (search-lines->uids lines) + (let loop ([xs lines]) + (cond + [(null? xs) '()] + [else + (let ([r (imap-parse-line (car xs))]) + (if (and (eq? 'untagged (imap-response-kind r)) + (string? (imap-response-name r)) + (string=? "SEARCH" (imap-response-name r))) + (imap-response-data r) + (loop (cdr xs))))]))) + + (define (take n xs) + (cond + [(or (<= n 0) (null? xs)) '()] + [else (cons (car xs) (take (- n 1) (cdr xs)))])) + + (define (take-last n xs) + (reverse (take n (reverse xs)))) + + (define (fetch-header-by-uid client uid) + (let* ([command (string-append + "UID FETCH " + uid + " BODY.PEEK[HEADER.FIELDS (FROM SUBJECT DATE)]")] + [entries (imap-command-entries client command)] + [lines (map imap-entry-line entries)]) + (require-ok 'imap-fetch-header lines) + (let loop ([xs entries]) + (cond + [(null? xs) ""] + [(imap-entry-literal (car xs)) + (utf8->string (imap-entry-literal (car xs)))] + [else (loop (cdr xs))])))) + + (define (summary-for-uid client uid) + (let* ([header-text (fetch-header-by-uid client uid)] + [headers (mail-headers-parse header-text)]) + (list + (cons 'uid uid) + (cons 'date (mail-header-ref headers "Date" "")) + (cons 'from (mail-header-ref headers "From" "")) + (cons 'subject (mail-header-ref headers "Subject" ""))))) + + (define (imap-list-message-summaries cfg folder limit) + (imap-with-session cfg + (lambda (client) + (require-ok 'imap-select + (imap-command client + (string-append "SELECT " (imap-quote folder)))) + (let* ([search-lines (require-ok 'imap-search + (imap-command client "UID SEARCH ALL"))] + [uids (take-last limit (search-lines->uids search-lines))]) + (map (lambda (uid) (summary-for-uid client uid)) uids))))) ) ;; end library --- a/protonmail/imap/transport.ss +++ b/protonmail/imap/transport.ss @@ -6,6 +6,7 @@ transport-connect transport-mode transport-read-line + transport-read-bytes transport-write-line transport-close) @@ -76,4 +77,25 @@ (write-char (integer->char b) out) (loop)]))))) + (define (transport-read-bytes tr n) + (let ([out (make-bytevector n 0)]) + (let loop ([offset 0]) + (if (= offset n) + out + (let* ([remaining (- n offset)] + [buf (make-bytevector remaining 0)] + [count (cond + [(eq? (vector-ref tr 0) 'tls) + (ssl-read (vector-ref tr 1) buf remaining)] + [else + (tcp-read (vector-ref tr 1) buf remaining)])]) + (cond + [(= count 0) + (error 'transport-read-bytes "connection closed")] + [(< count 0) + (error 'transport-read-bytes "read failed")] + [else + (bytevector-copy! buf 0 out offset count) + (loop (+ offset count))])))))) + ) ;; end library new file mode 100644 --- /dev/null +++ b/protonmail/mail/header.ss @@ -0,0 +1,105 @@ +#!chezscheme +;;; (protonmail mail header) - minimal RFC 5322 header parser. + +(library (protonmail mail header) + (export + mail-headers-parse + mail-header-ref) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time)) + + (define (trim-cr line) + (let ([n (string-length line)]) + (if (and (> n 0) (char=? (string-ref line (- n 1)) #\return)) + (substring line 0 (- n 1)) + line))) + + (define (split-lines s) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length s)) + (reverse (cons (trim-cr (substring s start i)) acc))] + [(char=? (string-ref s i) #\newline) + (loop (+ i 1) (+ i 1) + (cons (trim-cr (substring s start i)) acc))] + [else + (loop (+ i 1) start acc)]))) + + (define (continuation-line? line) + (and (> (string-length line) 0) + (or (char=? (string-ref line 0) #\space) + (char=? (string-ref line 0) #\tab)))) + + (define (string-trim s) + (let* ([n (string-length s)] + [start (let loop ([i 0]) + (if (and (< i n) + (or (char=? (string-ref s i) #\space) + (char=? (string-ref s i) #\tab))) + (loop (+ i 1)) + i))] + [end (let loop ([i n]) + (if (and (> i start) + (or (char=? (string-ref s (- i 1)) #\space) + (char=? (string-ref s (- i 1)) #\tab))) + (loop (- i 1)) + i))]) + (substring s start end))) + + (define (unfold-lines lines) + (let loop ([xs lines] [current #f] [acc '()]) + (cond + [(null? xs) + (reverse (if current (cons current acc) acc))] + [(string=? (car xs) "") + (reverse (if current (cons current acc) acc))] + [(continuation-line? (car xs)) + (loop (cdr xs) + (if current + (string-append current " " (string-trim (car xs))) + (string-trim (car xs))) + acc)] + [else + (loop (cdr xs) + (car xs) + (if current (cons current acc) acc))]))) + + (define (colon-index s) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #f] + [(char=? (string-ref s i) #\:) i] + [else (loop (+ i 1))]))) + + (define (parse-header-line line) + (let ([idx (colon-index line)]) + (if idx + (cons (substring line 0 idx) + (string-trim (substring line (+ idx 1) (string-length line)))) + #f))) + + (define (mail-headers-parse s) + (let loop ([xs (unfold-lines (split-lines s))] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [else + (let ([h (parse-header-line (car xs))]) + (loop (cdr xs) (if h (cons h acc) acc)))]))) + + (define (mail-header-ref headers name . default) + (let ([fallback (if (null? default) "" (car default))]) + (let loop ([xs headers]) + (cond + [(null? xs) fallback] + [(string-ci=? (caar xs) name) (cdar xs)] + [else (loop (cdr xs))])))) + + ) ;; end library --- a/test/test-all.ss +++ b/test/test-all.ss @@ -30,6 +30,7 @@ (import (protonmail config)) (import (protonmail imap client)) (import (protonmail imap parser)) +(import (protonmail mail header)) (define failures 0) @@ -143,6 +144,15 @@ (check "parser decodes escaped quoted strings" (equal? '(() "/" "a\\b\"c") (imap-response-data r)))) +(let ([headers (mail-headers-parse + "From: A <a@example.com>\r\nSubject: Hello\r\n Date folded\r\n\r\nBody")]) + (check "mail header parser reads From" + (string=? "A <a@example.com>" (mail-header-ref headers "From"))) + (check "mail header parser unfolds continuation" + (string=? "Hello Date folded" (mail-header-ref headers "Subject"))) + (check "mail header parser supports default" + (string=? "" (mail-header-ref headers "Missing")))) + (if (= failures 0) (begin (fprintf (current-error-port) "~%All tests passed.~%")