Support downloading of attachments.
[software/mumi.git] / mumi / web / download.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or
5 ;;; modify it under the terms of the GNU Affero General Public License
6 ;;; as published by the Free Software Foundation, either version 3 of
7 ;;; the License, or (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ;;; Affero General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU Affero General Public
15 ;;; License along with this program. If not, see
16 ;;; <http://www.gnu.org/licenses/>.
17
18 (define-module (mumi web download)
19 #:use-module (srfi srfi-1)
20 #:use-module (srfi srfi-26)
21 #:use-module (debbugs base64)
22 #:use-module (ice-9 iconv)
23 #:use-module (ice-9 match)
24 #:use-module (ice-9 regex)
25 #:use-module (mumi messages)
26 #:use-module (mumi web render)
27 #:export (handle-download))
28
29 (define (handle-download id msg-num path)
30 "Handle download of an attachment for bug ID, message number
31 MSG-NUM, in the possibly nested message part identified by the list
32 PATH."
33 (or (and=> (extract-attachment id msg-num path)
34 (match-lambda
35 ((#:headers headers #:body body)
36 (list (filter-map (match-lambda
37 (("content-type" vals)
38 (list 'content-type
39 (string->symbol vals)))
40 (("content-disposition" vals)
41 (let ((name (or (and=> (string-match "filename=([^ ;]+)" vals)
42 (lambda (m)
43 (match:substring m 1)))
44 "attachment")))
45 (list 'content-disposition
46 'attachment
47 `(filename . ,name))))
48 (_ #f))
49 headers)
50 ;; Try to decode the attachment
51 (or (and=> (assoc-ref headers "content-transfer-encoding")
52 (match-lambda
53 (("base64")
54 (string-join (map (compose (cut bytevector->string <> "UTF-8") base64-decode)
55 (string-split body #\newline)) "\n"))
56 (("quoted-printable")
57 (with-input-from-string body
58 (lambda () (qp-decoder (current-input-port)))))
59 (_ #f)))
60 body)))
61 (_ #f)))
62 (apply render-html (unknown id))))