7873c863bb59adfa8506790d1248fd45a85d1502
[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 ;; TODO: This is very ugly. The first few
80 ;; lines of the raw messages stored in Debbugs
81 ;; logs seem to confuse the email parser, so we
82 ;; try to strip them off.
83 (let* ((content (string-join
84 (drop-while (lambda (line)
85 (or (string-prefix? "From " line)
86 (string-prefix? "Received" line)
87 (string-prefix? "\t" line)
88 (string-prefix? " " line)))
89 (reverse lines)) "\n"))
90 (mail (catch #t
91 (lambda ()
92 (parse-email content))
93 (lambda args
94 (format (current-error-port)
95 "failed to process email~%")
96 #f))))
97 (let ((id (and mail (assoc-ref (email-headers mail) 'message-id))))
98 (if (and id (not (hash-ref msgids id)))
99 (begin
100 (hash-set! msgids id #t)
101 (cons mail mails))
102 mails)))
103 mails)))
104 (loop msgids mails* '() 'init #f)))
105 ;; Ctrl-E, beginning of email in recips
106 (#\enq
107 (loop msgids mails lines 'recips #f))
108 ;; Ctrl-F, raw HTML snippet: skip
109 (#\ack
110 (loop msgids mails lines 'html #t))
111 ;; Ctrl-G, incoming-recv
112 (#\bel
113 (loop msgids mails lines 'incoming-recv #f))
114 (_
115 (if skip?
116 (loop msgids mails lines type skip?)
117 (loop msgids mails (cons line lines) type skip?))))))))
118
119 (define* (extract-bug-numbers packages #:key archived?)
120 "Open up a Debbugs index file and return the bug numbers for those
121 lines that match one of PACKAGES. If ARCHIVED? is #T search the index
122 of archived issues."
123 (define index-file
124 (format #f "~a/spool/index.~a.realtime" (%config 'data-dir)
125 (if archived? "archive" "db")))
126 (define (extract-numbers port)
127 (let loop ((numbers '()))
128 (match (read-line port)
129 ((? eof-object? x) numbers)
130 (line
131 (cond
132 ((any (lambda (package)
133 (string-prefix? package line))
134 packages)
135 (loop (cons (second (string-split line #\space))
136 numbers)))
137 (else (loop numbers)))))))
138 (call-with-input-file index-file extract-numbers))
139
140 (define* (bug-id->log-file bug-id #:key archived?)
141 (format #f "~a/spool/~a/~a/~a.log"
142 (%config 'data-dir)
143 (if archived? "archive" "db-h")
144 (string-take-right (if (string? bug-id)
145 bug-id
146 (number->string bug-id)) 2)
147 bug-id))