Add some support for multipart messages.

4 files changed, 265 insertions, 5 deletions

diff --git a/assets/css/screen.css b/assets/css/screen.css
index 21c55a4..9021320 100644
--- a/assets/css/screen.css
+++ b/assets/css/screen.css
@@ -155,6 +155,23 @@ input#query {
     border: none;
 }
 
+.message .body .multipart {
+    padding-bottom: 1rem;
+}
+
+.message .body .multipart + .multipart {
+    padding-top: 1rem;
+    padding-bottom: 1rem;
+    border-top: 1px dashed #ddd;
+}
+
+.multipart.application-pgp-signature {
+    display: none;
+}
+
+.multipart.text-x-patch {
+}
+
 .message .from .address {
     font-weight: bold;
 }
@@ -221,3 +238,8 @@ input#query {
 .status-tag.open {
     background: #2cbe4e;
 }
+
+.error.parse {
+    font-style: italic;
+    font-size: 0.8em;
+}
diff --git a/mumi/messages.scm b/mumi/messages.scm
index 9614852..e6edfe0 100644
--- a/mumi/messages.scm
+++ b/mumi/messages.scm
@@ -22,13 +22,20 @@
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 textual-ports)
   #:use-module (debbugs soap)
   #:use-module (debbugs operations)
   #:use-module (debbugs email)
   #:use-module (debbugs bug)
+  #:use-module (debbugs rfc822)
   #:use-module (mumi config)
   #:use-module (mailutils mailutils)
-  #:export (search-bugs fetch-bug recent-bugs))
+  #:export (search-bugs
+            fetch-bug
+            recent-bugs
+
+            split-multipart-message
+            multipart-message?))
 
 ;; TODO: mu-address-get-personal skips non ASCII characters
 ;; ex: (mu-address-get-personal "ludo@gnu.org (Ludovic Courtès)")
@@ -86,12 +93,189 @@
 (define-public (internal-message? message)
   (bot? (sender-email message)))
 
