Supporting raw 8-bit binary in mime.

lib/chibi/mime.scm

@@ -68,9 +68,10 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 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}
@@ -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-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"))
                (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
-               (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)
   (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

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"))

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)