From 9ac10570fca04800f04a439e484f41421864b99f Mon Sep 17 00:00:00 2001
From: Arun Isaac
Date: Sat, 27 Jul 2019 20:25:29 +0530
Subject: email: Decode MIME entities without headers.

* email/email.scm (email->headers+body): If there are no headers,
return "" as headers not an eof-object.
(parse-email-body): Parse headers of parent entity or email to
parse-mime-entity.
(add-default-mime-entity-headers): New function.
(parse-mime-entity): Use add-default-mime-entity-headers instead of
add-default-headers. Handle MIME entities without headers.
* tests/email.scm ("decode MIME entity without headers"): New test.
---
 email/email.scm | 39 ++++++++++++++++++++++++++++++++++-----
 1 file changed, 34 insertions(+), 5 deletions(-)

(limited to 'email')

diff --git a/email/email.scm b/email/email.scm
index 381c81a..565f8e7 100644
--- a/email/email.scm
+++ b/email/email.scm
@@ -611,7 +611,8 @@ values. The returned headers is a string and body is a bytevector."
                                    (not (or (string= line "\n")
                                             (string= line "\r\n")))))))
         (get-line-with-delimiter port)
-        (values headers (get-bytevector-all port))))))
+        (values (if (eof-object? headers) "" headers)
+                (get-bytevector-all port))))))
 
 (define (post-process-mailbox . args)
   (define process-name
@@ -731,7 +732,7 @@ message. Else, return a single <mime-entity> record."
      (let ((content-type (assoc-ref headers 'content-type)))
        (case (assoc-ref content-type 'type)
          ((multipart)
-          (map parse-mime-entity
+          (map (cut parse-mime-entity headers <>)
                (body->mime-entities body (assoc-ref content-type 'boundary))))
          ((text)
           (string-trim-both
@@ -756,7 +757,29 @@ message. Else, return a single <mime-entity> record."
                            default-headers)
             headers)))
 
-(define (parse-mime-entity bv)
+(define (add-default-mime-entity-headers parent-headers headers)
+  ;; Default Content-Type and Content-Transfer-Encoding headers as
+  ;; specified in RFC2045 and RFC2046
+  (let* ((parent-content-type (assoc-ref parent-headers 'content-type))
+         (default-headers
+           (acons* 'content-type `(,@(if (and (eq? (assoc-ref parent-content-type 'type) 'multipart)
+                                              (eq? (assoc-ref parent-content-type 'subtype) 'digest))
+                                         '((type . message)
+                                           (subtype . rfc822))
+                                         '((type . text)
+                                           (subtype . plain)))
+                                  ;; UTF-8 is specified as the default
+                                  ;; charset in RFC6657
+                                  (charset . "utf-8"))
+                  'content-transfer-encoding '#{7bit}#)))
+    (append (alist-delete* (append (if (assoc-ref headers 'content-type)
+                                       (list 'content-type) (list))
+                                   (if (assoc-ref headers 'content-transfer-encoding)
+                                       (list 'content-transfer-encoding) (list)))
+                           default-headers)
+            headers)))
+
+(define (parse-mime-entity parent-headers bv)
   (let-values (((headers body) (email->headers+body bv)))
     (let ((headers
            (pre-post-order
@@ -767,14 +790,20 @@ message. Else, return a single <mime-entity> record."
               (disposition . ,post-process-content-disposition)
               (optional-field . ,post-process-optional-field)
               (mime-entity-fields . ,(lambda (_ . mime-entity-fields)
-                                       (add-default-headers
+                                       (add-default-mime-entity-headers
+                                        parent-headers
                                         (map (match-lambda
                                                ((mime-entity-field value)
                                                 (cons mime-entity-field value))
                                                ((mime-entity-field . values)
                                                 (cons mime-entity-field values)))
                                              mime-entity-fields))))
-              (*text* . ,(lambda (_ text) text))
+              (*text* . ,(match-lambda*
+                           ;; Handle MIME entities that have no
+                           ;; headers.
+                           ((_ 'mime-entity-fields)
+                            (add-default-mime-entity-headers parent-headers '()))
+                           ((_ text) text)))
               (*default* . ,(lambda tree tree))))))
       (make-mime-entity headers (parse-email-body headers body)))))
 
-- 
cgit v1.2.3