Initial reusable mail parsing library
ober
a80b7742876ef458b4d15341dc821918b119d29b
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +.DS_Store +*.so +*.dylib +*.o +*.wpo +*.boot +*.log +tmp/ new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,24 @@ +JERBOA_HOME ?= $(realpath $(CURDIR)/../jerboa) +SCHEME ?= $(JERBOA_HOME)/.chez/bin/scheme +LIBDIRS := $(CURDIR):$(JERBOA_HOME)/lib + +.PHONY: help test clean +.DEFAULT_GOAL := help + +help: + @echo "jerboa-mail" + @echo "" + @echo "Development:" + @echo " make test Run smoke tests" + @echo " make clean Remove local generated files" + @echo "" + @echo "Environment:" + @echo " JERBOA_HOME = $(JERBOA_HOME)" + @echo " SCHEME = $(SCHEME)" + +test: + JERBOA_HOME=$(JERBOA_HOME) \ + $(SCHEME) -q --libdirs $(LIBDIRS) --script test/test-all.ss + +clean: + rm -rf tmp new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,21 @@ +# jerboa-mail + +Reusable email parsing and MIME helpers for Jerboa. + +The initial scope is read-oriented: + +- RFC 5322 header/body splitting. +- Header unfolding and lookup. +- RFC 2047 encoded-word decoding for common UTF-8/ASCII cases. +- Base64 and quoted-printable content-transfer decoding. +- Simple MIME parsing for text and multipart messages. +- Best-effort body selection for CLI mail readers. + +Sending helpers can be added later, but this first version is intentionally +small and fixture-driven. + +## Development + +```sh +make test +``` new file mode 100644 --- /dev/null +++ b/jerboa-mail/encoding.ss @@ -0,0 +1,156 @@ +#!chezscheme +;;; (jerboa-mail encoding) - common mail encodings. + +(library (jerboa-mail encoding) + (export + mail-base64-decode-string + mail-quoted-printable-decode-string + mail-transfer-decode-string + mail-decode-encoded-words) + + (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) + (only (std text base64) base64-string->u8vector)) + + (define (ascii-whitespace? ch) + (or (char=? ch #\space) + (char=? ch #\tab) + (char=? ch #\return) + (char=? ch #\newline))) + + (define (strip-ascii-whitespace s) + (let ([out (open-output-string)]) + (let loop ([i 0]) + (when (< i (string-length s)) + (let ([ch (string-ref s i)]) + (unless (ascii-whitespace? ch) + (write-char ch out)) + (loop (+ i 1))))) + (get-output-string out))) + + (define (mail-base64-decode-string s) + (utf8->string (base64-string->u8vector (strip-ascii-whitespace s)))) + + (define (hex-value ch) + (cond + [(and (char>=? ch #\0) (char<=? ch #\9)) + (- (char->integer ch) (char->integer #\0))] + [(and (char>=? ch #\A) (char<=? ch #\F)) + (+ 10 (- (char->integer ch) (char->integer #\A)))] + [(and (char>=? ch #\a) (char<=? ch #\f)) + (+ 10 (- (char->integer ch) (char->integer #\a)))] + [else #f])) + + (define (mail-quoted-printable-decode-string s) + (let ([out (open-output-string)]) + (let loop ([i 0]) + (cond + [(>= i (string-length s)) (get-output-string out)] + [(and (char=? (string-ref s i) #\=) + (< (+ i 1) (string-length s)) + (char=? (string-ref s (+ i 1)) #\newline)) + (loop (+ i 2))] + [(and (char=? (string-ref s i) #\=) + (< (+ i 2) (string-length s)) + (char=? (string-ref s (+ i 1)) #\return) + (char=? (string-ref s (+ i 2)) #\newline)) + (loop (+ i 3))] + [(and (char=? (string-ref s i) #\=) + (< (+ i 2) (string-length s))) + (let ([hi (hex-value (string-ref s (+ i 1)))] + [lo (hex-value (string-ref s (+ i 2)))]) + (if (and hi lo) + (begin + (write-char (integer->char (+ (* hi 16) lo)) out) + (loop (+ i 3))) + (begin + (write-char (string-ref s i) out) + (loop (+ i 1)))))] + [else + (write-char (string-ref s i) out) + (loop (+ i 1))])))) + + (define (mail-transfer-decode-string encoding body) + (cond + [(or (string-ci=? encoding "base64") + (string-ci=? encoding "b")) + (mail-base64-decode-string body)] + [(or (string-ci=? encoding "quoted-printable") + (string-ci=? encoding "q")) + (mail-quoted-printable-decode-string body)] + [else body])) + + (define (string-index-from s ch start) + (let loop ([i start]) + (cond + [(>= i (string-length s)) #f] + [(char=? (string-ref s i) ch) i] + [else (loop (+ i 1))]))) + + (define (find-encoded-end s start) + (let loop ([i start]) + (cond + [(> (+ i 1) (string-length s)) #f] + [(and (char=? (string-ref s i) #\?) + (< (+ i 1) (string-length s)) + (char=? (string-ref s (+ i 1)) #\=)) + i] + [else (loop (+ i 1))]))) + + (define (q-encoded-word->qp s) + (let ([out (open-output-string)]) + (let loop ([i 0]) + (when (< i (string-length s)) + (let ([ch (string-ref s i)]) + (write-char (if (char=? ch #\_) #\space ch) out) + (loop (+ i 1))))) + (get-output-string out))) + + (define (decode-one-encoded-word charset enc payload) + (if (or (string-ci=? charset "utf-8") + (string-ci=? charset "us-ascii") + (string-ci=? charset "ascii")) + (mail-transfer-decode-string + enc + (if (string-ci=? enc "q") (q-encoded-word->qp payload) payload)) + (string-append "=?" charset "?" enc "?" payload "?="))) + + (define (try-decode-at s start) + (if (and (<= (+ start 1) (string-length s)) + (char=? (string-ref s start) #\=) + (char=? (string-ref s (+ start 1)) #\?)) + (let* ([q1 (string-index-from s #\? (+ start 2))] + [q2 (and q1 (string-index-from s #\? (+ q1 1)))] + [end (and q2 (find-encoded-end s (+ q2 1)))]) + (if (and q1 q2 end) + (let ([charset (substring s (+ start 2) q1)] + [enc (substring s (+ q1 1) q2)] + [payload (substring s (+ q2 1) end)]) + (values (decode-one-encoded-word charset enc payload) + (+ end 2))) + (values #f start))) + (values #f start))) + + (define (mail-decode-encoded-words s) + (let ([out (open-output-string)]) + (let loop ([i 0]) + (cond + [(>= i (string-length s)) (get-output-string out)] + [else + (let-values ([(decoded next) (try-decode-at s i)]) + (if decoded + (begin + (display decoded out) + (loop next)) + (begin + (write-char (string-ref s i) out) + (loop (+ i 1)))))])))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/jerboa-mail/header.ss @@ -0,0 +1,147 @@ +#!chezscheme +;;; (jerboa-mail header) - RFC 5322 header helpers. + +(library (jerboa-mail header) + (export + mail-split-header-body + mail-headers-parse + mail-header-ref + mail-header-values + mail-string-trim + mail-split-lines) + + (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 (mail-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) + (char=? (string-ref s i) #\return) + (char=? (string-ref s i) #\newline))) + (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) + (char=? (string-ref s (- i 1)) #\return) + (char=? (string-ref s (- i 1)) #\newline))) + (loop (- i 1)) + i))]) + (substring s start end))) + + (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 (mail-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 (blank-line-at? s i) + (or (and (< (+ i 3) (string-length s)) + (char=? (string-ref s i) #\return) + (char=? (string-ref s (+ i 1)) #\newline) + (char=? (string-ref s (+ i 2)) #\return) + (char=? (string-ref s (+ i 3)) #\newline)) + (and (< (+ i 1) (string-length s)) + (char=? (string-ref s i) #\newline) + (char=? (string-ref s (+ i 1)) #\newline)))) + + (define (mail-split-header-body raw) + (let loop ([i 0]) + (cond + [(>= i (string-length raw)) (values raw "")] + [(and (< (+ i 3) (string-length raw)) + (char=? (string-ref raw i) #\return) + (char=? (string-ref raw (+ i 1)) #\newline) + (char=? (string-ref raw (+ i 2)) #\return) + (char=? (string-ref raw (+ i 3)) #\newline)) + (values (substring raw 0 i) + (substring raw (+ i 4) (string-length raw)))] + [(and (< (+ i 1) (string-length raw)) + (char=? (string-ref raw i) #\newline) + (char=? (string-ref raw (+ i 1)) #\newline)) + (values (substring raw 0 i) + (substring raw (+ i 2) (string-length raw)))] + [else (loop (+ i 1))]))) + + (define (continuation-line? line) + (and (> (string-length line) 0) + (or (char=? (string-ref line 0) #\space) + (char=? (string-ref line 0) #\tab)))) + + (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 " " (mail-string-trim (car xs))) + (mail-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) + (mail-string-trim + (substring line (+ idx 1) (string-length line)))) + #f))) + + (define (mail-headers-parse s) + (let loop ([xs (unfold-lines (mail-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-values headers name) + (let loop ([xs headers] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [(string-ci=? (caar xs) name) + (loop (cdr xs) (cons (cdar xs) acc))] + [else (loop (cdr xs) acc)]))) + + (define (mail-header-ref headers name . default) + (let ([fallback (if (null? default) "" (car default))]) + (let ([values (mail-header-values headers name)]) + (if (null? values) fallback (car values))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/jerboa-mail/mime.ss @@ -0,0 +1,191 @@ +#!chezscheme +;;; (jerboa-mail mime) - small MIME parser and body selector. + +(library (jerboa-mail mime) + (export + mail-content-type + mail-content-params + mail-content-param + mail-parse-message + mail-message-headers + mail-message-body + mail-message-parts + mail-message-content-type + mail-best-text-body) + + (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) + (jerboa-mail header) + (jerboa-mail encoding)) + + (define (string-prefix? prefix s) + (let ([plen (string-length prefix)] + [slen (string-length s)]) + (and (<= plen slen) + (string-ci=? prefix (substring s 0 plen))))) + + (define (string-split s sep) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length s)) + (reverse (cons (substring s start i) acc))] + [(char=? (string-ref s i) sep) + (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else (loop (+ i 1) start acc)]))) + + (define (strip-quotes s) + (let ([n (string-length s)]) + (if (and (>= n 2) + (char=? (string-ref s 0) #\") + (char=? (string-ref s (- n 1)) #\")) + (substring s 1 (- n 1)) + s))) + + (define (param-pair s) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #f] + [(char=? (string-ref s i) #\=) + (cons (mail-string-trim (substring s 0 i)) + (strip-quotes + (mail-string-trim + (substring s (+ i 1) (string-length s)))))] + [else (loop (+ i 1))]))) + + (define (content-type-parts raw) + (let ([parts (map mail-string-trim (string-split raw #\;))]) + (if (null? parts) '("text/plain") parts))) + + (define (mail-content-type headers) + (let* ([raw (mail-header-ref headers "Content-Type" "text/plain")] + [parts (content-type-parts raw)]) + (if (string=? (car parts) "") "text/plain" (car parts)))) + + (define (mail-content-params headers) + (let* ([raw (mail-header-ref headers "Content-Type" "text/plain")] + [parts (cdr (content-type-parts raw))]) + (let loop ([xs parts] [acc '()]) + (cond + [(null? xs) (reverse acc)] + [else + (let ([p (param-pair (car xs))]) + (loop (cdr xs) (if p (cons p acc) acc)))])))) + + (define (mail-content-param headers name . default) + (let ([fallback (if (null? default) #f (car default))]) + (let loop ([xs (mail-content-params headers)]) + (cond + [(null? xs) fallback] + [(string-ci=? (caar xs) name) (cdar xs)] + [else (loop (cdr xs))])))) + + (define (make-message headers body parts) + (vector 'mail-message headers body parts)) + + (define (mail-message-headers m) (vector-ref m 1)) + (define (mail-message-body m) (vector-ref m 2)) + (define (mail-message-parts m) (vector-ref m 3)) + (define (mail-message-content-type m) + (mail-content-type (mail-message-headers m))) + + (define (boundary-line? line marker) + (or (string=? line marker) + (string=? line (string-append marker "--")))) + + (define (closing-boundary-line? line marker) + (string=? line (string-append marker "--"))) + + (define (split-multipart-body body boundary) + (let* ([marker (string-append "--" boundary)] + [lines (mail-split-lines body)]) + (let loop ([xs lines] [inside? #f] [current '()] [parts '()]) + (cond + [(null? xs) + (reverse (if (and inside? (pair? current)) + (cons (string-join-lines (reverse current)) parts) + parts))] + [(boundary-line? (car xs) marker) + (let ([new-parts (if (and inside? (pair? current)) + (cons (string-join-lines (reverse current)) parts) + parts)]) + (if (closing-boundary-line? (car xs) marker) + (reverse new-parts) + (loop (cdr xs) #t '() new-parts)))] + [inside? + (loop (cdr xs) inside? (cons (car xs) current) parts)] + [else + (loop (cdr xs) inside? current parts)])))) + + (define (string-join-lines lines) + (let ([out (open-output-string)]) + (let loop ([xs lines]) + (cond + [(null? xs) (get-output-string out)] + [else + (display (car xs) out) + (unless (null? (cdr xs)) (newline out)) + (loop (cdr xs))])))) + + (define (decode-leaf-body headers body) + (mail-transfer-decode-string + (mail-header-ref headers "Content-Transfer-Encoding" "7bit") + body)) + + (define (mail-parse-message raw) + (let-values ([(header-text body) (mail-split-header-body raw)]) + (let* ([headers (mail-headers-parse header-text)] + [ctype (mail-content-type headers)]) + (if (string-prefix? "multipart/" ctype) + (let ([boundary (mail-content-param headers "boundary" #f)]) + (if boundary + (make-message + headers + "" + (map mail-parse-message + (split-multipart-body body boundary))) + (make-message headers body '()))) + (make-message headers (decode-leaf-body headers body) '()))))) + + (define (html->text html) + (let ([out (open-output-string)]) + (let loop ([i 0] [in-tag? #f]) + (cond + [(>= i (string-length html)) (get-output-string out)] + [(char=? (string-ref html i) #\<) + (loop (+ i 1) #t)] + [(char=? (string-ref html i) #\>) + (loop (+ i 1) #f)] + [in-tag? + (loop (+ i 1) #t)] + [else + (write-char (string-ref html i) out) + (loop (+ i 1) #f)])))) + + (define (find-text-part m want-html?) + (let ([ctype (mail-message-content-type m)]) + (cond + [(and (not want-html?) (string-ci=? ctype "text/plain")) + (mail-message-body m)] + [(and want-html? (string-ci=? ctype "text/html")) + (html->text (mail-message-body m))] + [else + (let loop ([parts (mail-message-parts m)]) + (cond + [(null? parts) #f] + [else + (or (find-text-part (car parts) want-html?) + (loop (cdr parts)))]))]))) + + (define (mail-best-text-body m) + (or (find-text-part m #f) + (find-text-part m #t) + (mail-message-body m))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/test/test-all.ss @@ -0,0 +1,105 @@ +#!chezscheme +;;; Smoke tests for jerboa-mail. + +(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 home (or (getenv "HOME") ".")) +(define jerboa-dir + (or (getenv "JERBOA_HOME") + (string-append home "/mine/jerboa"))) +(define project-dir (current-directory)) + +(library-directories + (append + (list (cons project-dir project-dir) + (cons (string-append jerboa-dir "/lib") + (string-append jerboa-dir "/lib"))) + (library-directories))) + +(import (jerboa-mail header)) +(import (jerboa-mail encoding)) +(import (jerboa-mail mime)) + +(define failures 0) + +(define (pass! name) + (fprintf (current-error-port) " PASS ~a~%" name)) + +(define (fail! name detail) + (set! failures (+ failures 1)) + (fprintf (current-error-port) " FAIL ~a (~a)~%" name detail)) + +(define-syntax check + (syntax-rules () + [(_ name expr) + (let ([res (guard (e [#t e]) + expr)]) + (cond + [(condition? res) + (fail! name (condition-message res))] + [res (pass! name)] + [else (fail! name "returned #f")]))])) + +(fprintf (current-error-port) "jerboa-mail smoke tests~%") +(fprintf (current-error-port) "========================~%") + +(let-values ([(h b) (mail-split-header-body "Subject: Hi\r\n\r\nBody")]) + (check "split header/body header" + (string=? h "Subject: Hi")) + (check "split header/body body" + (string=? b "Body"))) + +(let ([headers (mail-headers-parse + "From: A <a@example.com>\r\nSubject: Hello\r\n folded\r\n\r\nBody")]) + (check "header parser reads From" + (string=? "A <a@example.com>" (mail-header-ref headers "From"))) + (check "header parser unfolds continuation" + (string=? "Hello folded" (mail-header-ref headers "Subject")))) + +(check "base64 decodes string" + (string=? "Hello" (mail-base64-decode-string "SGVsbG8="))) + +(check "quoted-printable decodes hex" + (string=? "Hello world!" (mail-quoted-printable-decode-string "Hello=20world!"))) + +(check "encoded-word decodes base64" + (string=? "Hello" (mail-decode-encoded-words "=?UTF-8?B?SGVsbG8=?="))) + +(check "encoded-word decodes quoted printable" + (string=? "Hello world" (mail-decode-encoded-words "=?UTF-8?Q?Hello_world?="))) + +(let* ([raw "Content-Type: text/plain\r\nContent-Transfer-Encoding: quoted-printable\r\n\r\nHello=20there"] + [msg (mail-parse-message raw)]) + (check "parse plain text body" + (string=? "Hello there" (mail-best-text-body msg)))) + +(let* ([raw (string-append + "Content-Type: multipart/alternative; boundary=\"b\"\r\n\r\n" + "--b\r\n" + "Content-Type: text/plain\r\n\r\n" + "Plain body\r\n" + "--b\r\n" + "Content-Type: text/html\r\n\r\n" + "<p>HTML body</p>\r\n" + "--b--\r\n")] + [msg (mail-parse-message raw)]) + (check "parse multipart has two parts" + (= 2 (length (mail-message-parts msg)))) + (check "best body prefers text/plain" + (string=? "Plain body" (mail-best-text-body msg)))) + +(if (= failures 0) + (begin + (fprintf (current-error-port) "~%All tests passed.~%") + (exit 0)) + (begin + (fprintf (current-error-port) "~%~a test(s) failed.~%" failures) + (exit 1)))