messages: Speed up recent-bugs by using mumimu.
[software/mumi.git] / mumi / messages.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2017, 2018, 2019 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 file-name)))))))
177
178 ;; We would like to use get-bug-log here, but it often returns
179 ;; truncated messages. This is a known bug upstream.
180 (define-public (patch-messages bug-id)
181 "Return list of messages relating to the bug BUG-ID. Cache the
182 result for a while."
183 (let ((key (list 'patch-messages bug-id)))
184 (or (cached? key)
185 (cache! key
186 (match
187 (soap-invoke* (%config 'debbugs) get-bug-message-numbers bug-id)
188 ((msg-nums . _)
189 (map (lambda (msg-num)
190 (with-input-from-file (download-message bug-id msg-num)
191 (lambda ()
192 (match (mbox->emails (current-input-port))
193 ((email) (parse-email email))
194 (_ #f)))))
195 msg-nums)))))))
196
197 (define* (search-bugs query #:key (attributes '()) (max 100))
198 "Return a list of all bugs matching the given QUERY string."
199 (let* ((matches (soap-invoke* (%config 'debbugs)
200 search-est
201 query
202 #:max max
203 #:attributes
204 (append attributes
205 '((package string-prefix "guix")))))
206 (ids (filter-map (lambda (item)
207 (assoc-ref item "id"))
208 matches)))
209 (status-with-cache ids)))
210
211 ;; TODO: This returns *any* matching debbugs bug, even if it is not
212 ;; part of the default packages.
213 (define (fetch-bug id)
214 "Return the bug matching ID or #F."
215 (match (soap-invoke* (%config 'debbugs) get-status (list id))
216 (() #f)
217 ((bug) bug)))
218
219 (define (recent-bugs amount)
220 "Return up to AMOUNT bugs with most recent activity."
221 (let* ((recent-ids
222 (delete-duplicates
223 (map mu:bugid (mu:message-list (string-append "date:1m..")))))
224 (ids (take recent-ids (min amount (length recent-ids)))))
225 (status-with-cache ids)))
226
227 (define (easy-bugs)
228 "Return all bugs that have been tagged \"easy\"."
229 (let ((ids
230 (soap-invoke* (%config 'debbugs)
231 get-bugs
232 '((package . "guix") (tag . "easy")))))
233 (status-with-cache ids)))
234
235 (define* (bugs-by-severity severity #:optional status)
236 "Return severe bugs."
237 (let* ((ids
238 (soap-invoke* (%config 'debbugs)
239 get-bugs
240 `((package . "guix")
241 (severity . ,severity)
242 ,@(if status `((status . ,status)) '())))))
243 (status-with-cache ids)))
244
245 (define (ago unit amount)
246 "Return the point in time that lies AMOUNT UNITs in the past."
247 (let ((amount* (match unit
248 ('hours amount)
249 ('days (* 24 amount))
250 ('weeks (* 24 7 amount))
251 ('months (* 24 30 amount))
252 ('years (* 24 365 amount)))))
253 (subtract-duration (date->time-utc (current-date))
254 (make-time time-duration 0 (* 60 60 amount*)))))
255
256 (define (date-term->epoch-seconds term)
257 "Convert a date search term string into seconds since the epoch, or
258 return #F if the term is invalid."
259 (match term
260 ("now" 'now)
261 ("today" (time-second (ago 'days 1)))
262 ("yesterday" (time-second (ago 'days 2)))
263 (_
264 (cond
265 ;; TODO: support more date template strings
266 ((or (false-if-exception (string->date term "~Y~m~d"))
267 (false-if-exception (string->date term "~Y-~m-~d")))
268 => (lambda (date)
269 (time-second (date->time-utc date))))
270 ;; e.g. "12h" meaning "12 hours ago"
271 ((string->number (string-drop-right term 1))
272 => (lambda (amount)
273 (match (string-take-right term 1)
274 ("h"
275 (time-second (ago 'hours amount)))
276 ("d"
277 (time-second (ago 'days amount)))
278 ("w"
279 (time-second (ago 'weeks amount)))
280 ("m"
281 (time-second (ago 'months amount)))
282 ("y"
283 (time-second (ago 'years amount)))
284 (_ #f))))
285 (else #f)))))
286
287 (define-public (process-query query)
288 "Process the QUERY string and return two values: the remaining
289 unprocessed query string and an alist of search attributes."
290 (fold (lambda (term acc)
291 (match acc
292 ((#:terms terms
293 #:attributes attrs
294 #:filters fs)
295 (match (string-split term #\:)
296 ;; This is not supported by the Debbugs SOAP service,
297 ;; so we filter locally.
298 (("is" (or "done" "closed"))
299 `(#:terms ,terms
300 #:attributes ,attrs
301 #:filters
302 ,(cons bug-done fs)))
303 (("is" (or "open" "pending"))
304 `(#:terms ,terms
305 #:attributes ,attrs
306 #:filters
307 ,(cons (negate bug-done) fs)))
308 ;; "date" for submission date, "mdate" for message date.
309 (((and (or "date" "mdate") type) when)
310 (let ((date-attribute (match type
311 ("date" 'date)
312 ("mdate" '@cdate)))
313 (pat "(yesterday|today|now|[1-9][0-9]*(h|d|w|m|y)|[0-9]+)"))
314 (or (match (map (compose date-term->epoch-seconds
315 match:substring)
316 (list-matches pat when))
317 ((and ((? number? start)
318 (? number? end))
319 range)
320 (match (sort range <)
321 ((start end)
322 `(#:terms ,terms
323 #:attributes ,(cons `(,date-attribute >< ,start ,end) attrs)
324 #:filters ,fs))))
325 ((or ('now (? number? since))
326 ((? number? since) 'now))
327 `(#:terms ,terms
328 #:attributes ,(cons `(,date-attribute > ,since) attrs)
329 #:filters ,fs))
330 (_ #f))
331 ;; Invalid, don't do anything.
332 `(#:terms ,terms
333 #:attributes ,attrs
334 #:filters ,fs))))
335 (("title" title)
336 `(#:terms ,terms
337 #:attributes ,(cons `(subject string-contains ,title) attrs)
338 #:filters ,fs))
339 (("tag" tag)
340 `(#:terms ,terms
341 #:attributes ,(cons `(tags string= ,tag) attrs)
342 #:filters ,fs))
343 (("author" who)
344 `(#:terms ,terms
345 #:attributes ,(cons `(@author string-contains ,who) attrs)
346 #:filters ,fs))
347 ;; This is not supported by the Debbugs SOAP service,
348 ;; so we filter locally. At least we know that we need
349 ;; bugs where the author is "who".
350 (("submitter" who)
351 `(#:terms ,terms
352 #:attributes ,(cons `(@author string-contains ,who) attrs)
353 #:filters ,(cons (lambda (bug)
354 (string-contains-ci (bug-originator bug)
355 who))
356 fs)))
357 (("severity" level)
358 `(#:terms ,terms
359 #:attributes ,(cons `(severity string= ,level) attrs)
360 #:filters ,fs))
361 (_
362 `(#:terms ,(cons term terms)
363 #:attributes ,attrs
364 #:filters ,fs))))))
365 '(#:terms () #:attributes () #:filters ())
366 (string-tokenize query)))