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