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