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