mumi: Add send-email.
authorRicardo Wurmus <rekado@elephly.net>
Sun, 5 Apr 2020 13:52:32 +0000 (15:52 +0200)
committerRicardo Wurmus <rekado@elephly.net>
Sun, 5 Apr 2020 13:52:32 +0000 (15:52 +0200)
Makefile.am
mumi/send-email.scm [new file with mode: 0644]

index fa4e149..fd34ea5 100644 (file)
@@ -46,4 +46,5 @@ SOURCES =                                                     \
   mumi/web/view/utils.scm                      \
   mumi/bugs.scm                                                \
   mumi/messages.scm                                    \
+  mumi/send-email.scm                          \
   mumi/config.scm
diff --git a/mumi/send-email.scm b/mumi/send-email.scm
new file mode 100644 (file)
index 0000000..02a5364
--- /dev/null
@@ -0,0 +1,216 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This program is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (mumi send-email)
+  #:use-module ((guix build utils) #:select (dump-port))
+  #:use-module (gcrypt base64)
+  #: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
+            send-message))
+
+;; This variable is looked up by 'mu-message-send', uh!
+(define-public mu-debug 0)
+
+(define (pipe-pair command)
+  "Run COMMAND as a separate process and return three values: its PID, an
+output port to write on COMMAND's standard input, and an input port to read
+COMMAND's standard output."
+  (let ((input (pipe))
+        (output (pipe)))
+    (match (primitive-fork)
+      (0
+       (dynamic-wind
+         (const #t)
+         (lambda ()
+           (close-port (cdr input))
+           (close-port (car output))
+           (dup2 (fileno (car input)) 0)
+           (dup2 (fileno (cdr output)) 1)
+           (apply execlp (car command) command))
+         (lambda ()
+           (primitive-_exit 127))))
+      (pid
+       (close-port (car input))
+       (close-port (cdr output))
+       (values pid (cdr input) (car output))))))
+
+(define (dump-port/convert-newlines input output)
+  "Dump INPUT to OUTPUT, converting '\n' to '\n\r'."
+  (let loop ()
+    (match (get-u8 input)
+      ((? eof-object?) #t)
+      (10
+       (put-bytevector output #vu8(13 10))
+       (loop))
+      (octet
+       (put-u8 output octet)
+       (loop)))))
+
+(define* (insert-newlines str #:optional (line-length 76))
+  "Insert newlines in STR every LINE-LENGTH characters."
+  (let loop ((result '())
+             (str str))
+    (if (string-null? str)
+        (string-concatenate-reverse result)
+        (let* ((length (min (string-length str) line-length))
+               (prefix (string-take str length))
+               (suffix (string-drop str length)))
+          (loop (cons (string-append prefix "\n") result)
+                suffix)))))
+
+(define* (attach-file! mime data #:key
+                       (attachment (mu-message-create))
+                       (file-mime-type "application/octet-stream")
+                       (binary-file? #t)
+                       (inline-file? #f))
+  "Attach FILE to MIME, an object returned by 'mu-mime-create'."
+  (let ((port (mu-message-get-port attachment "w")))
+    (put-bytevector port
+                    (if binary-file?
+                        (string->utf8
+                         (insert-newlines (base64-encode data)))
+                        data))
+    (close-port port)
+    (when binary-file?
+      (mu-message-set-header attachment
+                             "Content-Transfer-Encoding"
+                             "base64"))
+    (mu-message-set-header attachment
+                           "Content-Type" file-mime-type)
+    (when inline-file?
+      (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)
+                          (inline-file? #t)
+                          sign? (gpg-arguments '()))
+  "Compose a message, and return a message object."
+  (let* ((mime    (mu-mime-create))
+         (message (mu-message-create))
+         (body    (mu-message-get-port message "w")))
+    (mu-message-set-header message
+                           "Content-Type"
+                           "text/plain; charset=utf-8")
+    (put-bytevector body (string->utf8 text))
+    (newline body)
+    (close-port body)
+    (mu-mime-add-part mime message)
+
+    (when file
+      (attach-file! mime
+                    (call-with-input-file file get-bytevector-all)
+                    #:file-mime-type file-mime-type
+                    #:binary-file? binary-file?
+                    #:inline-file? inline-file?))
+
+    (when sign?
+      (let* ((pid output input (pipe-pair `("gpg" "-ab" ,@gpg-arguments)))
+             (body (mu-message-get-port message "r" #t)))
+        (dump-port/convert-newlines body output)
+        (close-port output)
+        (let ((signature (get-bytevector-all input)))
+          (close-port input)
+          (match (waitpid pid)
+            ((_ . 0) #t)
+            ((_ . status) (error "failed to sign message body" status)))
+
+          (attach-file! mime signature
+                        #:file-mime-type "application/pgp-signature"
+                        #:binary-file? #f
+                        #:inline-file? #f))))
+
+    (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
+        (mu-message-set-header result "Reply-To" reply-to))
+      (when user-agent
+        (mu-message-set-header result "User-Agent" user-agent))
+      (when sign?
+        (set-multipart/signed-content-type! result))
+      result)))
+
+(define (set-multipart/signed-content-type! message)
+  (let ((content-type (mu-message-get-header message "Content-Type"))
+        (mixed        "multipart/mixed; "))
+    (when (string-prefix? mixed content-type)
+      (mu-message-set-header message "Content-Type"
+                             (string-append
+                              "multipart/signed; "
+                              (string-drop content-type
+                                           (string-length mixed))
+                              "; micalg=pgp-sha256; "
+                              "protocol=\"application/pgp-signature\"")
+                             #t))))
+
+(define (display-body message)                    ;debug
+  (let ((port (mu-message-get-port message "r")))
+    (dump-port port (current-error-port))
+    (close-port port)))
+
+(define* (send-message message uri)
+  "Send MESSAGE, a message returned by 'compose-message', using the
+parameters in URI.  See (info \"(mailutils) SMTP Mailboxes)." 
+  (mu-register-format (if (string-prefix? "sendmail" uri)
+                          "sendmail"
+                          "smtp"))
+  (mu-message-send message uri))