c08a7bdd770a5e301d052646bb0effe397b91639
[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 ((msgids (make-hash-table))
61 (mails '())
62 (lines '())
63 (type 'init)
64 (skip? #f))
65 (let ((line (read-line port)))
66 (if (eof-object? line) (reverse mails)
67 (match (and (not (string-null? line))
68 (string-ref line 0))
69 ;; Ctrl-A, autocheck
70 (#\soh
71 (loop msgids mails lines 'autocheck #f))
72 ;; Ctrl-B, recips: skip until beginning of email
73 (#\stx
74 (loop msgids mails lines 'recips #t))
75 ;; Ctrl-C, end of record
76 (#\etx
77 (let ((mails*
78 (if (member type keep)
79 (let* ((contents (string-join (drop (reverse lines) 1) "\n"))
80 (mail (catch #t
81 (lambda ()
82 (parse-email
83 (and=> (call-with-input-string contents mbox->emails)
84 first)))
85 (lambda args
86 (format (current-error-port)
87 "failed to process email~% ~a~%"
88 args)
89 #f))))
90 (let ((id (and mail (assoc-ref (email-headers mail) 'message-id))))
91 (if (and id (not (hash-ref msgids id)))
92 (begin
93 (hash-set! msgids id #t)
94 (cons mail mails))
95 mails)))
96 mails)))
97 (loop msgids mails* '() 'init #f)))
98 ;; Ctrl-E, beginning of email in recips
99 (#\enq
100 (loop msgids mails lines 'recips #f))
101 ;; Ctrl-F, raw HTML snippet: skip
102 (#\ack
103 (loop msgids mails lines 'html #t))
104 ;; Ctrl-G, incoming-recv
105 (#\bel
106 (loop msgids mails lines 'incoming-recv #f))
107 (_
108 (if skip?
109 (loop msgids mails lines type skip?)
110 (loop msgids mails (cons line lines) type skip?))))))))
111
112 (define* (extract-bug-numbers packages #:key archived?)
113 "Open up a Debbugs index file and return the bug numbers for those
114 lines that match one of PACKAGES. If ARCHIVED? is #T search the index
115 of archived issues."
116 (define index-file
117 (format #f "~a/spool/index.~a.realtime" (%config 'data-dir)
118 (if archived? "archive" "db")))
119 (define (extract-numbers port)
120 (let loop ((numbers '()))
121 (match (read-line port)
122 ((? eof-object? x) numbers)
123 (line
124 (cond
125 ((any (lambda (package)
126 (string-prefix? package line))
127 packages)
128 (loop (cons (second (string-split line #\space))
129 numbers)))
130 (else (loop numbers)))))))
131 (call-with-input-file index-file extract-numbers))
132
133 (define* (bug-id->log-file bug-id #:key archived?)
134 (format #f "~a/spool/~a/~a/~a.log"
135 (%config 'data-dir)
136 (if archived? "archive" "db-h")
137 (string-take-right (if (string? bug-id)
138 bug-id
139 (number->string bug-id)) 2)
140 bug-id))