diff --git a/lib/chibi/mime.scm b/lib/chibi/mime.scm index 9649fe81..1ed5a7e6 100644 --- a/lib/chibi/mime.scm +++ b/lib/chibi/mime.scm @@ -68,9 +68,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; dummy encoder -;; TODO: add conversion routines -(define (ces-convert str . x) - str) +(define (ces-convert bv . o) + (let ((enc (if (pair? o) (car o) "utf8"))) + ;; TODO: add conversion routines for non-utf8 encodings + (utf8->string bv))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;> \section{RFC2822 Headers} @@ -220,7 +221,45 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; message parsing -(define (mime-read-to-boundary port boundary next final) +(define (read-line/binary in) + (let ((out (open-output-bytevector))) + (let lp () + (let ((ch (read-u8 in))) + (cond ((eof-object? ch) + (let ((res (get-output-bytevector out))) + (if (zero? (bytevector-length res)) + ch + res))) + ((eqv? ch 10) + (get-output-bytevector out)) + (else + (write-u8 ch out) + (lp))))))) + +(define (mime-read-to-boundary/binary port boundary next final) + (let* ((boundary (if (string? boundary) (string->utf8 boundary) boundary)) + (boundary-cr (and boundary (bytevector-append boundary #u8(13)))) + (final-boundary + (and boundary (bytevector-append boundary #u8(45 45)))) + (final-boundary-cr + (and final-boundary (bytevector-append final-boundary #u8(13)))) + (out (open-output-bytevector))) + (let lp ((first? #t)) + (let ((line (read-line/binary port))) + (cond + ((or (eof-object? line) + (equal? line final-boundary) + (equal? line final-boundary-cr)) + (final (get-output-bytevector out))) + ((or (equal? line boundary) (equal? line boundary-cr)) + (next (get-output-bytevector out))) + (else + (if (not first?) + (write-u8 10 out)) + (write-bytevector line out) + (lp #f))))))) + +(define (mime-read-to-boundary/text port boundary next final) (let ((final-boundary (and boundary (string-append boundary "--")))) (let lp ((res '())) (let ((line (read-line port mime-line-length-limit))) @@ -234,21 +273,31 @@ (else (lp (cons line res)))))))) -(define (mime-convert-part str text? cte enc) +(define (mime-read-to-boundary port boundary next final) + ((if (binary-port? port) + mime-read-to-boundary/binary + mime-read-to-boundary/text) + port boundary next final)) + +(define (mime-convert-part part text? cte enc) (let ((res (cond ((and (string? cte) (string-ci=? cte "quoted-printable")) (if text? - (quoted-printable-decode-string str) - (quoted-printable-decode-bytevector (string->utf8 str)))) + (quoted-printable-decode-string part) + (quoted-printable-decode-bytevector + (if (string? part) (string->utf8 part) part)))) ((and (string? cte) (string-ci=? cte "base64")) (if text? - (base64-decode-string str) - (base64-decode-bytevector (string->utf8 str)))) - (text? - str) + (base64-decode-string part) + (base64-decode-bytevector + (if (string? part) (string->utf8 part) part)))) + ((and (not text?) (string? part)) + (string->utf8 part)) (else - (string->utf8 str))))) - (if (string? res) (ces-convert res enc) res))) + part)))) + (cond + ((and text? (bytevector? res)) (ces-convert res enc)) + (else res)))) (define (mime-read-part port type cte enc boundary next final) (let ((text? (and (symbol? type) @@ -331,6 +380,7 @@ (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) (let lp ((part-seed (kons-down headers seed))) (let ((part-headers (mime-headers->list port))) + (flush-output (current-error-port)) (tfold headers part-headers part-seed boundary2 lp diff --git a/lib/chibi/mime.sld b/lib/chibi/mime.sld index f9b37b39..e0f11d96 100644 --- a/lib/chibi/mime.sld +++ b/lib/chibi/mime.sld @@ -4,5 +4,6 @@ mime-parse-content-type mime-decode-header mime-message-fold mime-message->sxml mime-write-headers) (import (chibi) (chibi base64) (chibi quoted-printable) - (chibi string) (chibi io)) + (chibi string) (chibi io) + (only (scheme base) bytevector-append write-bytevector)) (include "mime.scm")) diff --git a/tests/mime-tests.scm b/tests/mime-tests.scm index 400eab38..c23c0064 100644 --- a/tests/mime-tests.scm +++ b/tests/mime-tests.scm @@ -1,5 +1,6 @@ -(import (chibi) (chibi mime) (chibi test)) +(import (chibi) (chibi mime) (chibi test) + (only (scheme base) string->utf8 open-input-bytevector)) (test-begin "mime") @@ -95,4 +96,51 @@ Content-Transfer-Encoding: binary " mime-message->sxml)) +(test '(mime + (@ (content-type . "multipart/form-data, boundary=AaB03x")) + (mime (@ (content-disposition . "form-data; name=\"field1\"") + (content-type . "text/plain")) + "Joe Blow") + (mime (@ (content-disposition . "form-data; name=\"pics\"") + (content-type . "multipart/mixed, boundary=BbC04y")) + (mime (@ (content-disposition + . "attachment; filename=\"file1.txt\"") + (content-type . "text/plain")) + "... contents of file1.txt ...") + (mime (@ (content-disposition + . "attachment; filename=\"file2.gif\"") + (content-type . "image/gif") + (content-transfer-encoding . "binary")) + #u8(32 32 46 46 46 99 111 110 116 101 110 + 116 115 32 111 102 32 102 105 108 101 + 50 46 103 105 102 46 46 46)))) + (mime-message->sxml + (open-input-bytevector + (string->utf8 + "Content-type: multipart/form-data, boundary=AaB03x + +--AaB03x +content-disposition: form-data; name=\"field1\" +Content-Type: text/plain + +Joe Blow +--AaB03x +content-disposition: form-data; name=\"pics\" +Content-type: multipart/mixed, boundary=BbC04y + +--BbC04y +Content-disposition: attachment; filename=\"file1.txt\" +Content-Type: text/plain + +... contents of file1.txt ... +--BbC04y +Content-disposition: attachment; filename=\"file2.gif\" +Content-type: image/gif +Content-Transfer-Encoding: binary + + ...contents of file2.gif... +--BbC04y-- +--AaB03x-- +")))) + (test-end)