aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--email/email.scm52
-rw-r--r--email/utils.scm19
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 ()