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