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