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