Initial commit.
[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-26)
24 #:use-module (ice-9 binary-ports)
25 #:use-module (web response)
26 #:use-module (web uri)
27 #:use-module (json)
28 #:use-module (mumi config)
29 #:use-module (mumi web sxml)
30 #:use-module (mumi web util)
31 #:export (render-static-asset
32 render-html
33 render-json
34 not-found
35 unprocessable-entity
36 created
37 redirect))
38
39 (define file-mime-types
40 '(("css" . (text/css))
41 ("js" . (text/javascript))
42 ("png" . (image/png))
43 ("gif" . (image/gif))
44 ("woff" . (application/font-woff))
45 ("ttf" . (application/octet-stream))
46 ("html" . (text/html))))
47
48 (define (render-static-asset path)
49 (render-static-file (assoc-ref %config 'assets-dir) path))
50
51 (define (render-static-file root path)
52 ;; PATH is a list of path components
53 (let ((file-name (string-join (cons* root path) "/")))
54 (if (and (not (any (cut string-contains <> "..") path))
55 (file-exists? file-name)
56 (not (directory? file-name)))
57 (list `((content-type . ,(assoc-ref file-mime-types
58 (file-extension file-name))))
59 (call-with-input-file file-name get-bytevector-all))
60 (not-found (build-uri 'http
61 #:host (assoc-ref %config 'host)
62 #:port (assoc-ref %config 'port)
63 #:path (string-join path "/" 'prefix))))))
64
65 (define (render-html sxml)
66 (list '((content-type . (text/html)))
67 (lambda (port)
68 (sxml->html sxml port))))
69
70 (define (render-json json)
71 (list '((content-type . (application/json)))
72 (lambda (port)
73 (scm->json json port))))
74
75 (define (not-found uri)
76 (list (build-response #:code 404)
77 (string-append "Resource not found: " (uri->string uri))))
78
79 (define (unprocessable-entity)
80 (list (build-response #:code 422)
81 ""))
82
83 (define (created)
84 (list (build-response #:code 201)
85 ""))
86
87 (define (redirect path)
88 (let ((uri (build-uri 'http
89 #:host (assoc-ref %config 'host)
90 #:port (assoc-ref %config 'port)
91 #:path (string-append
92 "/" (encode-and-join-uri-path path)))))
93 (list (build-response
94 #:code 301
95 #:headers `((content-type . (text/html))
96 (location . ,uri)))
97 (format #f "Redirect to ~a" (uri->string uri)))))