email: Introduce alist union utility.

* email/utils.scm (alist-combine): New function.
(alist-delete*): Delete function.
* email/email.scm (add-default-headers,
add-default-mime-entity-headers): Use alist-combine.

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 ()