render: Allow clients to cache static files.

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