summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-02-13 22:05:30 +0100
committerLudovic Courtès <ludo@gnu.org>2020-02-13 22:05:30 +0100
commitb95a83029a1fe01e72f6749c109dedd9885a04df (patch)
treedfd3ef7b6ad9e323f9c554a132e87851b18eff9c
parentsocial-contract-endorsement: Add Mark Galassi. (diff)
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.
-rw-r--r--code/modules/email.scm35
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 @@
19 #:use-module (rnrs io ports) 19 #:use-module (rnrs io ports)
20 #:use-module (rnrs bytevectors) 20 #:use-module (rnrs bytevectors)
21 #:use-module (mailutils mailutils) 21 #:use-module (mailutils mailutils)
22 #:use-module (srfi srfi-19)
22 #:use-module (srfi srfi-71) 23 #:use-module (srfi srfi-71)
23 #:use-module (ice-9 match) 24 #:use-module (ice-9 match)
24 #:export (compose-message 25 #:export (compose-message
@@ -97,8 +98,38 @@ COMMAND's standard output."
97 (mu-message-set-header attachment "Content-Disposition" "inline")) 98 (mu-message-set-header attachment "Content-Disposition" "inline"))
98 (mu-mime-add-part mime attachment))) 99 (mu-mime-add-part mime attachment)))
99 100
101(define (date->rfc822-string date)
102 "Return a date string like \"Thu, 13 Feb 2020 18:09:31 +0100\" for use in a
103'Date' header."
104 (define days
105 #("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
106 (define months
107 #("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
108 "Dec"))
109
110 ;; Return locale-independent day/month names.
111 (define (day-name date)
112 (vector-ref days (date-week-day date)))
113 (define (month-name date)
114 (vector-ref months (- (date-month date) 1)))
115
116 (date->string date
117 (string-append (day-name date) ", ~e "
118 (month-name date) " ~Y ~H:~M:~S ~z")))
119
120(define* (compute-message-id message #:optional seed)
121 "Return a message ID string."
122 (string-append "<" (number->string (object-address message) 16)
123 "." (number->string
124 (or seed
125 (string-hash (or (mu-message-get-header message "Subject")
126 "")))
127 16)
128 "@guile.gnu.org>"))
129
100(define* (compose-message from to 130(define* (compose-message from to
101 #:key reply-to text subject file 131 #:key reply-to text subject file
132 (date (time-utc->date (current-time time-utc)))
102 (file-mime-type "image/jpeg") 133 (file-mime-type "image/jpeg")
103 user-agent 134 user-agent
104 (binary-file? #t) 135 (binary-file? #t)
@@ -142,6 +173,10 @@ COMMAND's standard output."
142 (let ((result (mu-mime-get-message mime))) 173 (let ((result (mu-mime-get-message mime)))
143 (mu-message-set-header result "From" from) 174 (mu-message-set-header result "From" from)
144 (mu-message-set-header result "To" to) 175 (mu-message-set-header result "To" to)
176 (mu-message-set-header result "Date" (date->rfc822-string date))
177 (mu-message-set-header result "Message-ID"
178 (compute-message-id message
179 (and=> text string-hash)))
145 (when subject 180 (when subject
146 (mu-message-set-header result "Subject" subject)) 181 (mu-message-set-header result "Subject" subject))
147 (when reply-to 182 (when reply-to