From b71c7cc8dc2b80cbb13888e8793c058c03fbe0e4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
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 <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))
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 <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 (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>
+ (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 <maintainer> 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