debbugs: Add forgotten-bug-numbers.
[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 (debbugs cache)
21 #:use-module (email email)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-11)
24 #:use-module (srfi srfi-19)
25 #:use-module (ice-9 match)
26 #:use-module (ice-9 rdelim)
27 #:export (read-emails-from-bug-log
28 extract-bug-numbers
29 forgotten-bug-numbers
30 bug-id->log-file))
31
32 (define* (read-emails-from-bug-log port
33 #:optional (keep '(incoming-recv)))
34 "Read the Debbugs bug log from PORT and return a list of parsed
35 email objects. According to the documentation of the Perl module
36 Debbugs::Log there are four record types that are separated with
37 single control characters on a line of their own.
38
39 * autocheck
40
41 This is for auto-forwarded messages. The mail is recorded between a
42 leading ^A and a trailing ^C.
43
44 * recips
45
46 This is for emails with an additional list of recipients. The
47 recipients list may be just the string \"-t\", which represents the
48 same sendmail option, indicating that the recipients are taken from
49 the message headers. This record starts with ^B, uses ^D as an inline
50 separator for recipients, and uses ^E to mark the beginning of the
51 email. The email ends with ^C.
52
53 * html
54
55 This is for raw HTML snippets. They are recorded between ^F and ^C.
56 They are only used for the Debbugs web interface.
57
58 * incoming-recv
59
60 This is for received emails. The raw email is introduced by ^G and
61 ends with ^C.
62 "
63 (let loop ((msgids (make-hash-table))
64 (mails '())
65 (lines '())
66 (type 'init)
67 (skip? #f))
68 (let ((line (read-line port)))
69 (if (eof-object? line) (reverse mails)
70 (match (and (not (string-null? line))
71 (string-ref line 0))
72 ;; Ctrl-A, autocheck
73 (#\soh
74 (loop msgids mails lines 'autocheck #f))
75 ;; Ctrl-B, recips: skip until beginning of email
76 (#\stx
77 (loop msgids mails lines 'recips #t))
78 ;; Ctrl-C, end of record
79 (#\etx
80 (let ((mails*
81 (if (member type keep)
82 ;; TODO: This is very ugly. The first few
83 ;; lines of the raw messages stored in Debbugs
84 ;; logs seem to confuse the email parser, so we
85 ;; try to strip them off.
86 (let* ((content (string-join
87 (drop-while (lambda (line)
88 (or (string-prefix? "From " line)
89 (string-prefix? "Received" line)
90 (string-prefix? "\t" line)
91 (string-prefix? " " line)))
92 (reverse lines)) "\n"))
93 (mail (catch #t
94 (lambda ()
95 (parse-email content))
96 (lambda args
97 (format (current-error-port)
98 "failed to process email~%")
99 #f))))
100 (let ((id (and mail (assoc-ref (email-headers mail) 'message-id))))
101 (if (and id (not (hash-ref msgids id)))
102 (begin
103 (hash-set! msgids id #t)
104 (cons mail mails))
105 mails)))
106 mails)))
107 (loop msgids mails* '() 'init #f)))
108 ;; Ctrl-E, beginning of email in recips
109 (#\enq
110 (loop msgids mails lines 'recips #f))
111 ;; Ctrl-F, raw HTML snippet: skip
112 (#\ack
113 (loop msgids mails lines 'html #t))
114 ;; Ctrl-G, incoming-recv
115 (#\bel
116 (loop msgids mails lines 'incoming-recv #f))
117 (_
118 (if skip?
119 (loop msgids mails lines type skip?)
120 (loop msgids mails (cons line lines) type skip?))))))))
121
122 (define* (filter-index pred proc #:key archived?)
123 "Open up a Debbugs index file and collect the result of applying
124 PROC to those lines that match the predicate PRED. If ARCHIVED? is #T
125 search the index of archived issues."
126 (define index-file
127 (format #f "~a/spool/index.~a.realtime" (%config 'data-dir)
128 (if archived? "archive" "db")))
129 (call-with-input-file index-file
130 (lambda (port)
131 (let loop ((result '()))
132 (match (read-line port)
133 ((? eof-object? x) result)
134 (line
135 (cond
136 ((pred line)
137 (loop (cons (proc line) result)))
138 (else (loop result)))))))))
139
140 (define* (extract-bug-numbers packages #:key archived?)
141 "Open up a Debbugs index file and return the bug numbers for those
142 lines that match one of PACKAGES. If ARCHIVED? is #T search the index
143 of archived issues."
144 (filter-index (lambda (line)
145 (any (lambda (package)
146 (string-prefix? package line))
147 packages))
148 (lambda (line)
149 (second (string-split line #\space)))
150 #:archived? archived?))
151
152 (define* (forgotten-bug-numbers packages #:key (seconds-ago (* 60 60 24 30)))
153 "Return the numbers of issues that are open but haven't seen any
154 activity for a while. The duration is given by SECONDS-AGO, which
155 defaults to 30 days."
156 (define threshold
157 (number->string
158 (time-second
159 (subtract-duration (current-time)
160 (make-time time-duration 0 seconds-ago)))))
161 (define cache-key
162 (list 'forgotten-bug-numbers packages seconds-ago))
163 (define cached (cached? cache-key))
164 (or cached
165 (let ((result
166 (filter-index (lambda (line)
167 (any (lambda (package)
168 (and (string-prefix? package line)
169 (let ((fields (string-split line #\space)))
170 (and (string=? "open" (fourth fields))
171 (string< (third fields) threshold)))))
172 packages))
173 (lambda (line)
174 (second (string-split line #\space))))))
175 (cache! cache-key result)
176 result)))
177
178 (define* (bug-id->log-file bug-id #:key archived?)
179 (format #f "~a/spool/~a/~a/~a.log"
180 (%config 'data-dir)
181 (if archived? "archive" "db-h")
182 (string-take-right (if (string? bug-id)
183 bug-id
184 (number->string bug-id)) 2)
185 bug-id))