diff options
| -rw-r--r-- | email/email.scm | 52 | ||||
| -rw-r--r-- | email/utils.scm | 19 |
2 files changed, 32 insertions, 39 deletions
diff --git a/email/email.scm b/email/email.scm index 7665760..43f9a72 100644 --- a/email/email.scm +++ b/email/email.scm @@ -775,41 +775,31 @@ message. Else, return a single <mime-entity> record." (define (add-default-headers headers) ;; Default Content-Type and Content-Transfer-Encoding headers as ;; specified in RFC2045 - (let ((default-headers - (acons* 'content-type '((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))) + (alist-combine (acons* 'content-type '((type . text) + (subtype . plain) + ;; UTF-8 is specified as the default + ;; charset in RFC6657 + (charset . "utf-8")) + 'content-transfer-encoding '#{7bit}#) + headers)) (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))) + (let ((parent-content-type (assoc-ref parent-headers 'content-type))) + (alist-combine + (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}#) + headers))) (define (parse-mime-entity parent-headers bv) (let-values (((headers body) (email->headers+body bv))) diff --git a/email/utils.scm b/email/utils.scm index 536dc52..70153be 100644 --- a/email/utils.scm +++ b/email/utils.scm @@ -26,13 +26,14 @@ #:use-module ((rnrs io ports) #:select (call-with-bytevector-output-port)) #:use-module (rnrs io simple) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (get-line-with-delimiter read-objects read-while read-bytes-till acons* - alist-delete*)) + alist-combine)) (define (read-objects read-proc port) "Read all objects using READ-PROC from PORT and return them as a @@ -101,13 +102,15 @@ delimiting linefeed character." (acons key value (apply acons* rest))) ((alist) alist))) -(define (alist-delete* keys alist) - "Return a list containing all elements of ALIST whose keys are not a -member of KEYS." - (filter (match-lambda - ((key . _) - (not (member key keys)))) - alist)) +(define (alist-combine alist1 alist2) + "Combine two association lists ALIST1 and ALIST2 into a single +association list. Key-value pairs in ALIST2 are more significant and +override those in ALIST1." + (append alist2 + (remove (match-lambda + ((key . _) + (assoc key alist2))) + alist1))) (define (cg-string-ci pat accum) (syntax-case pat () |