summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--assets/css/screen.css9
-rw-r--r--assets/img/file.svg8
-rw-r--r--mumi/web/controller.scm7
-rw-r--r--mumi/web/download.scm62
-rw-r--r--mumi/web/view/html.scm2
-rw-r--r--mumi/web/view/utils.scm75
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)))))