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