1 files changed, 190 insertions, 0 deletions

diff --git a/code/modules/email.scm b/code/modules/email.scm
new file mode 100644
index 0000000..fcf0d9d
--- /dev/null
+++ b/code/modules/email.scm
@@ -0,0 +1,190 @@
+;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 (email)
+  #:use-module ((guix build utils) #:select (dump-port))
+  #:use-module (guix base64)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (mailutils mailutils)
+  #: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* (compose-message from to
+                          #:key reply-to text subject file
+                          (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)
+      (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)
+  "Send MESSAGE, a message returned by 'compose-message', using the SMTP
+parameters found in ~/.config/smtp."
+  (define uri
+    ;; Something like "smtp://USER:SECRET@SERVER:PORT" (info "(mailutils)
+    ;; SMTP Mailboxes").
+    (call-with-input-file (string-append (getenv "HOME") "/.config/smtp")
+      read))
+
+  (mu-register-format "smtp")
+  (mu-message-send message uri))
+
+;; FIXME: This returns an empty message.
+;; (define (set-message-recipient message to)
+;;   "Return a copy of MESSAGE with TO as its recipient."
+;;   (let ((message (mu-message-copy message)))
+;;     (mu-message-set-header message "To" to #t)
+;;     message))