Support downloading of attachments.
[software/mumi.git] / mumi / web / render.scm
1 ;;; mumi -- Mediocre, uh, mail interface
2 ;;; Copyright © 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Affero General Public License
7 ;;; as published by the Free Software Foundation, either version 3 of
8 ;;; the License, or (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Affero General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Affero General Public
16 ;;; License along with this program. If not, see
17 ;;; <http://www.gnu.org/licenses/>.
18
19 ;; This code was snarfed from David Thompson's guix-web.
20
21 (define-module (mumi web render)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-19)
24 #:use-module (srfi srfi-26)
25 #:use-module (ice-9 binary-ports)
26 #:use-module (web request)
27 #:use-module (web response)
28 #:use-module (web uri)
29 #:use-module (json)
30 #:use-module (mumi config)
31 #:use-module (mumi web sxml)
32 #:use-module (mumi web util)
33 #:export (render-static-asset
34 render-html
35 render-json
36 not-found
37 unprocessable-entity
38 created
39 redirect))
40
41 (define file-mime-types
42 '(("css" . (text/css))
43 ("js" . (text/javascript))
44 ("svg" . (image/svg+xml))
45 ("png" . (image/png))
46 ("gif" . (image/gif))
47 ("woff" . (application/font-woff))
48 ("ttf" . (application/octet-stream))
49 ("html" . (text/html))))
50
51 (define (render-static-asset request)
52 (render-static-file (%config 'assets-dir) request))
53
54 (define %not-slash
55 (char-set-complement (char-set #\/)))
56
57 (define (render-static-file root request)
58 (define path
59 (uri-path (request-uri request)))
60
61 (define failure
62 (not-found (build-uri 'http
63 #:host (%config 'host)
64 #:port (%config 'port)
65 #:path path)))
66
67 (let ((file-name (string-append root "/" path)))
68 (if (not (any (cut string-contains <> "..")
69 (string-tokenize path %not-slash)))
70 (let* ((stat (stat file-name #f))
71 (modified (and stat
72 (make-time time-utc 0 (stat:mtime stat)))))
73 (define (send-file)
74 (list `((content-type
75 . ,(assoc-ref file-mime-types
76 (file-extension file-name)))
77 (last-modified . ,(time-utc->date modified)))
78 (call-with-input-file file-name get-bytevector-all)))
79
80 (if (and stat (not (eq? 'directory (stat:type stat))))
81 (cond ((assoc-ref (request-headers request) 'if-modified-since)
82 =>
83 (lambda (client-date)
84 (if (time>? modified (date->time-utc client-date))
85 (send-file)
86 (list (build-response #:code 304) ;"Not Modified"
87 #f))))
88 (else
89 (send-file)))
90 failure))
91 failure)))
92
93 (define* (render-html #:key sxml (extra-headers '()))
94 (list (append extra-headers
95 '((content-type . (text/html))))
96 (lambda (port)
97 (sxml->html sxml port))))
98
99 (define (render-json json)
100 (list '((content-type . (application/json)))
101 (lambda (port)
102 (scm->json json port))))
103
104 (define (not-found uri)
105 (list (build-response #:code 404)
106 (string-append "Resource not found: " (uri->string uri))))
107
108 (define (unprocessable-entity)
109 (list (build-response #:code 422)
110 ""))
111
112 (define (created)
113 (list (build-response #:code 201)
114 ""))
115
116 (define (redirect path)
117 (let ((uri (build-uri 'http
118 #:host (%config 'host)
119 #:port (%config 'port)
120 #:path (string-append
121 "/" (encode-and-join-uri-path path)))))
122 (list (build-response
123 #:code 301
124 #:headers `((content-type . (text/html))
125 (location . ,uri)))
126 (format #f "Redirect to ~a" (uri->string uri)))))