messages: Close port after downloading mail.
[software/mumi.git] / mumi / messages.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Affero General Public License
7 ;;; as published by the Free Software Foundation, either version 3 of
8 ;;; the License, or (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Affero General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Affero General Public
16 ;;; License along with this program. If not, see
17 ;;; <http://www.gnu.org/licenses/>.
18
19 (define-module (mumi messages)
20 #:use-module (srfi srfi-1)
21 #:use-module (srfi srfi-19)
22 #:use-module (srfi srfi-26)
23 #:use-module (ice-9 optargs)
24 #:use-module (ice-9 regex)
25 #:use-module (ice-9 match)
26 #:use-module (ice-9 textual-ports)
27 #:use-module (ice-9 binary-ports)
28 #:use-module (debbugs cache)
29 #:use-module (debbugs soap)
30 #:use-module (debbugs operations)
31 #:use-module (debbugs bug)
32 #:use-module (email email)
33 #:use-module (mumi config)
34 #:use-module (mumimu)
35 #:export (search-bugs
36 fetch-bug
37 recent-bugs
38 easy-bugs
39 bugs-by-severity
40
41 download-message
42
43 multipart-message?
44 extract-attachment))
45
46 (define (status-with-cache ids)
47 "Invoke GET-STATUS, but only on those IDS that have not been cached
48 yet. Return new results alongside cached results."
49 (let* ((cached (filter-map cached? ids))
50 (uncached-ids (lset-difference eq?
51 ids
52 (map bug-num cached)))
53 (new (soap-invoke* (%config 'debbugs) get-status uncached-ids)))
54 ;; Cache new things
55 (map (lambda (bug) (cache! (bug-num bug) bug)) new)
56 ;; Return everything from cache
57 (sort (append cached new) (lambda (a b) (< (bug-num a) (bug-num b))))))
58
59 (define-public (extract-name address)
60 (or (assoc-ref address 'name)
61 (and=> (assoc-ref address 'address)
62 (lambda (address)
63 (string-take address (string-index address #\@))))
64 "Somebody"))
65
66 (define-public (extract-email address)
67 (assoc-ref address 'address))
68
69 (define (header message key)
70 (assoc-ref (email-headers message) key))
71
72 (define-public (sender message)
73 (first (header message 'from)))
74
75 (define-public sender-email
76 (compose extract-email sender))
77
78 (define-public (sender-name message)
79 (extract-name (sender message)))
80
81 (define-public (date message)
82 (header message 'date))
83
84 (define-public (subject message)
85 (or (header message 'subject) "(no subject)"))
86
87 (define-public (message-id message)
88 (header message 'message-id))
89
90 (define-public (participants messages)
91 "Return a list of unique senders in the conversion."
92 (apply lset-adjoin (lambda (a b)
93 (string= (extract-email a)
94 (extract-email b)))
95 '() (map sender messages)))
96
97 (define-public (recipients message)
98 "Return a list of recipient email addresses for the given MESSAGE."
99 (let ((headers (email-headers message)))
100 (filter-map (match-lambda
101 (((or 'cc 'bcc 'to) val) val)
102 (_ #f)) headers)))
103
104 (define-public (closing? message id)
105 "Is this MESSAGE closing this bug ID?"
106 (let ((done (string-append (number->string id)
107 "-done")))
108 (string= (header message 'x-debbugs-envelope-to) done)))
109
110 (define-public (bot? address)
111 (string= "help-debbugs@gnu.org" address))
112
113 (define-public (internal-message? message)
114 (bot? (sender-email message)))
115
116 \f
117 (define (multipart-message? message)
118 (eq? (assoc-ref (header message 'content-type)
119 'type)
120 'multipart))
121
122 (define (extract-attachment id msg-num path)
123 "Extract attachment from message number MSG-NUM in the thread for
124 the bug with the given ID. Follow PATH to get to the correct
125 multipart chunk containing the attachment. This is absolutely
126 horrible because Debbugs does not let us access messages directly, so
127 we have to do this in a very convoluted way."
128 (define (nth n lst)
129 (and (< n (length lst))
130 (list-ref lst n)))
131 (define (traverse path parts)
132 (let loop ((path path)
133 (parts parts))
134 (match path
135 ((pos) (nth pos parts))
136 ((pos . rest)
137 (loop rest
138 (and=> (nth pos parts)
139 mime-entity-body))))))
140 (and=> (fetch-bug id)
141 (lambda (bug)
142 (and=> (nth msg-num (patch-messages id))
143 (lambda (msg)
144 (cond
145 ((multipart-message? msg)
146 (traverse path (email-body msg)))
147 (else
148 (match path
149 (() msg)
150 (_ #f)))))))))
151
152 \f
153 (define (download-message bug-id msg-num)
154 "Download message number MSG-NUM of bug BUG-ID and store it in the
155 mail directory if it's not already there. Return the name of the
156 target file."
157 (let ((key (list 'download-message bug-id msg-num)))
158 (or (cached? key)
159 (cache! key
160 (let ((file-name (format #f "~a/cur/~a-~a"
161 (%config 'mail-dir)
162 bug-id msg-num)))
163 (if (file-exists? file-name) file-name
164 (begin
165 (format (current-error-port)
166 "downloading ~a~%" file-name)
167 (call-with-values
168 (lambda ()
169 (fetch-mbox (%config 'debbugs)
170 bug-id msg-num #:streaming? #t))
171 (lambda (response port)
172 (with-output-to-file file-name
173 (lambda ()
174 (put-bytevector (current-output-port)
175 (get-bytevector-all port))))
176 (close-port port)))
177 file-name)))))))
178
179 ;; We would like to use get-bug-log here, but it often returns
180 ;; truncated messages. This is a known bug upstream.
181 (define-public (patch-messages bug-id)
182 "Return list of messages relating to the bug BUG-ID. Cache the
183 result for a while."
184 (let ((key (list 'patch-messages bug-id)))
185 (or (cached? key)
186 (cache! key
187 (match
188 (soap-invoke* (%config 'debbugs) get-bug-message-numbers bug-id)
189 ((msg-nums . _)
190 (map (lambda (msg-num)
191 (with-input-from-file (download-message bug-id msg-num)
192 (lambda ()
193 (match (mbox->emails (current-input-port))
194 ((email) (parse-email email))
195 (_ #f)))))
196 msg-nums)))))))
197
198 (define* (search-bugs query #:key (attributes '()) (max 100))
199 "Return a list of all bugs matching the given QUERY string."
200 (let* ((matches (soap-invoke* (%config 'debbugs)
201 search-est
202 query
203 #:max max
204 #:attributes
205 (append attributes
206 '((package string-prefix "guix")))))
207 (ids (filter-map (lambda (item)
208 (assoc-ref item "id"))
209 matches)))
210 (status-with-cache ids)))
211
212 ;; TODO: This returns *any* matching debbugs bug, even if it is not
213 ;; part of the default packages.
214 (define (fetch-bug id)
215 "Return the bug matching ID or #F."
216 (match (soap-invoke* (%config 'debbugs) get-status (list id))
217 (() #f)
218 ((bug) bug)))
219
220 (define (recent-bugs amount)
221 "Return up to AMOUNT bugs with most recent activity."
222 (let* ((recent-ids
223 (delete-duplicates
224 (map mu:bugid (mu:message-list (string-append "date:1m..")))))
225 (ids (take recent-ids (min amount (length recent-ids)))))
226 (status-with-cache ids)))
227
228 (define (easy-bugs)
229 "Return all bugs that have been tagged \"easy\"."
230 (let ((ids
231 (soap-invoke* (%config 'debbugs)
232 get-bugs
233 '((package . "guix") (tag . "easy")))))
234 (status-with-cache ids)))
235
236 (define* (bugs-by-severity severity #:optional status)
237 "Return severe bugs."
238 (let* ((ids
239 (soap-invoke* (%config 'debbugs)
240 get-bugs
241 `((package . "guix")
242 (severity . ,severity)
243 ,@(if status `((status . ,status)) '())))))
244 (status-with-cache ids)))
245
246 (define (ago unit amount)
247 "Return the point in time that lies AMOUNT UNITs in the past."
248 (let ((amount* (match unit
249 ('hours amount)
250 ('days (* 24 amount))
251 ('weeks (* 24 7 amount))
252 ('months (* 24 30 amount))
253 ('years (* 24 365 amount)))))
254 (subtract-duration (date->time-utc (current-date))
255 (make-time time-duration 0 (* 60 60 amount*)))))
256
257 (define (date-term->epoch-seconds term)
258 "Convert a date search term string into seconds since the epoch, or
259 return #F if the term is invalid."
260 (match term
261 ("now" 'now)
262 ("today" (time-second (ago 'days 1)))
263 ("yesterday" (time-second (ago 'days 2)))
264 (_
265 (cond
266 ;; TODO: support more date template strings
267 ((or (false-if-exception (string->date term "~Y~m~d"))
268 (false-if-exception (string->date term "~Y-~m-~d")))
269 => (lambda (date)
270 (time-second (date->time-utc date))))
271 ;; e.g. "12h" meaning "12 hours ago"
272 ((string->number (string-drop-right term 1))
273 => (lambda (amount)
274 (match (string-take-right term 1)
275 ("h"
276 (time-second (ago 'hours amount)))
277 ("d"
278 (time-second (ago 'days amount)))
279 ("w"
280 (time-second (ago 'weeks amount)))
281 ("m"
282 (time-second (ago 'months amount)))
283 ("y"
284 (time-second (ago 'years amount)))
285 (_ #f))))
286 (else #f)))))
287
288 (define-public (process-query query)
289 "Process the QUERY string and return two values: the remaining
290 unprocessed query string and an alist of search attributes."
291 (fold (lambda (term acc)
292 (match acc
293 ((#:terms terms
294 #:attributes attrs
295 #:filters fs)
296 (match (string-split term #\:)
297 ;; This is not supported by the Debbugs SOAP service,
298 ;; so we filter locally.
299 (("is" (or "done" "closed"))
300 `(#:terms ,terms
301 #:attributes ,attrs
302 #:filters
303 ,(cons bug-done fs)))
304 (("is" (or "open" "pending"))
305 `(#:terms ,terms
306 #:attributes ,attrs
307 #:filters
308 ,(cons (negate bug-done) fs)))
309 ;; "date" for submission date, "mdate" for message date.
310 (((and (or "date" "mdate") type) when)
311 (let ((date-attribute (match type
312 ("date" 'date)
313 ("mdate" '@cdate)))
314 (pat "(yesterday|today|now|[1-9][0-9]*(h|d|w|m|y)|[0-9]+)"))
315 (or (match (map (compose date-term->epoch-seconds
316 match:substring)
317 (list-matches pat when))
318 ((and ((? number? start)
319 (? number? end))
320 range)
321 (match (sort range <)
322 ((start end)
323 `(#:terms ,terms
324 #:attributes ,(cons `(,date-attribute >< ,start ,end) attrs)
325 #:filters ,fs))))
326 ((or ('now (? number? since))
327 ((? number? since) 'now))
328 `(#:terms ,terms
329 #:attributes ,(cons `(,date-attribute > ,since) attrs)
330 #:filters ,fs))
331 (_ #f))
332 ;; Invalid, don't do anything.
333 `(#:terms ,terms
334 #:attributes ,attrs
335 #:filters ,fs))))
336 (("title" title)
337 `(#:terms ,terms
338 #:attributes ,(cons `(subject string-contains ,title) attrs)
339 #:filters ,fs))
340 (("tag" tag)
341 `(#:terms ,terms
342 #:attributes ,(cons `(tags string= ,tag) attrs)
343 #:filters ,fs))
344 (("author" who)
345 `(#:terms ,terms
346 #:attributes ,(cons `(@author string-contains ,who) attrs)
347 #:filters ,fs))
348 ;; This is not supported by the Debbugs SOAP service,
349 ;; so we filter locally. At least we know that we need
350 ;; bugs where the author is "who".
351 (("submitter" who)
352 `(#:terms ,terms
353 #:attributes ,(cons `(@author string-contains ,who) attrs)
354 #:filters ,(cons (lambda (bug)
355 (string-contains-ci (bug-originator bug)
356 who))
357 fs)))
358 (("severity" level)
359 `(#:terms ,terms
360 #:attributes ,(cons `(severity string= ,level) attrs)
361 #:filters ,fs))
362 (_
363 `(#:terms ,(cons term terms)
364 #:attributes ,attrs
365 #:filters ,fs))))))
366 '(#:terms () #:attributes () #:filters ())
367 (string-tokenize query)))