1f6d4304419a7026a3ed55682ecc1b62eb98243a
[software/mumi.git] / mumi / debbugs.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Affero General Public License
6 ;;; as published by the Free Software Foundation, either version 3 of
7 ;;; the License, or (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Affero General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Affero General Public
15 ;;; License along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 (define-module (mumi debbugs)
19 #:use-module (mumi config)
20 #:use-module (mumi cache)
21 #:use-module (email email)
22 #:use-module (email quoted-printable)
23 #:use-module (rnrs bytevectors)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-2)
26 #:use-module (srfi srfi-9)
27 #:use-module (srfi srfi-11)
28 #:use-module (srfi srfi-19)
29 #:use-module (ice-9 match)
30 #:use-module (ice-9 rdelim)
31 #:use-module (ice-9 regex)
32 #:export (read-emails-from-bug-log
33 extract-bug-numbers
34 forgotten-bug-numbers
35 bug-id->log-file
36 bug-id->summary-file
37
38 bug-status
39 bug-status?
40
41 bug-num
42 bug-archived
43 bug-blockedby
44 bug-blocks
45 bug-date
46 bug-done
47 bug-mergedwith
48 bug-originator
49 bug-owner
50 bug-severity
51 bug-subject
52 bug-tags))
53
54 (define* (read-emails-from-bug-log port
55 #:optional (keep '(incoming-recv)))
56 "Read the Debbugs bug log from PORT and return a list of parsed
57 email objects. According to the documentation of the Perl module
58 Debbugs::Log there are four record types that are separated with
59 single control characters on a line of their own.
60
61 * autocheck
62
63 This is for auto-forwarded messages. The mail is recorded between a
64 leading ^A and a trailing ^C.
65
66 * recips
67
68 This is for emails with an additional list of recipients. The
69 recipients list may be just the string \"-t\", which represents the
70 same sendmail option, indicating that the recipients are taken from
71 the message headers. This record starts with ^B, uses ^D as an inline
72 separator for recipients, and uses ^E to mark the beginning of the
73 email. The email ends with ^C.
74
75 * html
76
77 This is for raw HTML snippets. They are recorded between ^F and ^C.
78 They are only used for the Debbugs web interface.
79
80 * incoming-recv
81
82 This is for received emails. The raw email is introduced by ^G and
83 ends with ^C.
84 "
85 (let loop ((msgids (make-hash-table))
86 (mails '())
87 (lines '())
88 (type 'init)
89 (skip? #f))
90 (let ((line (read-line port)))
91 (if (eof-object? line) (reverse mails)
92 (match (and (not (string-null? line))
93 (string-ref line 0))
94 ;; Ctrl-A, autocheck
95 (#\soh
96 (loop msgids mails lines 'autocheck #f))
97 ;; Ctrl-B, recips: skip until beginning of email
98 (#\stx
99 (loop msgids mails lines 'recips #t))
100 ;; Ctrl-C, end of record
101 (#\etx
102 (let ((mails*
103 (if (member type keep)
104 ;; TODO: This is very ugly. The first few
105 ;; lines of the raw messages stored in Debbugs
106 ;; logs seem to confuse the email parser, so we
107 ;; try to strip them off.
108 (let* ((content (string-join
109 (drop-while (lambda (line)
110 (or (string-prefix? "From " line)
111 (string-prefix? "Received" line)
112 (string-prefix? "\t" line)
113 (string-prefix? " " line)))
114 (reverse lines)) "\n"))
115 (mail (catch #t
116 (lambda ()
117 (parse-email content))
118 (lambda args
119 (format (current-error-port)
120 "failed to process email~%")
121 #f))))
122 (let ((id (and mail (assoc-ref (email-headers mail) 'message-id))))
123 (if (and id (not (hash-ref msgids id)))
124 (begin
125 (hash-set! msgids id #t)
126 (cons mail mails))
127 mails)))
128 mails)))
129 (loop msgids mails* '() 'init #f)))
130 ;; Ctrl-E, beginning of email in recips
131 (#\enq
132 (loop msgids mails lines 'recips #f))
133 ;; Ctrl-F, raw HTML snippet: skip
134 (#\ack
135 (loop msgids mails lines 'html #t))
136 ;; Ctrl-G, incoming-recv
137 (#\bel
138 (loop msgids mails lines 'incoming-recv #f))
139 (_
140 (if skip?
141 (loop msgids mails lines type skip?)
142 (loop msgids mails (cons line lines) type skip?))))))))
143
144 (define* (filter-index pred proc #:key archived?)
145 "Open up a Debbugs index file and collect the result of applying
146 PROC to those lines that match the predicate PRED. If ARCHIVED? is #T
147 search the index of archived issues."
148 (define index-file
149 (format #f "~a/spool/index.~a.realtime" (%config 'data-dir)
150 (if archived? "archive" "db")))
151 (call-with-input-file index-file
152 (lambda (port)
153 (let loop ((result '()))
154 (match (read-line port)
155 ((? eof-object? x) result)
156 (line
157 (cond
158 ((pred line)
159 (loop (cons (proc line) result)))
160 (else (loop result)))))))))
161
162 (define* (extract-bug-numbers packages #:key archived?)
163 "Open up a Debbugs index file and return the bug numbers for those
164 lines that match one of PACKAGES. If ARCHIVED? is #T search the index
165 of archived issues."
166 (define cache-key
167 (list 'extract-bug-numbers packages archived?))
168 (define cached (cached? cache-key))
169 (or cached
170 (let ((result
171 (filter-index (lambda (line)
172 (any (lambda (package)
173 (string-prefix? package line))
174 packages))
175 (lambda (line)
176 (second (string-split line #\space)))
177 #:archived? archived?)))
178 (cache! cache-key result)
179 result)))
180
181 (define* (forgotten-bug-numbers packages #:key (seconds-ago (* 60 60 24 30)))
182 "Return the numbers of issues that are open but haven't seen any
183 activity for a while. The duration is given by SECONDS-AGO, which
184 defaults to 30 days."
185 (define threshold
186 (number->string
187 (time-second
188 (subtract-duration (current-time)
189 (make-time time-duration 0 seconds-ago)))))
190 (define cache-key
191 (list 'forgotten-bug-numbers packages seconds-ago))
192 (define cached (cached? cache-key))
193 (or cached
194 (let ((result
195 (filter-index (lambda (line)
196 (any (lambda (package)
197 (and (string-prefix? package line)
198 (let ((fields (string-split line #\space)))
199 (and (string=? "open" (fourth fields))
200 (string< (third fields) threshold)))))
201 packages))
202 (lambda (line)
203 (second (string-split line #\space))))))
204 (cache! cache-key result)
205 result)))
206
207 (define* (bug-id->log-file bug-id #:key archived?)
208 (format #f "~a/spool/~a/~a/~a.log"
209 (%config 'data-dir)
210 (if archived? "archive" "db-h")
211 (string-take-right (if (string? bug-id)
212 bug-id
213 (number->string bug-id)) 2)
214 bug-id))
215
216 (define (bug-id->summary-file bug-id)
217 (let ((candidate (lambda (archived?)
218 (format #f "~a/spool/~a/~a/~a.summary"
219 (%config 'data-dir)
220 (if archived? "archive" "db-h")
221 (string-take-right (if (string? bug-id)
222 bug-id
223 (number->string bug-id)) 2)
224 bug-id))))
225 (find file-exists?
226 (list (candidate #f)
227 (candidate #t)))))
228
229 \f
230 (define-record-type <bug-status>
231 (make-bug-status num
232 archived blockedby blocks date done mergedwith
233 originator owner severity subject tags)
234 bug-status?
235 (num bug-num)
236 (archived bug-archived)
237 (blockedby bug-blockedby)
238 (blocks bug-blocks)
239 (date bug-date)
240 (done bug-done)
241 (mergedwith bug-mergedwith)
242 (originator bug-originator)
243 (owner bug-owner)
244 (severity bug-severity)
245 (subject bug-subject)
246 (tags bug-tags))
247
248 (define qp-pattern "=\\?UTF-8\\?Q\\?([^?]+)\\?=")
249 (define (bug-status bug-id)
250 (and-let* ((bug-id (if (number? bug-id) bug-id
251 (string->number bug-id)))
252 (file (bug-id->summary-file bug-id))
253 (properties
254 (call-with-input-file file
255 (lambda (port)
256 (let loop ((props '()))
257 (let ((line (read-line port)))
258 (if (eof-object? line) props
259 (let* ((split-point (string-index line #\:))
260 (key (string-take line split-point))
261 (value (string-drop line (1+ split-point))))
262 (loop (cons (cons key
263 (string-trim-both value))
264 props))))))))))
265 (make-bug-status bug-id
266 (string-contains "/archive/" file)
267 (assoc-ref properties "Blocked-By")
268 (assoc-ref properties "Blocks")
269 (time-monotonic->date
270 (make-time time-monotonic
271 0
272 (string->number (assoc-ref properties "Date"))))
273 (assoc-ref properties "Done")
274 (assoc-ref properties "Merged-With")
275 (assoc-ref properties "Submitter")
276 (assoc-ref properties "Owner")
277 (assoc-ref properties "Severity")
278 (let ((subject (assoc-ref properties "Subject")))
279 (if (string-contains subject "=?UTF-8?Q?")
280 (or (false-if-exception
281 (utf8->string
282 (quoted-printable-decode
283 (regexp-substitute/global #f qp-pattern
284 subject 'pre 1 'post))))
285 subject)
286 subject))
287 (assoc-ref properties "Tags"))))