diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | mumi/send-email.scm | 216 |
2 files changed, 217 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index fa4e149..fd34ea5 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 index 0000000..02a5364 --- /dev/null +++ b/mumi/send-email.scm @@ -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)) |