fix caching

* tekuti/cache.scm: Update with more structure. Use take-max, not
  list-head. Only cache cacheable request-response pairs.

* tekuti/index.scm: Add cache as index entry. Also return the index ref
  within the index itself, instead of at the head.

* tekuti/web.scm: Don't pass cache around, it's part of the index
  now. Adapt to new API.

3 files changed, 106 insertions, 58 deletions

diff --git a/tekuti/cache.scm b/tekuti/cache.scm
index 73228e0..4fef371 100644
--- a/tekuti/cache.scm
+++ b/tekuti/cache.scm
@@ -20,29 +20,58 @@
 
 ;;; Commentary:
 ;;
-;; A cache for responses.
+;; A simple response cache.  The model is that all request-response
+;; pairs that the cache sees are fresh and valid.  The application can
+;; invalidate the cache simply by creating a new empty cache.
 ;;
 ;;; Code:
 
 (define-module (tekuti cache)
+  #:use-module (tekuti util)
   #:use-module (web request)
-  #:export (cache-hit?
-            cache-ref
-            cache-set))
+  #:use-module (web response)
+  #:export (make-empty-cache
+            cached-response-and-body
+            update-cache))
             
-(define (cache-hit? cache master request)
+(define (cacheable-request? request)
+  (and (memq (request-method request) '(GET HEAD))
+       (not (request-authorization request))))
+
+(define (cacheable-response? response)
+  (and (not (memq 'no-cache (response-pragma response)))
+       (not (member '(no-cache . #t) (response-cache-control response)))
+       (memq (response-code response) '(200 301 304 404 410))
+       (null? (response-vary response))))
+
+(define (make-empty-cache)
+  '())
+
+(define (make-entry matcher response body)
+  (cons matcher (cons response body)))
+(define (entry-matcher entry)
+  (car entry))
+(define (entry-response-body-pair entry)
+  (cdr entry))
+
+(define (cached-response-and-body cache request)
   (and cache
-       (equal? (car cache) master)
-       (eq? (request-method request) 'GET)
-       (assoc (request-uri request) (cdr cache))
-       #t))
-
-(define (cache-ref cache master request)
-  (apply values (assoc-ref (cdr cache) (request-uri request))))
-
-(define (cache-set cache master request . args)
-  (cons* master
-         (cons (request-uri request) args)
-         (if (and cache (equal? (car cache) master))
-             (list-head (cdr cache) 9)
-             '())))
+       (cacheable-request? request)
+       (or-map (lambda (entry)
+                 (and ((entry-matcher entry) request)
+                      (entry-response-body-pair entry)))
+               cache)))
+
+(define (make-matcher request response)
+  (let ((uri (request-uri request))
+        (method (request-method request)))
+    (lambda (request)
+      (and (equal? (request-uri request) uri)
+           (eq? (request-method request) method)))))
+
+(define (update-cache cache request response body)
+  (if (and (cacheable-request? request)
+           (cacheable-response? response))
+      (cons (make-entry (make-matcher request response) response body)
+            (take-max (or cache '()) 9))
+      (or cache '())))
diff --git a/tekuti/index.scm b/tekuti/index.scm
index ab28d9c..da23423 100644
--- a/tekuti/index.scm
+++ b/tekuti/index.scm
@@ -30,11 +30,13 @@
   #:use-module (tekuti git)
   #:use-module (tekuti post)
   #:use-module (tekuti tags)
-  #:export (maybe-reindex read-index))
+  #:use-module (tekuti cache)
+  #:export (maybe-reindex read-index update-index))
 
 (define index-specs
   `((posts ,reindex-posts ,write ,read)
-    (tags ,reindex-tags ,write-hash ,read-hash)))
+    (tags ,reindex-tags ,write-hash ,read-hash)
+    (cache ,(lambda _ (make-empty-cache)) ,(lambda (x) #f) ,(lambda () '()))))
 
 (define (reindex oldindex master)
   (with-time-debugging
@@ -60,11 +62,14 @@
 (define (write-index index oldref)
   (let ((new (git-commit-tree
               (git-mktree
-               (pk (map (lambda (pair)
-                          (list (car pair)
-                                (index->blob (car pair) (cdr pair))
-                                'blob))
-                        index)))
+               (let lp ((index index))
+                 (cond
+                  ((null? index) '())
+                  ((eq? (caar index) 'index) (lp (cdr index)))
+                  (else (cons (list (caar index)
+                                    (index->blob (caar index) (cdar index))
+                                    'blob)
+                              (lp (cdr index)))))))
               oldref "reindex\n"
               (commit-utc-timestamp (assq-ref index 'master)))))
     (or (false-if-git-error
@@ -75,26 +80,31 @@
 (define (read-index)
   (let* ((ref (false-if-git-error (git-rev-parse "refs/heads/index")))
          (dents (if ref (git-ls-tree ref #f) '())))
-    (cons ref
-          (and (and-map (lambda (spec)
-                          (assoc (symbol->string (car spec)) dents))
-                        index-specs)
-               (map (lambda (dent)
-                      (cons (string->symbol (car dent))
-                            (blob->index (car dent) (cadr dent))))
-                    dents)))))
+    (acons 'index ref
+           (and (and-map (lambda (spec)
+                           (assoc (symbol->string (car spec)) dents))
+                         index-specs)
+                (map (lambda (dent)
+                       (cons (string->symbol (car dent))
+                             (blob->index (car dent) (cadr dent))))
+                     dents)))))
 
 (define (maybe-reindex old-index)
-  (let ((master (git-rev-parse "refs/heads/master"))
-        (old-index-sha1 (and=> old-index car))
-        (old-index-data (if old-index (cdr old-index) '())))
-    (if (equal? (assq-ref old-index-data 'master) master)
+  (let ((master (git-rev-parse "refs/heads/master")))
+    (if (equal? (assq-ref old-index 'master) master)
         old-index
         (catch #t
                (lambda ()
-                 (let ((new-index (reindex old-index-data master)))
-                   (cons (write-index new-index old-index-sha1)
-                         new-index)))
+                 (let ((new-index (reindex old-index master)))
+                   (acons
+                    'index (write-index new-index (assq-ref old-index 'index))
+                    new-index)))
                (lambda (key . args)
                  (warn "error while reindexing:" key args)
                  old-index)))))
+
+(define (update-index index key update)
+  (cond
+   ((null? index) (acons key (update '()) '()))
+   ((eq? (caar index) key) (acons key (update index) (cdr index)))
+   (else (cons (car index) (update-index (cdr index) key update)))))
diff --git a/tekuti/web.scm b/tekuti/web.scm
index a6fad73..f81b59a 100644
--- a/tekuti/web.scm
+++ b/tekuti/web.scm
@@ -58,29 +58,38 @@
    ((GET debug) page-debug)
    (else page-not-found)))
 
-(define handler
-  (lambda (request body index cache)
-    (let ((index (maybe-reindex index)))
-      (call-with-values
-          (lambda ()
-            (if (cache-hit? cache (car index) request)
-                (cache-ref cache (car index) request)
-                (call-with-values
-                    (lambda ()
-                      ((choose-handler request) request body (cdr index)))
-                  (lambda (response body)
-                    (sanitize-response request response body)))))
+(define (cache-ref index request)
+  (cached-response-and-body (assq-ref index 'cache) request))
+
+(define (cache-set index request response body)
+  (update-index
+   (maybe-reindex index)
+   'cache
+   (lambda (index)
+     (update-cache (assq-ref index 'cache) request response body))))
+
+(define (handler request body index)
+  (let ((index (maybe-reindex index)))
+    (cond
+     ((cache-ref index request)
+      => (lambda (cached)
+           (values (car cached) (cdr cached) index)))
+     (else
+      (call-with-values (lambda ()
+                          ((choose-handler request) request body index))
         (lambda (response body)
-          (values response body index
-                  (cache-set cache (car index) request response body)))))))
+          (call-with-values (lambda ()
+                              (sanitize-response request response body))
+            (lambda (response body)
+              (let ((index (cache-set index request response body)))
+                (values response body index))))))))))
 
 ;; The seemingly useless lambda is to allow for `handler' to be
 ;; redefined at runtime.
 (define (main-loop)
-  (run-server (lambda (r b i c) (handler r b i c))
+  (run-server (lambda (r b i) (handler r b i))
               *server-impl*
               (if (list? *server-impl-args*)
                   *server-impl-args*
                   (*server-impl-args*))
-              (read-index)
-              #f))
+              (read-index)))