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* (filter-index pred proc #:key archived?)
 120   "Open up a Debbugs index file and collect the result of applying
 121 PROC to those lines that match the predicate PRED.  If ARCHIVED? is #T
 122 search the index of archived issues."
 123   (define index-file
 124     (format #f "~a/spool/index.~a.realtime" (%config 'data-dir)
 125             (if archived? "archive" "db")))
 126   (call-with-input-file index-file
 127     (lambda (port)
 128       (let loop ((result '()))
 129         (match (read-line port)
 130           ((? eof-object? x) result)
 131           (line
 132            (cond
 133             ((pred line)
 134              (loop (cons (proc line) result)))
 135             (else (loop result)))))))))
 136
 137 (define* (extract-bug-numbers packages #:key archived?)
 138   "Open up a Debbugs index file and return the bug numbers for those
 139 lines that match one of PACKAGES.  If ARCHIVED? is #T search the index
 140 of archived issues."
 141   (filter-index (lambda (line)
 142                   (any (lambda (package)
 143                          (string-prefix? package line))
 144                        packages))
 145                 (lambda (line)
 146                   (second (string-split line #\space)))
 147                 #:archived? archived?))
 148
 149 (define* (bug-id->log-file bug-id #:key archived?)
 150   (format #f "~a/spool/~a/~a/~a.log"
 151           (%config 'data-dir)
 152           (if archived? "archive" "db-h")
 153           (string-take-right (if (string? bug-id)
 154                                  bug-id
 155                                  (number->string bug-id)) 2)
 156           bug-id))