summaryrefslogtreecommitdiffstats
path: root/code
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-01-26 22:53:10 +0100
committerLudovic Courtès <ludo@gnu.org>2020-01-27 14:48:42 +0100
commitb71c7cc8dc2b80cbb13888e8793c058c03fbe0e4 (patch)
tree221c386a9f43ff663805b2cf5eb69d93d3e0b313 /code
parentsc-email: Replace placeholders with URLs and email addresses. (diff)
Add supporting code: (email) and (maintainers).
* code/modules/email.scm, code/modules/maintainers.scm: New files.
Diffstat (limited to '')
-rw-r--r--code/modules/email.scm190
-rw-r--r--code/modules/maintainers.scm68
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 @@
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
32output port to write on COMMAND's standard input, and an input port to read
33COMMAND'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
175parameters 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
45list 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))