+
+;; Taken from (debbugs rfc822).
+(define* (read-token predicate #:optional (port (current-input-port)))
+  "Read characters from PORT and call the procedure PREDICATE with
+each character until PREDICATE returns #F.  Return a string with the
+accumulated characters."
+  (let ((r (open-output-string)))
+    (define (finish) (get-output-string r))
+    (let loop ((c (peek-char port)))
+      (cond ((eof-object? c) (finish))
+            ((predicate c)
+             (write-char (read-char port) r)
+             (loop (peek-char port)))
+            (else (finish))))))
+
+(define* (read-until delimiter #:optional (port (current-input-port)))
+  "Return the string up to DELIMITER.  Also read DELIMITER and throw
+it away."
+  (let ((result (read-token (lambda (char) (not (char=? char delimiter))) port)))
+    (read-token (cut char=? <> delimiter) port)
+    result))
+
+(define* (read-between delimiter #:optional (port (current-input-port)))
+  "Return the string after DELIMITER and before DELIMITER from PORT."
+  (read-token (cut char=? <> delimiter) port)
+  (read-until delimiter port))
+
+(define* (read-key-value-pair #:optional (port (current-input-port)))
+  "Read a single key value pair from PORT.  The key is separated from
+the value by an equal sign.  The value may be wrapped in double
+quotes.  The pair must end with a semicolon."
+  (let* ((key (read-until #\= port))
+         (val (if (char=? (peek-char port) #\")
+                  (let ((return (read-between #\" port)))
+                    (read-until #\; port)
+                    return)
+                  (read-until #\; port))))
+    (cons (string-downcase key) val)))
+
+(define (throw-away char-pred)
+  "Return a procedure that reads and discards any number of characters
+for which the predicate CHAR-PRED returns #T from a port."
+  (lambda* (#:optional (port (current-input-port)))
+    (while (char-pred (peek-char port))
+      (read-token char-pred port))))
+
+(define (parse-multipart-header port)
+  "Read a multipart header string from PORT and return an alist of
+attributes."
+  (let loop ((acc `(("type" . ,(read-until #\; port)))))
+    (if (eof-object? (peek-char port))
+        acc
+        (begin
+          ((throw-away char-whitespace?) port)
+          (loop (cons (read-key-value-pair port) acc))))))
+
+(define (multipart-header? line)
+  "Return the attributes of the provided Content-Type header value."
+  (and (string? line)
+       (string-prefix? "multipart" line)
+       (call-with-input-string line parse-multipart-header)))
+
+(define (multipart-message? message)
+  (multipart-header? (header message "content-type")))
+
+(define (qp-decoder port)
+  "Read a quoted-printable line from PORT and return the decoded
+string."
+  (let ((decoder-port (mu-decoder-port port "quoted-printable")))
+    (with-output-to-string
+      (lambda ()
+        (let loop ((line (get-line decoder-port)))
+          (cond
+           ((eof-object? line) #t)
+           (else
+            (display line)
+            (newline)
+            (loop (get-line decoder-port)))))))))
+
+(define (decode headers str)
+  "Decode the string STR according to the encoding specified in
+HEADERS."
+  (if (and=> (assoc-ref headers "content-transfer-encoding")
+             (lambda (values)
+               (string-contains (first values) "quoted-printable")))
+      (with-input-from-string str
+        (lambda () (qp-decoder (current-input-port))))
+      str))
+
+(define* (collect-parts boundary port #:key nested?)
+  "Read multipart message parts from PORT and return them as a list of
+containing #:headers and #:body.  If NESTED? is #T look for nested
+multipart messages."
+  (define final-boundary (string-append boundary "--"))
+  (let loop ((headers (rfc822-header->list port))
+             (line (get-line port))
+             (current-part '())
+             (parts '()))
+    (cond
+     ((or (string=? line final-boundary)
+          (eof-object? line))
+      ;; We're done!
+      (reverse (cons `(#:headers ,headers
+                       #:body ,(decode headers
+                                       (string-join (reverse current-part) "\n")))
+                     parts)))
+     ((string=? boundary line)
+      ;; End of this part
+      (let ((next-headers (rfc822-header->list port))
+            (next-line (get-line port)))
+        (loop next-headers
+              next-line
+              '()
+              (cons `(#:headers ,headers
+                      #:body ,(decode headers
+                                      (string-join (reverse current-part) "\n")))
+                    parts))))
+     ;; New part beginning with an in-body multipart
+     ;; header.
+     ((and nested?
+           (null? current-part)
+           (and=> (assoc-ref headers "content-type")
+                  (match-lambda
+                    (() #f)
+                    ((val) (multipart-header? val)))))
+      => (lambda (attributes)
+           ;; Parse multipart body.
+           (let ((embedded-parts
+                  (let* ((boundary (string-append "--"
+                                                  (assoc-ref attributes "boundary")))
+                         (final-boundary (string-append boundary "--")))
+                    (if (string=? boundary line)
+                        (collect-parts boundary port)
+                        ;; Invalid multipart message
+                        '()))))
+             ;; TODO: there might be some white space after the end of
+             ;; this embedded multipart message.  Not sure what to do
+             ;; with it, though.
+             (loop '()
+                   (get-line port)
+                   '()
+                   (cons `(#:headers ,headers
+                           #:body ,(decode headers
+                                           embedded-parts))
+                         parts)))))
+     ;; Just a boring old message body: add the line to
+     ;; the current part.
+     (else
+      (loop headers
+            (get-line port)
+            (cons line current-part)
+            parts)))))
+
+;; A multipart message may contain a body that is a multipart message
+;; itself.  This is signalized by a Content-Type header on the first
+;; line after the boundary.
+(define (split-multipart-message attributes message)
+  "Return list of message parts contained in the multipart MESSAGE.
+The ATTRIBUTES alist must contain the boundary string and the
+multipart type, among other things.  A message part is either a list
+of strings, or if the body itself contains a multipart message a lists
+of message parts."
+  (let ((boundary (string-append "--"
+                                 (assoc-ref attributes "boundary"))))
+    (call-with-input-string (email-body message)
+      (lambda (port)
+        ;; Ignore everything up to the first boundary string.
+        (let ((found (let loop ((line (get-line port)))
+                       (cond
+                        ((eof-object? line) #f)
+                        ((string=? boundary line) #t)
+                        (else (loop (get-line port)))))))
+          (if found
+              (collect-parts boundary port #:nested? #t)
+              ;; Invalid multipart message
+              '()))))))
+
+
 (define-public (patch-messages id)
   "Return list of messages relating to the bug ID."
   ;; TODO: sort by date necessary?
   (soap-invoke* (%config 'debbugs) get-bug-log id))
 
-
 (define* (search-bugs query #:key (attributes '()) (max 100))
   "Return a list of all bugs matching the given QUERY string."
   (let* ((matches (soap-invoke* (%config 'debbugs)
diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm
index 4d8a1e1..bb52376 100644
--- a/mumi/web/view/html.scm
+++ b/mumi/web/view/html.scm
@@ -184,7 +184,7 @@
             ,(message-id message))))
          (div
           (@ (class "body panel-body"))
-          ,(prettify (email-body message))))))
+          ,(display-message-body message)))))
       ,@(if (closing? message id)
             '((div
                (@ (class "row event"))
diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm
index 73a5969..4277ce8 100644
--- a/mumi/web/view/utils.scm
+++ b/mumi/web/view/utils.scm
@@ -17,9 +17,13 @@
 
 (define-module (mumi web view utils)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (debbugs email)
+  #:use-module (mumi messages)
   #:export (prettify
-            avatar-color))
+            avatar-color
+            display-message-body))
 
 ;; TODO: at some point this should tokenize the text, then apply
 ;; styles, then output sxml, but for now we keep it simple
@@ -61,7 +65,9 @@
         (if (eof-object? line)
             ;; Drop the first line break, because it's for an eof
             ;; read.
-            (cdr (reverse result))
+            (match (reverse result)
+              ((_ . rest) rest)
+              (() '()))
             (loop (read-line port)
                   (cons (process line)
                         (cons '(br) result))))))))
@@ -76,3 +82,51 @@
   (or (and=> (assoc-ref (zip participants colors) who)
              first)
       (first colors)))
+
+(define (content-type->css-class value)
+  "Convert a content-type header value to a CSS class name."
+  (string-map (lambda (chr)
+                (cond
+                 ((char-set-contains? char-set:letter chr) chr)
+                 (else #\-)))
+              (string-take value (or (string-index value #\;)
+                                     (string-length value)))))
+
+(define (display-multipart-chunk headers body)
+  (let ((classes
+         (string-join `("multipart"
+                        ,(or (and=> (assoc-ref headers "content-type")
+                                    (lambda (value)
+                                      (content-type->css-class (first value))))
+                             "")))))
+    `(div (@ (class ,classes))
+          ,(prettify body))))
+
+(define (display-message-body message)
+  "Convenience procedure to render MESSAGE, even when it is a
+multipart message."
+  (cond
+   ((multipart-message? message)
+    => (lambda (attributes)
+         (match (split-multipart-message attributes message)
+           (()
+            (cons
+             `(p (@ (class "error parse"))
+                 "[Failed to process the following multipart message.  Sorry!]")
+             (prettify (email-body message))))
+           (parts
+            (map (match-lambda
+                   (() "")
+                   ((#:headers hs #:body '()) "")
+                   ((#:headers hs #:body (? string? body))
+                    (display-multipart-chunk hs body))
+                   ;; Message parts can be nested.
+                   ((#:headers hs #:body sub-parts)
+                    (map (match-lambda
+                           ((#:headers hs #:body body)
+                            (display-multipart-chunk hs body)))
+                         sub-parts)))
+                 parts)))))
+   ;; Regular message with a simple body.
+   (else
+    (prettify (email-body message)))))