diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | assets/css/screen.css | 9 | ||||
| -rw-r--r-- | assets/img/file.svg | 8 | ||||
| -rw-r--r-- | mumi/web/controller.scm | 7 | ||||
| -rw-r--r-- | mumi/web/download.scm | 62 | ||||
| -rw-r--r-- | mumi/web/view/html.scm | 2 | ||||
| -rw-r--r-- | mumi/web/view/utils.scm | 75 |
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))))) |
