mumi: Add (mumi debbugs).

* mumi/debbugs.scm: New file.
* Makefile.am (SOURCES): Add it.

2 files changed, 113 insertions, 1 deletions

diff --git a/Makefile.am b/Makefile.am
index 47343ab..aeeffee 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -48,4 +48,6 @@ SOURCES =							\
   mumi/messages.scm					\
   mumi/jobs.scm						\
   mumi/send-email.scm				\
-  mumi/config.scm
+  mumi/config.scm					\
+  mumi/debbugs.scm
+
diff --git a/mumi/debbugs.scm b/mumi/debbugs.scm
new file mode 100644
index 0000000..405d020
--- /dev/null
+++ b/mumi/debbugs.scm
@@ -0,0 +1,110 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (mumi debbugs)
+  #:use-module (email email)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 rdelim)
+  #:export (read-emails-from-bug-log))
+
+(define* (read-emails-from-bug-log port
+                                   #:optional (keep '(incoming-recv)))
+  "Read the Debbugs bug log from PORT and return a list of parsed
+email objects.  According to the documentation of the Perl module
+Debbugs::Log there are four record types that are separated with
+single control characters on a line of their own.
+
+* autocheck
+
+This is for auto-forwarded messages.  The mail is recorded between a
+leading ^A and a trailing ^C.
+
+* recips
+
+This is for emails with an additional list of recipients.  The
+recipients list may be just the string \"-t\", which represents the
+same sendmail option, indicating that the recipients are taken from
+the message headers.  This record starts with ^B, uses ^D as an inline
+separator for recipients, and uses ^E to mark the beginning of the
+email.  The email ends with ^C.
+
+* html
+
+This is for raw HTML snippets.  They are recorded between ^F and ^C.
+They are only used for the Debbugs web interface.
+
+* incoming-recv
+
+This is for received emails.  The raw email is introduced by ^G and
+ends with ^C.
+"
+  (let loop ((mails '())
+             (lines '())
+             (type 'init)
+             (skip? #f))
+    (let ((line (read-line port)))
+      (if (eof-object? line) (reverse mails)
+          (match (and (not (string-null? line))
+                      (string-ref line 0))
+            ;; Ctrl-A, autocheck
+            (#\soh
+             (loop mails lines 'autocheck #f))
+            ;; Ctrl-B, recips: skip until beginning of email
+            (#\stx
+             (loop mails lines 'recips #t))
+            ;; Ctrl-C, end of record
+            (#\etx
+             (loop (if (member type keep)
+                       ;; TODO: This is very ugly.  The first few
+                       ;; lines of the raw messages stored in Debbugs
+                       ;; logs seem to confuse the email parser, so we
+                       ;; try to strip them off.
+                       (let* ((content (string-join
+                                        (drop-while (lambda (line)
+                                                      (or (string-prefix? "From" line)
+                                                          (string-prefix? "Received" line)
+                                                          (string-prefix? "\t" line)
+                                                          (string-prefix? " " line)))
+                                                    (reverse lines)) "\n"))
+                              (mail (catch #t
+                                      (lambda ()
+                                        (parse-email content))
+                                      (lambda args
+                                        (format (current-error-port)
+                                                "failed to process email~%")
+                                        #f))))
+                         (if mail
+                             (cons mail mails)
+                             mails))
+                       mails)
+                   '()
+                   'init #f))
+            ;; Ctrl-E, beginning of email in recips
+            (#\enq
+             (loop mails lines 'recips #f))
+            ;; Ctrl-F, raw HTML snippet: skip
+            (#\ack
+             (loop mails lines 'html #t))
+            ;; Ctrl-G, incoming-recv
+            (#\bel
+             (loop mails lines 'incoming-recv #f))
+            (_
+             (if skip?
+                 (loop mails lines type skip?)
+                 (loop mails (cons line lines) type skip?))))))))