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