da6821232ec0df75586f202b0d18474d0f1e3dd0
[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 (or (email-headers message) '()) key))
72
73 (define-public (sender message)
74 (or (and=> (header message 'from) first)
75 "unknown sender"))
76
77 (define-public sender-email
78 (compose extract-email sender))
79
80 (define-public (sender-name message)
81 (extract-name (sender message)))
82
83 (define-public (date message)
84 (or (header message 'date) "unknown date"))
85
86 (define-public (subject message)
87 (or (header message 'subject) "(no subject)"))
88
89 (define-public (message-id message)
90 (header message 'message-id))
91
92 (define-public (participants messages)
93 "Return a list of unique senders in the conversion."
94 (apply lset-adjoin (lambda (a b)
95 (string= (extract-email a)
96 (extract-email b)))
97 '() (map sender messages)))
98
99 (define-public (recipients message)
100 "Return a list of recipient email addresses for the given MESSAGE."
101 (let ((headers (or (email-headers message) '())))
102 (filter-map (match-lambda
103 (((or 'cc 'bcc 'to) val) val)
104 (_ #f)) headers)))
105
106 (define-public (closing? message id)
107 "Is this MESSAGE closing this bug ID?"
108 (let ((done (string-append (number->string id)
109 "-done")))
110 (string= (header message 'x-debbugs-envelope-to) done)))
111
112 (define-public (bot? address)
113 (string= "help-debbugs@gnu.org" address))
114
115 (define-public (internal-message? message)
116 (bot? (sender-email message)))
117
118 \f
119 (define (multipart-message? message)
120 (eq? (assoc-ref (header message 'content-type)
121 'type)
122 'multipart))
123
124 (define (extract-attachment id msg-num path)
125 "Extract attachment from message number MSG-NUM in the thread for
126 the bug with the given ID. Follow PATH to get to the correct
127 multipart chunk containing the attachment. This is absolutely
128 horrible because Debbugs does not let us access messages directly, so
129 we have to do this in a very convoluted way."
130 (define (nth n lst)
131 (and (< n (length lst))
132 (list-ref lst n)))
133 (define (traverse path parts)
134 (let loop ((path path)
135 (parts parts))
136 (match path
137 ((pos) (nth pos parts))
138 ((pos . rest)
139 (loop rest
140 (and=> (nth pos parts)
141 mime-entity-body))))))
142 (and=> (fetch-bug id)
143 (lambda (bug)
144 (and=> (nth msg-num (patch-messages id))
145 (lambda (msg)
146 (cond
147 ((multipart-message? msg)
148 (traverse path (email-body msg)))
149 (else
150 (match path
151 (() msg)
152 (_ #f)))))))))
153
154 \f
155 (define (download-message bug-id msg-num)
156 "Download message number MSG-NUM of bug BUG-ID and store it in the
157 mail directory if it's not already there. Return the name of the
158 target file."
159 (let ((key (list 'download-message bug-id msg-num)))
160 (or (cached? key)
161 (cache! key
162 (let ((file-name (format #f "~a/cur/~a-~a"
163 (%config 'mail-dir)
164 bug-id msg-num)))
165 (if (file-exists? file-name) file-name
166 (begin
167 (format (current-error-port)
168 "downloading ~a~%" file-name)
169 (call-with-values
170 (lambda ()
171 (fetch-mbox (%config 'debbugs)
172 bug-id msg-num #:streaming? #t))
173 (lambda (response port)
174 (with-output-to-file file-name
175 (lambda ()
176 (put-bytevector (current-output-port)
177 (get-bytevector-all port))))
178 (close-port port)))
179 file-name)))))))
180
181 ;; We would like to use get-bug-log here, but it often returns
182 ;; truncated messages. This is a known bug upstream.
183 (define-public (patch-messages bug-id)
184 "Return list of messages relating to the bug BUG-ID. Cache the
185 result for a while."
186 (let ((key (list 'patch-messages bug-id)))
187 (or (cached? key)
188 (cache! key
189 (map (lambda (msg)
190 (with-input-from-file (mu:path msg)
191 (lambda ()
192 (match (mbox->emails (current-input-port))
193 ((email) (parse-email email))
194 (_ #f)))))
195 (mu:message-list (format #f "bugid:~a" bug-id)))))))
196
197 (define* (search-bugs query #:key (sets '()) (max 100))
198 "Return a list of all bugs matching the given QUERY string.
199 Interset the result with the id sets in the list SETS."
200 (let* ((ids (delete-duplicates
201 (map (compose string->number mu:bugid)
202 (mu:message-list query))))
203 (filtered (match sets
204 (() ids)
205 (_ (apply lset-intersection eq? ids sets)))))
206 (status-with-cache (if (> (length filtered) max)
207 (take filtered max) filtered))))
208
209 ;; TODO: This returns *any* matching debbugs bug, even if it is not
210 ;; part of the default packages.
211 (define (fetch-bug id)
212 "Return the bug matching ID or #F."
213 (match (soap-invoke* (%config 'debbugs) get-status (list id))
214 (() #f)
215 ((bug) bug)))
216
217 (define (recent-bugs amount)
218 "Return up to AMOUNT bugs with most recent activity."
219 (let* ((recent-ids
220 (sort
221 (delete-duplicates
222 (map (compose string->number mu:bugid)
223 (mu:message-list (string-append "date:1m.."))))
224 <))
225 (ids (take (reverse recent-ids)
226 (min amount (length recent-ids)))))
227 (status-with-cache ids)))
228
229 (define (easy-bugs)
230 "Return all bugs that have been tagged \"easy\"."
231 (let ((ids (db:bugs-by-tag "easy")))
232 (status-with-cache ids)))
233
234 (define* (bugs-by-severity severity #:optional status)
235 "Return severe bugs."
236 (let* ((severity-ids (db:bugs-by-severity severity))
237 (ids (if status
238 (let ((status-ids (db:bugs-by-status status)))
239 (lset-intersection eq? severity-ids status-ids))
240 severity-ids)))
241 (status-with-cache ids)))
242
243 (define punctuation?
244 (cut char-set-contains? char-set:punctuation <>))
245
246 (define-public (process-query query)
247 "Process the QUERY string and return a list of query terms and
248 sets that need to overlap the result set."
249 ;; Mu doesn't like punctuation. Replace with spaces.
250 (define (clean-term term)
251 (string-map (match-lambda
252 ((? punctuation? c) #\space)
253 (c c))
254 term))
255 (fold (lambda (term acc)
256 (match acc
257 ((#:terms terms
258 #:sets fs)
259 (match (string-split term #\:)
260 ;; This is not supported by the Debbugs SOAP service,
261 ;; so we filter locally.
262 (("is" (or "done" "closed"))
263 `(#:terms ,terms
264 #:sets ,(cons (db:bugs-by-status "done") fs)))
265 (("is" (or "open" "pending"))
266 `(#:terms ,terms
267 #:sets ,(cons (db:bugs-by-status "open") fs)))
268 (("date" when)
269 `(#:terms ,(cons (string-append "date:" when) terms)
270 #:sets ,fs))
271 ;; TODO: this should only be the title of the bug, not
272 ;; the subject.
273 (("title" title)
274 `(#:terms
275 ,(cons (string-append "subject:" (clean-term title))
276 terms)
277 #:sets ,fs))
278 (("subject" subject)
279 `(#:terms
280 ,(cons (string-append "subject:" (clean-term subject))
281 terms)
282 #:sets ,fs))
283 (("tag" tag)
284 `(#:terms ,terms
285 #:sets
286 ,(cons (db:bugs-by-tag (clean-term tag)) fs)))
287 (("author" who)
288 `(#:terms
289 ,(cons (string-append "from:" (clean-term who)) terms)
290 #:sets ,fs))
291 (("owner" who)
292 `(#:terms ,terms
293 #:sets ,(cons (db:bugs-by-owner who) fs)))
294 (("submitter" who)
295 `(#:terms ,terms
296 #:sets ,(cons (db:bugs-by-submitter who) fs)))
297 (("severity" level)
298 `(#:terms ,terms
299 #:sets ,(cons (db:bugs-by-severity level) fs)))
300 ((whatever term)
301 `(#:terms ,(cons (clean-term term) terms)
302 #:sets ,fs))
303 (_
304 `(#:terms ,(cons (clean-term term) terms)
305 #:sets ,fs))))))
306 '(#:terms () #:sets ())
307 (string-tokenize query)))