summaryrefslogtreecommitdiff
path: root/email
diff options
context:
space:
mode:
authorArun Isaac2019-07-27 20:25:29 +0530
committerArun Isaac2019-07-28 12:13:43 +0530
commit9ac10570fca04800f04a439e484f41421864b99f (patch)
tree030144163601ddf43b72df64d84530f2f5871587 /email
parentac83c2a00c13702bc365cd0f3074239fa63d743f (diff)
downloadguile-email-9ac10570fca04800f04a439e484f41421864b99f.tar.gz
guile-email-9ac10570fca04800f04a439e484f41421864b99f.tar.lz
guile-email-9ac10570fca04800f04a439e484f41421864b99f.zip
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.
Diffstat (limited to 'email')
-rw-r--r--email/email.scm39
1 files changed, 34 insertions, 5 deletions
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)))))