Phase 5: render decoded messages via jerboa-mail
ober
9a656e103edb649dd825c56644a3a6885fe1e36d
--- a/Makefile +++ b/Makefile @@ -1,7 +1,8 @@ JERBOA_HOME ?= $(realpath $(CURDIR)/../jerboa) SCHEME ?= $(JERBOA_HOME)/.chez/bin/scheme JERBOA_SSL_DIR ?= $(realpath $(CURDIR)/../jerboa-ssl) -LIBDIRS := $(CURDIR):$(JERBOA_SSL_DIR)/lib:$(JERBOA_HOME)/lib +JERBOA_MAIL_DIR ?= $(realpath $(CURDIR)/../jerboa-mail) +LIBDIRS := $(CURDIR):$(JERBOA_MAIL_DIR):$(JERBOA_SSL_DIR)/lib:$(JERBOA_HOME)/lib .PHONY: help run test doctor clean .DEFAULT_GOAL := help @@ -20,6 +21,7 @@ help: @echo " JERBOA_HOME = $(JERBOA_HOME)" @echo " SCHEME = $(SCHEME)" @echo " JERBOA_SSL_DIR = $(JERBOA_SSL_DIR)" + @echo " JERBOA_MAIL_DIR = $(JERBOA_MAIL_DIR)" run: JERBOA_HOME=$(JERBOA_HOME) JERBOA_SSL_LIB=$(JERBOA_SSL_DIR) \ --- a/README.md +++ b/README.md @@ -12,7 +12,7 @@ first implementation path. ## Current Status -Phase 4 is in progress: +Phase 5 is in progress: - CLI entry point. - Environment config helper. @@ -22,6 +22,7 @@ Phase 4 is in progress: - Header-only message listing. - Raw message fetch. - `.eml` export. +- Decoded `show` output through `jerboa-mail`. - Smoke tests. - Makefile. - Project plan. @@ -49,6 +50,12 @@ The Bridge transport uses `../jerboa-ssl` by default. Override with: make JERBOA_SSL_DIR=/path/to/jerboa-ssl test ``` +Email parsing uses `../jerboa-mail` by default. Override with: + +```sh +make JERBOA_MAIL_DIR=/path/to/jerboa-mail test +``` + ## Bridge Configuration Later phases will read Bridge IMAP settings from environment variables: --- a/bin/protonmail-read +++ b/bin/protonmail-read @@ -4,9 +4,10 @@ set -eu repo_dir=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd) jerboa_home=${JERBOA_HOME:-"$repo_dir/../jerboa"} jerboa_ssl_dir=${JERBOA_SSL_DIR:-"$repo_dir/../jerboa-ssl"} +jerboa_mail_dir=${JERBOA_MAIL_DIR:-"$repo_dir/../jerboa-mail"} scheme=${SCHEME:-"$jerboa_home/.chez/bin/scheme"} export JERBOA_SSL_LIB=${JERBOA_SSL_LIB:-"$jerboa_ssl_dir"} -exec "$scheme" -q --libdirs "$repo_dir:$jerboa_ssl_dir/lib:$jerboa_home/lib" \ +exec "$scheme" -q --libdirs "$repo_dir:$jerboa_mail_dir:$jerboa_ssl_dir/lib:$jerboa_home/lib" \ --script "$repo_dir/main.ss" -- "$@" --- a/protonmail/cli.ss +++ b/protonmail/cli.ss @@ -14,7 +14,10 @@ partition make-date make-time) (protonmail config) - (protonmail imap client)) + (protonmail imap client) + (jerboa-mail encoding) + (jerboa-mail header) + (jerboa-mail mime)) (define version "0.0.0-phase0") @@ -141,6 +144,27 @@ (write-file-bytes output message) (println (string-append "wrote " output)))) + (define (decoded-header headers name) + (mail-decode-encoded-words (mail-header-ref headers name ""))) + + (define (print-header-if-present label value) + (when (> (string-length value) 0) + (println (string-append label ": " value)))) + + (define (cmd-show args) + (let* ([raw (fetch-raw-from-args args)] + [raw-text (utf8->string raw)] + [msg (mail-parse-message raw-text)] + [headers (mail-message-headers msg)]) + (print-header-if-present "From" (decoded-header headers "From")) + (print-header-if-present "To" (decoded-header headers "To")) + (print-header-if-present "Cc" (decoded-header headers "Cc")) + (print-header-if-present "Date" (mail-header-ref headers "Date" "")) + (print-header-if-present "Subject" (decoded-header headers "Subject")) + (newline) + (display (mail-best-text-body msg)) + (newline))) + (define (cmd-doctor) (let ([cfg (config-from-environment)]) (println "protonmail-read doctor") @@ -193,6 +217,7 @@ [(string=? (car args) "doctor") (cmd-doctor)] [(string=? (car args) "folders") (cmd-folders)] [(string=? (car args) "list") (cmd-list (cdr args))] + [(string=? (car args) "show") (cmd-show (cdr args))] [(string=? (car args) "raw") (cmd-raw (cdr args))] [(string=? (car args) "export-eml") (cmd-export-eml (cdr args))] [else --- a/protonmail/imap/client.ss +++ b/protonmail/imap/client.ss @@ -22,7 +22,7 @@ (protonmail config) (protonmail imap parser) (protonmail imap transport) - (protonmail mail header)) + (jerboa-mail header)) (define (make-client tr greeting) (vector tr greeting 0)) deleted file mode 100644 --- a/protonmail/mail/header.ss +++ /dev/null @@ -1,105 +0,0 @@ -#!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,7 +30,9 @@ (import (protonmail config)) (import (protonmail imap client)) (import (protonmail imap parser)) -(import (protonmail mail header)) +(import (jerboa-mail encoding)) +(import (jerboa-mail header)) +(import (jerboa-mail mime)) (define failures 0) @@ -153,6 +155,14 @@ (check "mail header parser supports default" (string=? "" (mail-header-ref headers "Missing")))) +(check "mail encoded subject decodes" + (string=? "Hello" (mail-decode-encoded-words "=?UTF-8?B?SGVsbG8=?="))) + +(let* ([raw "Subject: Hi\r\nContent-Type: text/plain\r\n\r\nBody text"] + [msg (mail-parse-message raw)]) + (check "mail parser selects plain body" + (string=? "Body text" (mail-best-text-body msg)))) + (if (= failures 0) (begin (fprintf (current-error-port) "~%All tests passed.~%")