From b95a83029a1fe01e72f6749c109dedd9885a04df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 13 Feb 2020 22:05:30 +0100 Subject: 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. --- code/modules/email.scm | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) 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 -- cgit v1.2.1