Support downloading of attachments.

* assets/css/screen.css (.attachment:before): Add rule.
* assets/img/file.svg: New file.
* mumi/web/controller.scm (controller): Handle attachment route.
* mumi/web/download.scm: New file.
* mumi/web/view/utils.scm (display-multipart-chunk): Move into...
(display-message-body): ...this procedure; adjust to include
attachment download links.
* mumi/web/view/html.scm (issue-page): Adjust.

7 files changed, 138 insertions, 26 deletions

diff --git a/Makefile.am b/Makefile.am
index 2083aef..cdf5f37 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -26,6 +26,7 @@ godir  = $(moddir)
 assetsdir = $(datadir)/@PACKAGE@
 
 SOURCES =							\
+  mumi/web/download.scm				\
   mumi/web/server.scm				\
   mumi/web/render.scm				\
   mumi/web/controller.scm			\
diff --git a/assets/css/screen.css b/assets/css/screen.css
index 1517a56..79dd0a3 100644
--- a/assets/css/screen.css
+++ b/assets/css/screen.css
@@ -151,6 +151,15 @@ table {
 .multipart.text-x-patch {
 }
 
+.attachment:before {
+    background-image: url('/img/file.svg');
+    background-size: 1rem;
+    display: inline-block;
+    height: 1rem;
+    width: 1rem;
+    content: "";
+}
+
 .message .from .address {
     font-weight: bold;
 }
diff --git a/assets/img/file.svg b/assets/img/file.svg
new file mode 100644
index 0000000..ce8c9b4
--- /dev/null
+++ b/assets/img/file.svg
@@ -0,0 +1,8 @@
+<?xml version="1.0" encoding="utf-8"?>

+<!-- Generator: Adobe Illustrator 16.0.0, SVG Export Plug-In . SVG Version: 6.00 Build 0)  -->

+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">

+<svg version="1.1" id="Layer_1" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" x="0px" y="0px"

+	 width="120px" height="120px" viewBox="0 0 120 120" enable-background="new 0 0 120 120" xml:space="preserve">

+<polygon points="103.192,120 16.526,120 16.526,0 55.96,0 55.96,46.301 103.192,46.301 "/>

+<polygon points="64.476,0 64.476,38.717 103.192,38.717 "/>

+</svg>

diff --git a/mumi/web/controller.scm b/mumi/web/controller.scm
index 414b42e..ad6c63a 100644
--- a/mumi/web/controller.scm
+++ b/mumi/web/controller.scm
@@ -24,6 +24,7 @@
   #:use-module (web uri)
   #:use-module (mumi messages)
   #:use-module (mumi web render)
+  #:use-module (mumi web download)
   #:use-module (mumi web util)
   #:use-module (mumi web view html)
   #:export (controller))
