;;; Copyright © 2018, 2020 Ludovic Courtès ;;; ;;; 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 . (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))