Goodbye mu, hello guile-debbugs!
[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 (%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 (%config 'host)
62 #:port (%config 'port)
63 #:path (string-join path "/" 'prefix))))))
64
65 (define* (render-html #:key sxml (extra-headers '()))
66 (list (append extra-headers
67 '((content-type . (text/html))))
68 (lambda (port)
69 (sxml->html sxml port))))
70
71 (define (render-json json)
72 (list '((content-type . (application/json)))
73 (lambda (port)
74 (scm->json json port))))
75
76 (define (not-found uri)
77 (list (build-response #:code 404)
78 (string-append "Resource not found: " (uri->string uri))))
79
80 (define (unprocessable-entity)
81 (list (build-response #:code 422)
82 ""))
83
84 (define (created)
85 (list (build-response #:code 201)
86 ""))
87
88 (define (redirect path)
89 (let ((uri (build-uri 'http
90 #:host (%config 'host)
91 #:port (%config 'port)
92 #:path (string-append
93 "/" (encode-and-join-uri-path path)))))
94 (list (build-response
95 #:code 301
96 #:headers `((content-type . (text/html))
97 (location . ,uri)))
98 (format #f "Redirect to ~a" (uri->string uri)))))