@@ -101,6 +102,12 @@
       (lambda () (or (and=> (fetch-bug id) issue-page)
                 (unknown id)))
       `(p "Could not access issue #" (strong ,id) ".")))
+    ((GET "issue" (? string->number id)
+          "attachment" (? string->number msg-num)
+          (? string->number path) ...)
+     (handle-download (string->number id)
+                      (string->number msg-num)
+                      (map string->number path)))
     ((GET "issue" not-an-id)
      (apply render-html (unknown not-an-id)))
     ((GET "help")
diff --git a/mumi/web/download.scm b/mumi/web/download.scm
new file mode 100644
index 0000000..8c97937
--- /dev/null
+++ b/mumi/web/download.scm
@@ -0,0 +1,62 @@
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2018 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 web download)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (debbugs base64)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (mumi messages)
+  #:use-module (mumi web render)
+  #:export (handle-download))
+
+(define (handle-download id msg-num path)
+  "Handle download of an attachment for bug ID, message number
+MSG-NUM, in the possibly nested message part identified by the list
+PATH."
+  (or (and=> (extract-attachment id msg-num path)
+             (match-lambda
+               ((#:headers headers #:body body)
+                (list (filter-map (match-lambda
+                                    (("content-type" vals)
+                                     (list 'content-type
+                                           (string->symbol vals)))
+                                    (("content-disposition" vals)
+                                     (let ((name (or (and=> (string-match "filename=([^ ;]+)" vals)
+                                                            (lambda (m)
+                                                              (match:substring m 1)))
+                                                     "attachment")))
+                                       (list 'content-disposition
+                                             'attachment
+                                             `(filename . ,name))))
+                                    (_ #f))
+                                  headers)
+                      ;; Try to decode the attachment
+                      (or (and=> (assoc-ref headers "content-transfer-encoding")
+                                 (match-lambda
+                                   (("base64")
+                                    (string-join (map (compose (cut bytevector->string <> "UTF-8") base64-decode)
+                                                      (string-split body #\newline)) "\n"))
+                                   (("quoted-printable")
+                                    (with-input-from-string body
+                                      (lambda () (qp-decoder (current-input-port)))))
+                                   (_ #f)))
+                          body)))
+               (_ #f)))
+      (apply render-html (unknown id))))
diff --git a/mumi/web/view/html.scm b/mumi/web/view/html.scm
index 693eadd..91c9809 100644
--- a/mumi/web/view/html.scm
+++ b/mumi/web/view/html.scm
@@ -289,7 +289,7 @@ range.  The supported arguments are the same as for "
             ,(message-id message))))
          (div
           (@ (class "body panel-body"))
-          ,(display-message-body message)))))
+          ,(display-message-body id message)))))
       ,@(if (closing? message id)
             '((div
                (@ (class "row event"))
diff --git a/mumi/web/view/utils.scm b/mumi/web/view/utils.scm
index f0d58c0..ce2827e 100644
--- a/mumi/web/view/utils.scm
+++ b/mumi/web/view/utils.scm
@@ -18,6 +18,7 @@
 (define-module (mumi web view utils)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:use-module (debbugs email)
   #:use-module (mumi messages)
@@ -94,19 +95,39 @@
               (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."
+(define (display-message-body bug-num message)
+  "Convenience procedure to render MESSAGE (part of bug with number
+BUG-NUM), even when it is a multipart message."
+  (define (display-multipart-chunk headers body . path)
+    (let* ((type
+            (and=> (assoc-ref headers "content-type")
+                   (lambda (value)
+                     (content-type->css-class (first value)))))
+           (binary-attachment?
+            (and (and=> (assoc-ref headers "content-disposition")
+                        (lambda (value)
+                          (string-contains (first value) "attachment")))
+                 type
+                 (string-contains type "application")
+                 (first (assoc-ref headers "content-disposition"))))
+           (attachment-name
+            (or (and=> binary-attachment?
+                       (lambda (value)
+                         (and=> (string-match "filename=([^ ;]+)" value)
+                                (lambda (m)
+                                  (match:substring m 1)))))
+                "file")))
+      (if binary-attachment?
+          `(div (@ (class "attachment"))
+                "Attachment: "
+                (a (@ (href ,(string-append "/issue/"
+                                            (number->string bug-num)
+                                            "/attachment/"
+                                            (number->string (email-msg-num message))
+                                            "/" (string-join (map number->string path) "/"))))
+                   ,attachment-name))
+          `(div (@ (class ,(string-join `("multipart" ,(or type "")))))
+                ,(prettify body)))))
   (cond
    ((multipart-message? message)
     => (lambda (attributes)
@@ -117,18 +138,22 @@ multipart message."
                  "[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)))))
+            (map (lambda (part part-num)
+                   (match part
+                     (() "")
+                     ((#:headers hs #:body '()) "")
+                     ((#:headers hs #:body (? string? body))
+                      (display-multipart-chunk hs body part-num))
+                     ;; Message parts can be nested.
+                     ((#:headers hs #:body sub-parts)
+                      (map (lambda (part sub-part-num)
+                             (match part
+                               ((#:headers hs #:body body)
+                                (display-multipart-chunk hs body part-num sub-part-num))))
+                           sub-parts
+                           (iota (length parts))))))
+                 parts
+                 (iota (length parts)))))))
    ;; Regular message with a simple body.
    (else
     (prettify (email-body message)))))