mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 21:47:33 +02:00
Supporting raw 8-bit binary in mime.
This commit is contained in:
parent
71aeb419fb
commit
5f7e5acb3e
3 changed files with 114 additions and 15 deletions
|
@ -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
|
||||||
|
|
|
@ -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"))
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Add table
Reference in a new issue