diff options
-rw-r--r-- | mumi/web/controller.scm | 2 | ||||
-rw-r--r-- | mumi/web/render.scm | 57 |
2 files changed, 43 insertions, 16 deletions
diff --git a/mumi/web/controller.scm b/mumi/web/controller.scm index 0b2ff73..5d9ea17 100644 --- a/mumi/web/controller.scm +++ b/mumi/web/controller.scm @@ -93,4 +93,4 @@ ((GET "issue" not-an-id) (apply render-html (unknown not-an-id))) ((GET path ...) - (render-static-asset path)))) + (render-static-asset request)))) diff --git a/mumi/web/render.scm b/mumi/web/render.scm index c67a124..3b69e55 100644 --- a/mumi/web/render.scm +++ b/mumi/web/render.scm @@ -20,8 +20,10 @@ (define-module (mumi web render) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 binary-ports) + #:use-module (web request) #:use-module (web response) #:use-module (web uri) #:use-module (json) @@ -45,22 +47,47 @@ ("ttf" . (application/octet-stream)) ("html" . (text/html)))) -(define (render-static-asset path) - (render-static-file (%config 'assets-dir) path)) +(define (render-static-asset request) + (render-static-file (%config 'assets-dir) request)) -(define (render-static-file root path) - ;; PATH is a list of path components - (let ((file-name (string-join (cons* root path) "/"))) - (if (and (not (any (cut string-contains <> "..") path)) - (file-exists? file-name) - (not (directory? file-name))) - (list `((content-type . ,(assoc-ref file-mime-types - (file-extension file-name)))) - (call-with-input-file file-name get-bytevector-all)) - (not-found (build-uri 'http - #:host (%config 'host) - #:port (%config 'port) - #:path (string-join path "/" 'prefix)))))) +(define %not-slash + (char-set-complement (char-set #\/))) + +(define (render-static-file root request) + (define path + (uri-path (request-uri request))) + + (define failure + (not-found (build-uri 'http + #:host (%config 'host) + #:port (%config 'port) + #:path path))) + + (let ((file-name (string-append root "/" path))) + (if (not (any (cut string-contains <> "..") + (string-tokenize path %not-slash))) + (let* ((stat (stat file-name #f)) + (modified (and stat + (make-time time-utc 0 (stat:mtime stat))))) + (define (send-file) + (list `((content-type + . ,(assoc-ref file-mime-types + (file-extension file-name))) + (last-modified . ,(time-utc->date modified))) + (call-with-input-file file-name get-bytevector-all))) + + (if (and stat (not (eq? 'directory (stat:type stat)))) + (cond ((assoc-ref (request-headers request) 'if-modified-since) + => + (lambda (client-date) + (if (time>? modified (date->time-utc client-date)) + (send-file) + (list (build-response #:code 304) ;"Not Modified" + #f)))) + (else + (send-file))) + failure)) + failure))) (define* (render-html #:key sxml (extra-headers '())) (list (append extra-headers |