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