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