diff options
Diffstat (limited to 'email')
| -rw-r--r-- | email/email.scm | 39 |
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))))) |