From b71c7cc8dc2b80cbb13888e8793c058c03fbe0e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 26 Jan 2020 22:53:10 +0100 Subject: Add supporting code: (email) and (maintainers). * code/modules/email.scm, code/modules/maintainers.scm: New files. --- code/modules/email.scm | 190 +++++++++++++++++++++++++++++++++++++++++++ code/modules/maintainers.scm | 68 ++++++++++++++++ 2 files changed, 258 insertions(+) create mode 100644 code/modules/email.scm create mode 100644 code/modules/maintainers.scm 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 +;;; +;;; 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)) diff --git a/code/modules/maintainers.scm b/code/modules/maintainers.scm new file mode 100644 index 0000000..a0ea81d --- /dev/null +++ b/code/modules/maintainers.scm @@ -0,0 +1,68 @@ +;;; Copyright © 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 (maintainers) + #:use-module (guix records) + #:use-module (ssh popen) + #:use-module ((ssh session) #:select (disconnect!)) + #:use-module (guix ssh) + #:use-module (srfi srfi-9) + #:export (maintainer? + maintainer-name + maintainer-address + maintainer-packages + + maintainer-collective? + read-maintainers + read-maintainers-from-fencepost)) + +(define-record-type + (maintainer name address packages) + maintainer? + (name maintainer-name) + (address maintainer-address) + (packages maintainer-packages)) + +(define (maintainer-collective? maintainer) + (or (string-suffix? "maintainers@gnu.org" (maintainer-address maintainer)) + (string-suffix? " maintainers" (maintainer-name maintainer)) + (string-suffix? " committee" (maintainer-name maintainer)))) + +(define (read-maintainers port) + "Read from PORT recutils-formatted info about GNU maintainers, and return a +list of records." + (define (read-one port) + (alist->record (recutils->alist port) + maintainer + '("name" "email" "package") + '("package"))) + + (let loop ((result '())) + (if (eof-object? (peek-char port)) + (reverse result) + (let ((maintainer (read-one port))) + (loop (if (and (maintainer-name maintainer) + (maintainer-address maintainer)) + (cons maintainer result) + result)))))) + +(define (read-maintainers-from-fencepost) + (let* ((session (open-ssh-session "fencepost.gnu.org")) + (pipe (open-remote-pipe* session OPEN_READ + "cat" "/gd/gnuorg/maintainers")) + (maintainers (read-maintainers pipe))) + (close-port pipe) + (disconnect! session) + maintainers)) -- cgit v1.2.1