2 files changed, 258 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))
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))

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 @@
	1	;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org>
	2	;;;
	3	;;; This program is free software; you can redistribute it and/or modify it
	4	;;; under the terms of the GNU General Public License as published by
	5	;;; the Free Software Foundation; either version 3 of the License, or (at
	6	;;; your option) any later version.
	7	;;;
	8	;;; This program is distributed in the hope that it will be useful, but
	9	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	10	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	;;; GNU General Public License for more details.
	12	;;;
	13	;;; You should have received a copy of the GNU General Public License
	14	;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
	15
	16	(define-module (email)
	17	#:use-module ((guix build utils) #:select (dump-port))
	18	#:use-module (guix base64)
	19	#:use-module (rnrs io ports)
	20	#:use-module (rnrs bytevectors)
	21	#:use-module (mailutils mailutils)
	22	#:use-module (srfi srfi-71)
	23	#:use-module (ice-9 match)
	24	#:export (compose-message
	25	send-message))
	26
	27	;; This variable is looked up by 'mu-message-send', uh!
	28	(define-public mu-debug 0)
	29
	30	(define (pipe-pair command)
	31	"Run COMMAND as a separate process and return three values: its PID, an
	32	output port to write on COMMAND's standard input, and an input port to read
	33	COMMAND's standard output."
	34	(let ((input (pipe))
	35	(output (pipe)))
	36	(match (primitive-fork)
	37	(0
	38	(dynamic-wind
	39	(const #t)
	40	(lambda ()
	41	(close-port (cdr input))
	42	(close-port (car output))
	43	(dup2 (fileno (car input)) 0)
	44	(dup2 (fileno (cdr output)) 1)
	45	(apply execlp (car command) command))
	46	(lambda ()
	47	(primitive-_exit 127))))
	48	(pid
	49	(close-port (car input))
	50	(close-port (cdr output))
	51	(values pid (cdr input) (car output))))))
	52
	53	(define (dump-port/convert-newlines input output)
	54	"Dump INPUT to OUTPUT, converting '\n' to '\n\r'."
	55	(let loop ()
	56	(match (get-u8 input)
	57	((? eof-object?) #t)
	58	(10
	59	(put-bytevector output #vu8(13 10))
	60	(loop))
	61	(octet
	62	(put-u8 output octet)
	63	(loop)))))
	64
	65	(define* (insert-newlines str #:optional (line-length 76))
	66	"Insert newlines in STR every LINE-LENGTH characters."
	67	(let loop ((result '())
	68	(str str))
	69	(if (string-null? str)
	70	(string-concatenate-reverse result)
	71	(let* ((length (min (string-length str) line-length))
	72	(prefix (string-take str length))
	73	(suffix (string-drop str length)))
	74	(loop (cons (string-append prefix "\n") result)
	75	suffix)))))
	76
	77	(define* (attach-file! mime data #:key
	78	(attachment (mu-message-create))
	79	(file-mime-type "application/octet-stream")
	80	(binary-file? #t)
	81	(inline-file? #f))
	82	"Attach FILE to MIME, an object returned by 'mu-mime-create'."
	83	(let ((port (mu-message-get-port attachment "w")))
	84	(put-bytevector port
	85	(if binary-file?
	86	(string->utf8
	87	(insert-newlines (base64-encode data)))
	88	data))
	89	(close-port port)
	90	(when binary-file?
	91	(mu-message-set-header attachment
	92	"Content-Transfer-Encoding"
	93	"base64"))
	94	(mu-message-set-header attachment
	95	"Content-Type" file-mime-type)
	96	(when inline-file?
	97	(mu-message-set-header attachment "Content-Disposition" "inline"))
	98	(mu-mime-add-part mime attachment)))
	99
	100	(define* (compose-message from to
	101	#:key reply-to text subject file
	102	(file-mime-type "image/jpeg")
	103	user-agent
	104	(binary-file? #t)
	105	(inline-file? #t)
	106	sign? (gpg-arguments '()))
	107	"Compose a message, and return a message object."
	108	(let* ((mime (mu-mime-create))
	109	(message (mu-message-create))
	110	(body (mu-message-get-port message "w")))
	111	(mu-message-set-header message
	112	"Content-Type"
	113	"text/plain; charset=utf-8")
	114	(put-bytevector body (string->utf8 text))
	115	(newline body)
	116	(close-port body)
	117	(mu-mime-add-part mime message)
	118
	119	(when file
	120	(attach-file! mime
	121	(call-with-input-file file get-bytevector-all)
	122	#:file-mime-type file-mime-type
	123	#:binary-file? binary-file?
	124	#:inline-file? inline-file?))
	125
	126	(when sign?
	127	(let* ((pid output input (pipe-pair `("gpg" "-ab" ,@gpg-arguments)))
	128	(body (mu-message-get-port message "r" #t)))
	129	(dump-port/convert-newlines body output)
	130	(close-port output)
	131	(let ((signature (get-bytevector-all input)))
	132	(close-port input)
	133	(match (waitpid pid)
	134	((_ . 0) #t)
	135	((_ . status) (error "failed to sign message body" status)))
	136
	137	(attach-file! mime signature
	138	#:file-mime-type "application/pgp-signature"
	139	#:binary-file? #f
	140	#:inline-file? #f))))
	141
	142	(let ((result (mu-mime-get-message mime)))
	143	(mu-message-set-header result "From" from)
	144	(mu-message-set-header result "To" to)
	145	(when subject
	146	(mu-message-set-header result "Subject" subject))
	147	(when reply-to
	148	(mu-message-set-header result "Reply-To" reply-to))
	149	(when user-agent
	150	(mu-message-set-header result "User-Agent" user-agent))
	151	(when sign?
	152	(set-multipart/signed-content-type! result))
	153	result)))
	154
	155	(define (set-multipart/signed-content-type! message)
	156	(let ((content-type (mu-message-get-header message "Content-Type"))
	157	(mixed "multipart/mixed; "))
	158	(when (string-prefix? mixed content-type)
	159	(mu-message-set-header message "Content-Type"
	160	(string-append
	161	"multipart/signed; "
	162	(string-drop content-type
	163	(string-length mixed))
	164	"; micalg=pgp-sha256; "
	165	"protocol=\"application/pgp-signature\"")
	166	#t))))
	167
	168	(define (display-body message) ;debug
	169	(let ((port (mu-message-get-port message "r")))
	170	(dump-port port (current-error-port))
	171	(close-port port)))
	172
	173	(define (send-message message)
	174	"Send MESSAGE, a message returned by 'compose-message', using the SMTP
	175	parameters found in ~/.config/smtp."
	176	(define uri
	177	;; Something like "smtp://USER:SECRET@SERVER:PORT" (info "(mailutils)
	178	;; SMTP Mailboxes").
	179	(call-with-input-file (string-append (getenv "HOME") "/.config/smtp")
	180	read))
	181
	182	(mu-register-format "smtp")
	183	(mu-message-send message uri))
	184
	185	;; FIXME: This returns an empty message.
	186	;; (define (set-message-recipient message to)
	187	;; "Return a copy of MESSAGE with TO as its recipient."
	188	;; (let ((message (mu-message-copy message)))
	189	;; (mu-message-set-header message "To" to #t)
	190	;; 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 @@
	1	;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
	2	;;;
	3	;;; This program is free software; you can redistribute it and/or modify it
	4	;;; under the terms of the GNU General Public License as published by
	5	;;; the Free Software Foundation; either version 3 of the License, or (at
	6	;;; your option) any later version.
	7	;;;
	8	;;; This program is distributed in the hope that it will be useful, but
	9	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	10	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	;;; GNU General Public License for more details.
	12	;;;
	13	;;; You should have received a copy of the GNU General Public License
	14	;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
	15
	16	(define-module (maintainers)
	17	#:use-module (guix records)
	18	#:use-module (ssh popen)
	19	#:use-module ((ssh session) #:select (disconnect!))
	20	#:use-module (guix ssh)
	21	#:use-module (srfi srfi-9)
	22	#:export (maintainer?
	23	maintainer-name
	24	maintainer-address
	25	maintainer-packages
	26
	27	maintainer-collective?
	28	read-maintainers
	29	read-maintainers-from-fencepost))
	30
	31	(define-record-type <maintainer>
	32	(maintainer name address packages)
	33	maintainer?
	34	(name maintainer-name)
	35	(address maintainer-address)
	36	(packages maintainer-packages))
	37
	38	(define (maintainer-collective? maintainer)
	39	(or (string-suffix? "maintainers@gnu.org" (maintainer-address maintainer))
	40	(string-suffix? " maintainers" (maintainer-name maintainer))
	41	(string-suffix? " committee" (maintainer-name maintainer))))
	42
	43	(define (read-maintainers port)
	44	"Read from PORT recutils-formatted info about GNU maintainers, and return a
	45	list of <maintainer> records."
	46	(define (read-one port)
	47	(alist->record (recutils->alist port)
	48	maintainer
	49	'("name" "email" "package")
	50	'("package")))
	51
	52	(let loop ((result '()))
	53	(if (eof-object? (peek-char port))
	54	(reverse result)
	55	(let ((maintainer (read-one port)))
	56	(loop (if (and (maintainer-name maintainer)
	57	(maintainer-address maintainer))
	58	(cons maintainer result)
	59	result))))))
	60
	61	(define (read-maintainers-from-fencepost)
	62	(let* ((session (open-ssh-session "fencepost.gnu.org"))
	63	(pipe (open-remote-pipe* session OPEN_READ
	64	"cat" "/gd/gnuorg/maintainers"))
	65	(maintainers (read-maintainers pipe)))
	66	(close-port pipe)
	67	(disconnect! session)
	68	maintainers))