cba4896cd31a95d520307944e1acb4c7e4070b3d
[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 (ice-9 threads)
29 #:use-module (email email)
30 #:use-module (mumi cache)
31 #:use-module (mumi config)
32 #:use-module (mumi debbugs)
33 #:use-module (mumi xapian)
34 #:use-module ((mumi bugs) #:prefix db:)
35 #:use-module (web client)
36 #:export (search-bugs
37 fetch-bug
38 recent-bugs
39 forgotten-issues
40 easy-bugs
41 wishlist-bugs
42 bugs-by-severity
43
44 multipart-message?
45 extract-attachment
46
47 extract-name
48 extract-email
49 sender
50 sender-email
51 sender-name
52 date
53 subject
54 message-id
55 participants
56 recipients
57 closing?
58 bot?
59 internal-message?
60
61 issue-messages
62 process-query))
63
64 (define (status-with-cache ids)
65 "Invoke GET-STATUS, but only on those IDS that have not been cached
66 yet. Return new results alongside cached results."
67 (let* ((cached (filter-map cached? ids))
68 (uncached-ids (lset-difference eq?
69 ids
70 (map bug-num cached)))
71 (new (filter-map bug-status uncached-ids )))
72 ;; Cache new things
73 (map (lambda (bug) (cache! (bug-num bug) bug)) new)
74 ;; Return everything from cache
75 (sort (append cached new) (lambda (a b) (< (bug-num a) (bug-num b))))))
76
77 (define (extract-name address)
78 (or (assoc-ref address 'name)
79 (and=> (assoc-ref address 'address)
80 (lambda (address)
81 (string-take address (string-index address #\@))))
82 "Somebody"))
83
84 (define (extract-email address)
85 (assoc-ref address 'address))
86
87 (define (header message key)
88 (assoc-ref (or (email-headers message) '()) key))
89
90 (define (sender message)
91 (or (and=> (header message 'from) first)
92 '((name . "Unknown sender")
93 (address . "unknown"))))
94
95 (define sender-email
96 (compose extract-email sender))
97
98 (define (sender-name message)
99 (extract-name (sender message)))
100
101 (define (date message)
102 (or (header message 'date) "unknown date"))
103
104 (define (subject message)
105 (or (header message 'subject) "(no subject)"))
106
107 (define (message-id message)
108 (header message 'message-id))
109
110 (define (participants messages)
111 "Return a list of unique senders in the conversion."
112 (apply lset-adjoin (lambda (a b)
113 (string= (extract-email a)
114 (extract-email b)))
115 '() (map sender messages)))
116
117 (define (recipients message)
118 "Return a list of recipient email addresses for the given MESSAGE."
119 (let ((headers (or (email-headers message) '())))
120 (filter-map (match-lambda
121 (((or 'cc 'bcc 'to) val) val)
122 (_ #f)) headers)))
123
124 (define (closing? message id)
125 "Is this MESSAGE closing this bug ID?"
126 (let ((done (string-append (number->string id)
127 "-done")))
128 (and=> (header message 'x-debbugs-envelope-to)
129 (cut string= <> done))))
130
131 (define (bot? address)
132 (string= "help-debbugs@gnu.org" address))
133
134 (define (internal-message? message)
135 (bot? (sender-email message)))
136
137 \f
138 (define (multipart-message? message)
139 (eq? (assoc-ref (header message 'content-type)
140 'type)
141 'multipart))
142
143 (define (extract-attachment id msg-num path)
144 "Extract attachment from message number MSG-NUM in the thread for
145 the bug with the given ID. Follow PATH to get to the correct
146 multipart chunk containing the attachment. This is absolutely
147 horrible because Debbugs does not let us access messages directly, so
148 we have to do this in a very convoluted way."
149 (define (nth n lst)
150 (and (< n (length lst))
151 (list-ref lst n)))
152 (define (traverse path parts)
153 (let loop ((path path)
154 (parts parts))
155 (match path
156 ((pos) (nth pos parts))
157 ((pos . rest)
158 (loop rest
159 (and=> (nth pos parts)
160 mime-entity-body))))))
161 (and=> (nth msg-num (issue-messages id))
162 (lambda (msg)
163 (cond
164 ((multipart-message? msg)
165 (traverse path (email-body msg)))
166 (else
167 (match path
168 (() msg)
169 (_ #f)))))))
170
171 \f
172 ;; We would like to use get-bug-log here, but it often returns
173 ;; truncated messages. This is a known bug upstream.
174 (define (issue-messages bug-id)
175 "Return list of messages relating to the issue BUG-ID. Cache the
176 result for a while."
177 (define archived-log
178 (bug-id->log-file bug-id #:archived? #t))
179 (define active-log
180 (bug-id->log-file bug-id))
181 (define file
182 (or (and (file-exists? archived-log) archived-log)
183 (and (file-exists? active-log) active-log)))
184 (if file
185 (let ((key (list 'issue-messages bug-id)))
186 (or (cached? key)
187 (cache! key
188 (call-with-input-file file
189 read-emails-from-bug-log))))
190 '()))
191
192 (define* (search-bugs query #:key (sets '()) (max 400))
193 "Return a list of all bugs matching the given QUERY string.
194 Intersect the result with the id sets in the list SETS."
195 (let* ((ids (delete-duplicates
196 (map string->number
197 (search query))))
198 (filtered (match sets
199 (() ids)
200 (_ (apply lset-intersection eq? ids sets)))))
201 (status-with-cache (if (> (length filtered) max)
202 (take filtered max) filtered))))
203
204 (define fetch-bug bug-status)
205
206 (define (recent-bugs amount)
207 "Return up to AMOUNT bugs with most recent activity."
208 (let* ((recent-ids
209 (sort
210 (delete-duplicates
211 (map string->number
212 (search "mdate:1m..")))
213 <))
214 (ids (take (reverse recent-ids)
215 (min amount (length recent-ids)))))
216 (status-with-cache ids)))
217
218 (define (forgotten-issues amount)
219 "Return up to AMOUNT issues that appear to have been forgotten
220 about."
221 (let* ((forgotten-ids (forgotten-bug-numbers (%config 'packages)))
222 (ids (take (reverse forgotten-ids)
223 (min amount (length forgotten-ids)))))
224 (status-with-cache ids)))
225
226 (define (easy-bugs)
227 "Return all bugs that have been tagged \"easy\"."
228 (let ((ids (db:bugs-by-tag "easy")))
229 (status-with-cache ids)))
230
231 (define (wishlist-bugs)
232 "Return all bugs that have been tagged \"wishlist\"."
233 (let ((ids (db:bugs-by-tag "wishlist")))
234 (status-with-cache ids)))
235
236 (define* (bugs-by-severity severity #:optional status)
237 "Return severe bugs."
238 (let* ((severity-ids (db:bugs-by-severity severity))
239 (ids (if status
240 (let ((status-ids (db:bugs-by-status status)))
241 (lset-intersection eq? severity-ids status-ids))
242 severity-ids)))
243 (status-with-cache ids)))
244
245 (define punctuation?
246 (cut char-set-contains? char-set:punctuation <>))
247
248 (define (process-query query)
249 "Process the QUERY string and return a list of query terms and
250 sets that need to overlap the result set."
251 ;; Xapian doesn't like punctuation. Replace with spaces. Leave
252 ;; hyphens and quotes.
253 (define (clean-term term)
254 (string-map (match-lambda
255 ((and (or #\" #\-) c) c)
256 ((? punctuation? c) #\space)
257 (c c))
258 term))
259 (fold (lambda (term acc)
260 (match acc
261 ((#:terms terms
262 #:sets fs)
263 (match (string-split term #\:)
264 (("is" (or "done" "closed"))
265 `(#:terms ,terms
266 #:sets ,(cons (db:bugs-by-status "done") fs)))
267 (("is" (or "open" "pending"))
268 `(#:terms ,terms
269 #:sets ,(cons (db:bugs-by-status "open") fs)))
270 (("date" when)
271 `(#:terms ,(cons (string-append "date:" when) terms)
272 #:sets ,fs))
273 ;; TODO: this should only be the title of the bug, not
274 ;; the subject.
275 (("title" title)
276 `(#:terms
277 ,(cons (string-append "subject:" (clean-term title))
278 terms)
279 #:sets ,fs))
280 (("subject" subject)
281 `(#:terms
282 ,(cons (string-append "subject:" (clean-term subject))
283 terms)
284 #:sets ,fs))
285 (("tag" tag)
286 `(#:terms ,terms
287 #:sets
288 ,(cons (db:bugs-by-tag (clean-term tag)) fs)))
289 (("author" who)
290 `(#:terms
291 ,(cons (string-append "from:" (clean-term who)) terms)
292 #:sets ,fs))
293 (("owner" who)
294 `(#:terms ,terms
295 #:sets ,(cons (db:bugs-by-owner who) fs)))
296 (("submitter" who)
297 `(#:terms ,(cons (string-append "submitter:" who) terms)
298 #:sets ,fs))
299 (("severity" level)
300 `(#:terms ,terms
301 #:sets ,(cons (db:bugs-by-severity level) fs)))
302 ((whatever term)
303 `(#:terms ,(cons (clean-term term) terms)
304 #:sets ,fs))
305 (_
306 `(#:terms ,(cons (clean-term term) terms)
307 #:sets ,fs))))))
308 '(#:terms () #:sets ())
309 (tokenize query)))