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