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)))))