fix: UTF-8 QP decoding, base64 error handling, boundary padding, encoded-word whitespace, alternative preference
ober
310d12329cd55522f73b65178f4c37db4b44ef88
--- a/jerboa-mail/encoding.ss +++ b/jerboa-mail/encoding.ss @@ -50,12 +50,25 @@ (loop (+ i 1))))) (get-output-string out))) + (define (u8vector->lossy-string bv) + (let ([out (open-output-string)]) + (let loop ([i 0]) + (cond + [(>= i (bytevector-length bv)) (get-output-string out)] + [else + (write-char (integer->char (bytevector-u8-ref bv i)) out) + (loop (+ i 1))])))) + + (define (u8vector->utf8-string bv) + (guard (_ [#t (u8vector->lossy-string bv)]) + (utf8->string bv))) + (define (mail-base64-decode-string s) (check-string-limit 'mail-base64-decode-string "base64 payload" s mail-max-transfer-encoded-chars) - (utf8->string (base64-string->u8vector (strip-ascii-whitespace s)))) + (u8vector->utf8-string (base64-string->u8vector (strip-ascii-whitespace s)))) (define (hex-value ch) (cond @@ -72,33 +85,28 @@ "quoted-printable payload" s mail-max-transfer-encoded-chars) - (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))])))) + (let loop ([i 0] [acc '()]) + (cond + [(>= i (string-length s)) + (u8vector->utf8-string (u8-list->bytevector (reverse acc)))] + [(and (char=? (string-ref s i) #\=) + (< (+ i 1) (string-length s)) + (char=? (string-ref s (+ i 1)) #\newline)) + (loop (+ i 2) acc)] + [(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) acc)] + [(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) + (loop (+ i 3) (cons (+ (* hi 16) lo) acc)) + (loop (+ i 1) (cons (char->integer (string-ref s i)) acc))))] + [else + (loop (+ i 1) (cons (char->integer (string-ref s i)) acc))]))) (define (mail-transfer-decode-string encoding body) (cond @@ -161,6 +169,17 @@ (values #f start))) (values #f start))) + (define (skip-linear-whitespace s i) + (let loop ([i i]) + (if (and (< i (string-length s)) + (ascii-whitespace? (string-ref s i))) + (loop (+ i 1)) + i))) + + (define (encoded-word-at? s i) + (let-values ([(decoded _) (try-decode-at s i)]) + (and decoded #t))) + (define (mail-decode-encoded-words s) (check-string-limit 'mail-decode-encoded-words "encoded-word header" @@ -175,7 +194,10 @@ (if decoded (begin (display decoded out) - (loop next)) + (let ([j (skip-linear-whitespace s next)]) + (if (and (> j next) (encoded-word-at? s j)) + (loop j) + (loop next)))) (begin (write-char (string-ref s i) out) (loop (+ i 1)))))])))) --- a/jerboa-mail/mime.ss +++ b/jerboa-mail/mime.ss @@ -129,12 +129,24 @@ (define (mail-message-content-type m) (mail-content-type (mail-message-headers m))) + (define (trim-trailing-whitespace s) + (let loop ([n (string-length s)]) + (if (and (> n 0) + (let ([ch (string-ref s (- n 1))]) + (or (char=? ch #\space) + (char=? ch #\tab) + (char=? ch #\return) + (char=? ch #\newline)))) + (loop (- n 1)) + (substring s 0 n)))) + (define (boundary-line? line marker) - (or (string=? line marker) - (string=? line (string-append marker "--")))) + (let ([trimmed (trim-trailing-whitespace line)]) + (or (string=? trimmed marker) + (string=? trimmed (string-append marker "--"))))) (define (closing-boundary-line? line marker) - (string=? line (string-append marker "--"))) + (string=? (trim-trailing-whitespace line) (string-append marker "--"))) (define (bad-boundary-char? ch) (or (char=? ch #\newline) @@ -256,12 +268,12 @@ [(and want-html? (string-ci=? ctype "text/html")) (html->text (mail-message-body m))] [else - (let loop ([parts (mail-message-parts m)]) + (let loop ([parts (mail-message-parts m)] [best #f]) (cond - [(null? parts) #f] + [(null? parts) best] [else - (or (find-text-part (car parts) want-html?) - (loop (cdr parts)))]))]))) + (let ([found (find-text-part (car parts) want-html?)]) + (loop (cdr parts) (if found found best)))]))]))) (define (mail-best-text-body m) (or (find-text-part m #f) --- a/test/test-all.ss +++ b/test/test-all.ss @@ -78,6 +78,25 @@ (check "encoded-word decodes quoted printable" (string=? "Hello world" (mail-decode-encoded-words "=?UTF-8?Q?Hello_world?="))) +(check "quoted-printable decodes UTF-8 multibyte" + (string=? (utf8->string (u8-list->bytevector '(#xC3 #xA9))) + (mail-quoted-printable-decode-string "=C3=A9"))) + +(check "quoted-printable decodes 3-byte UTF-8" + (string=? (utf8->string (u8-list->bytevector '(#xE2 #x82 #xAC))) + (mail-quoted-printable-decode-string "=E2=82=AC"))) + +(check "base64 invalid UTF-8 returns a string" + (string? (mail-base64-decode-string "w0E="))) + +(check "encoded-word drops whitespace between adjacent words" + (string=? "HelloWorld" + (mail-decode-encoded-words "=?UTF-8?Q?Hello?= =?UTF-8?Q?World?="))) + +(check "encoded-word keeps whitespace before plain text" + (string=? "Hello plain" + (mail-decode-encoded-words "=?UTF-8?Q?Hello?= plain"))) + (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" @@ -98,6 +117,31 @@ (check "best body prefers text/plain" (string=? "Plain body" (mail-best-text-body msg)))) +(let* ([raw (string-append + "Content-Type: multipart/mixed; boundary=\"b\"\r\n\r\n" + "--b \r\n" + "Content-Type: text/plain\r\n\r\n" + "padded boundary\r\n" + "--b--\r\n")] + [msg (mail-parse-message raw)]) + (check "boundary tolerates trailing transport padding" + (= 1 (length (mail-message-parts msg)))) + (check "padded boundary part body decoded" + (string=? "padded boundary" (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" + "older\r\n" + "--b\r\n" + "Content-Type: text/plain\r\n\r\n" + "newest\r\n" + "--b--\r\n")] + [msg (mail-parse-message raw)]) + (check "alternative prefers last matching part" + (string=? "newest" (mail-best-text-body msg)))) + (parameterize ([mail-max-message-chars 8]) (check-raises "reject over-limit message" (mail-split-header-body "Subject: Too long\r\n\r\nbody")))