Supporting raw 8-bit binary in mime.

This commit is contained in:
Alex Shinn 2014-04-01 18:45:58 +09:00
parent 71aeb419fb
commit 5f7e5acb3e
3 changed files with 114 additions and 15 deletions

View file

@ -68,9 +68,10 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dummy encoder ;; dummy encoder
;; TODO: add conversion routines (define (ces-convert bv . o)
(define (ces-convert str . x) (let ((enc (if (pair? o) (car o) "utf8")))
str) ;; TODO: add conversion routines for non-utf8 encodings
(utf8->string bv)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> \section{RFC2822 Headers} ;;> \section{RFC2822 Headers}
@ -220,7 +221,45 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; message parsing ;; 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 ((final-boundary (and boundary (string-append boundary "--"))))
(let lp ((res '())) (let lp ((res '()))
(let ((line (read-line port mime-line-length-limit))) (let ((line (read-line port mime-line-length-limit)))
@ -234,21 +273,31 @@
(else (else
(lp (cons line res)))))))) (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 (let ((res (cond
((and (string? cte) (string-ci=? cte "quoted-printable")) ((and (string? cte) (string-ci=? cte "quoted-printable"))
(if text? (if text?
(quoted-printable-decode-string str) (quoted-printable-decode-string part)
(quoted-printable-decode-bytevector (string->utf8 str)))) (quoted-printable-decode-bytevector
(if (string? part) (string->utf8 part) part))))
((and (string? cte) (string-ci=? cte "base64")) ((and (string? cte) (string-ci=? cte "base64"))
(if text? (if text?
(base64-decode-string str) (base64-decode-string part)
(base64-decode-bytevector (string->utf8 str)))) (base64-decode-bytevector
(text? (if (string? part) (string->utf8 part) part))))
str) ((and (not text?) (string? part))
(string->utf8 part))
(else (else
(string->utf8 str))))) part))))
(if (string? res) (ces-convert res enc) res))) (cond
((and text? (bytevector? res)) (ces-convert res enc))
(else res))))
(define (mime-read-part port type cte enc boundary next final) (define (mime-read-part port type cte enc boundary next final)
(let ((text? (and (symbol? type) (let ((text? (and (symbol? type)
@ -331,6 +380,7 @@
(mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x)) (mime-read-to-boundary port boundary2 (lambda (x) x) (lambda (x) x))
(let lp ((part-seed (kons-down headers seed))) (let lp ((part-seed (kons-down headers seed)))
(let ((part-headers (mime-headers->list port))) (let ((part-headers (mime-headers->list port)))
(flush-output (current-error-port))
(tfold headers part-headers (tfold headers part-headers
part-seed boundary2 part-seed boundary2
lp lp

View file

@ -4,5 +4,6 @@
mime-parse-content-type mime-decode-header mime-parse-content-type mime-decode-header
mime-message-fold mime-message->sxml mime-write-headers) mime-message-fold mime-message->sxml mime-write-headers)
(import (chibi) (chibi base64) (chibi quoted-printable) (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")) (include "mime.scm"))

View file

@ -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") (test-begin "mime")
@ -95,4 +96,51 @@ Content-Transfer-Encoding: binary
" "
mime-message->sxml)) 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) (test-end)