email: Always add a "Date" and a "Message-ID" header.

* code/modules/email.scm (date->rfc822-string, compute-message-id): New
procedures.
(compose-message): Add #:date parameter.  Set a "Date" and a
"Message-ID" header on RESULT.

1 files changed, 35 insertions, 0 deletions

diff --git a/code/modules/email.scm b/code/modules/email.scm
index fcf0d9d..b633567 100644
--- a/code/modules/email.scm
+++ b/code/modules/email.scm
@@ -19,6 +19,7 @@
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (mailutils mailutils)
+  #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:export (compose-message
@@ -97,8 +98,38 @@ COMMAND's standard output."
       (mu-message-set-header attachment "Content-Disposition" "inline"))
     (mu-mime-add-part mime attachment)))
 
+(define (date->rfc822-string date)
+  "Return a date string like \"Thu, 13 Feb 2020 18:09:31 +0100\" for use in a
+'Date' header."
+  (define days
+    #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+  (define months
+    #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
+      "Dec"))
+
+  ;; Return locale-independent day/month names.
+  (define (day-name date)
+    (vector-ref days (date-week-day date)))
+  (define (month-name date)
+    (vector-ref months (- (date-month date) 1)))
+
+  (date->string date
+                (string-append (day-name date) ", ~e "
+                               (month-name date) " ~Y ~H:~M:~S ~z")))
+
+(define* (compute-message-id message #:optional seed)
+  "Return a message ID string."
+  (string-append "<" (number->string (object-address message) 16)
+                 "." (number->string
+                      (or seed
+                          (string-hash (or (mu-message-get-header message "Subject")
+                                           "")))
+                      16)
+                 "@guile.gnu.org>"))
+
 (define* (compose-message from to
                           #:key reply-to text subject file
+                          (date (time-utc->date (current-time time-utc)))
                           (file-mime-type "image/jpeg")
                           user-agent
                           (binary-file? #t)
@@ -142,6 +173,10 @@ COMMAND's standard output."
     (let ((result (mu-mime-get-message mime)))
       (mu-message-set-header result "From" from)
       (mu-message-set-header result "To" to)
+      (mu-message-set-header result "Date" (date->rfc822-string date))
+      (mu-message-set-header result "Message-ID"
+                             (compute-message-id message
+                                                 (and=> text string-hash)))
       (when subject
         (mu-message-set-header result "Subject" subject))
       (when reply-to