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