Phase 4: add raw fetch and EML export
ober
712bebc52511031eb03f957414996074047ac3c3
--- a/README.md +++ b/README.md @@ -12,7 +12,7 @@ first implementation path. ## Current Status -Phase 3 is in progress: +Phase 4 is in progress: - CLI entry point. - Environment config helper. @@ -20,6 +20,8 @@ Phase 3 is in progress: - Structured IMAP response parser. - Folder listing. - Header-only message listing. +- Raw message fetch. +- `.eml` export. - Smoke tests. - Makefile. - Project plan. --- a/protonmail/cli.ss +++ b/protonmail/cli.ss @@ -85,6 +85,12 @@ [(and n (integer? n) (> n 0)) n] [else (die 2 (string-append "invalid number for " name))]))) + (define (required-option args name) + (let ([value (option-ref args name #f)]) + (if value + value + (die 2 (string-append "missing required option " name))))) + (define (print-summary-row s) (println (string-append @@ -107,6 +113,34 @@ (println "UID\tDate\tFrom\tSubject") (for-each print-summary-row summaries)))) + (define (write-stdout-bytes bv) + (let ([p (standard-output-port (buffer-mode block))]) + (put-bytevector p bv) + (flush-output-port p))) + + (define (write-file-bytes path bv) + (call-with-port (open-file-output-port path (file-options no-fail)) + (lambda (p) + (put-bytevector p bv)))) + + (define (fetch-raw-from-args args) + (let* ([cfg (config-from-environment)] + [folder (option-ref args "--folder" "INBOX")] + [uid (required-option args "--uid")]) + (require-complete-config cfg) + (run-network-command + (lambda () + (imap-fetch-raw-message cfg folder uid))))) + + (define (cmd-raw args) + (write-stdout-bytes (fetch-raw-from-args args))) + + (define (cmd-export-eml args) + (let* ([output (required-option args "--output")] + [message (fetch-raw-from-args args)]) + (write-file-bytes output message) + (println (string-append "wrote " output)))) + (define (cmd-doctor) (let ([cfg (config-from-environment)]) (println "protonmail-read doctor") @@ -159,6 +193,8 @@ [(string=? (car args) "doctor") (cmd-doctor)] [(string=? (car args) "folders") (cmd-folders)] [(string=? (car args) "list") (cmd-list (cdr args))] + [(string=? (car args) "raw") (cmd-raw (cdr args))] + [(string=? (car args) "export-eml") (cmd-export-eml (cdr args))] [else (die 2 (string-append "unknown command: " (car args)))]))) --- a/protonmail/imap/client.ss +++ b/protonmail/imap/client.ss @@ -6,6 +6,7 @@ imap-probe imap-list-folders imap-list-message-summaries + imap-fetch-raw-message imap-quote imap-final-ok?) @@ -227,21 +228,27 @@ (define (take-last n xs) (reverse (take n (reverse xs)))) - (define (fetch-header-by-uid client uid) + (define (fetch-literal-by-uid client uid fetch-item) (let* ([command (string-append "UID FETCH " uid - " BODY.PEEK[HEADER.FIELDS (FROM SUBJECT DATE)]")] + " " + fetch-item)] [entries (imap-command-entries client command)] [lines (map imap-entry-line entries)]) - (require-ok 'imap-fetch-header lines) + (require-ok 'imap-fetch lines) (let loop ([xs entries]) (cond - [(null? xs) ""] + [(null? xs) (error 'imap-fetch "response did not include a literal")] [(imap-entry-literal (car xs)) - (utf8->string (imap-entry-literal (car xs)))] + (imap-entry-literal (car xs))] [else (loop (cdr xs))])))) + (define (fetch-header-by-uid client uid) + (utf8->string + (fetch-literal-by-uid client uid + "BODY.PEEK[HEADER.FIELDS (FROM SUBJECT DATE)]"))) + (define (summary-for-uid client uid) (let* ([header-text (fetch-header-by-uid client uid)] [headers (mail-headers-parse header-text)]) @@ -262,4 +269,12 @@ [uids (take-last limit (search-lines->uids search-lines))]) (map (lambda (uid) (summary-for-uid client uid)) uids))))) + (define (imap-fetch-raw-message cfg folder uid) + (imap-with-session cfg + (lambda (client) + (require-ok 'imap-select + (imap-command client + (string-append "SELECT " (imap-quote folder)))) + (fetch-literal-by-uid client uid "BODY.PEEK[]")))) + ) ;; end library