cache returns 304 as appropriate; more pages set etags

* tekuti/cache.scm (update-cache): Expand cache size back to 20.
  (cached-response-and-body, make-entry): Entries are now procedures
  that return the cached pair. They also have some more smarts regarding
  etags, last-modified, and conditional requests.

* tekuti/page-helpers.scm (respond): Add etag arg. Set a date.

* tekuti/page.scm: Set etags on a number of pages.

3 files changed, 81 insertions, 22 deletions

diff --git a/tekuti/cache.scm b/tekuti/cache.scm
index 4fef371..8674f9b 100644
--- a/tekuti/cache.scm
+++ b/tekuti/cache.scm
@@ -30,13 +30,19 @@
   #:use-module (tekuti util)
   #:use-module (web request)
   #:use-module (web response)
+  #:use-module (srfi srfi-19)
   #:export (make-empty-cache
             cached-response-and-body
             update-cache))
             
 (define (cacheable-request? request)
   (and (memq (request-method request) '(GET HEAD))
-       (not (request-authorization request))))
+       (not (request-authorization request))
+       ;; We don't cache these conditional requests; just
+       ;; if-modified-since and if-none-match.
+       (not (request-if-match request))
+       (not (request-if-range request))
+       (not (request-if-unmodified-since request))))
 
 (define (cacheable-response? response)
   (and (not (memq 'no-cache (response-pragma response)))
@@ -47,31 +53,75 @@
 (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-syntax build-headers
+  (syntax-rules ()
+    ((_ k v-exp rest ...)
+     (let ((v v-exp))
+       (let ((tail (build-headers rest ...)))
+         (if v
+             (acons 'k v tail)
+             tail))))
+    ((_ tail)
+     tail)))
+
+(define (make-entry request response body)
+  (let ((uri (request-uri request))
+        (method (request-method request)))
+    (case (response-code response)
+      ((304)
+       (lambda (request)
+         (and (equal? (request-uri request) uri)
+              (eq? (request-method request) method)
+              (let ((last-modified (response-last-modified response))
+                    (since (request-if-modified-since request)))
+                (if (and last-modified since)
+                    (<= (date->time-utc last-modified) (date->time-utc since))
+                    #t))
+              (let ((etag (response-etag response))
+                    (match (request-if-none-match request)))
+                (if (and etag match)
+                    (and (list? match) (member etag match))
+                    #t))
+              (cons response body))))
+      ((200)
+       (lambda (request)
+         (and (equal? (request-uri request) uri)
+              (eq? (request-method request) method)
+              (or (let ((last-modified (response-last-modified response))
+                        (since (request-if-modified-since request))
+                        (etag (response-etag response))
+                        (match (request-if-none-match request)))
+                    (and (or since match)
+                         (or (not since)
+                             (and last-modified
+                                  (<= (date->time-utc last-modified)
+                                      (date->time-utc since))))
+                         (or (not match)
+                             (and etag (list? match) (member etag match)))
+                         (cons (build-response
+                                #:code 304
+                                #:headers (build-headers
+                                           etag etag
+                                           last-modified last-modified
+                                           date (current-date)
+                                           '()))
+                               #f)))
+                  (cons response body)))))
+      (else
+       (lambda (request)
+         (and (equal? (request-uri request) uri)
+              (eq? (request-method request) method)
+              (cons response body)))))))
 
 (define (cached-response-and-body cache request)
   (and cache
        (cacheable-request? request)
-       (or-map (lambda (entry)
-                 (and ((entry-matcher entry) request)
-                      (entry-response-body-pair entry)))
+       (or-map (lambda (entry) (entry request))
                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))
+      (cons (make-entry request response body)
+            (take-max (or cache '()) 19))
       (or cache '())))
diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm
index a76074e..feba568 100644
--- a/tekuti/page-helpers.scm
+++ b/tekuti/page-helpers.scm
@@ -80,6 +80,7 @@
                   (status (if redirect 302 200))
                   (title *title*)
                   last-modified
+                  etag
                   (doctype xhtml-doctype)
                   (content-type-params '(("charset" . "utf-8")))
                   (content-type "text/html")
@@ -91,6 +92,8 @@
                       location (and=> redirect ensure-public-uri)
                       last-modified last-modified
                       content-type (cons content-type content-type-params)
+                      date (current-date)
+                      etag (if (string? etag) (cons etag #t) etag)
                       extra-headers))
           (lambda (port)
             (if sxml
diff --git a/tekuti/page.scm b/tekuti/page.scm
index 9d0de95..ac7af87 100644
--- a/tekuti/page.scm
+++ b/tekuti/page.scm
@@ -171,7 +171,8 @@
   (respond `(,(main-sidebar request index)
              ,@(map (lambda (post)
                       (show-post post #f))
-                    (published-posts index 10)))))
+                    (published-posts index 10)))
+           #:etag (assq-ref index 'master)))
 
 (define (page-show-post request body index year month day post)
   (cond
@@ -180,7 +181,8 @@
     => (lambda (post)
          (respond `(,(post-sidebar post index)
                     ,(show-post post #t))
-                  #:title (string-append (post-title post) " -- " *title*))))
+                  #:title (string-append (post-title post) " -- " *title*)
+                  #:etag (assq-ref index 'master))))
    (else
     (page-not-found request body index))))
 
@@ -233,7 +235,8 @@
                  (cond
                   ((or (null? posts) (too-early? (car posts)))
                    (respond (reverse out)
-                            #:title (string-append "archives -- " *title*)))
+                            #:title (string-append "archives -- " *title*)
+                            #:etag (assq-ref index 'master)))
                   ((new-header (car posts))
                    => (lambda (sxml)
                         (lp (cdr posts) (make-date-header (car posts))
@@ -256,6 +259,7 @@
   (respond `((div (@ (id "tag-cloud"))
                   (h2 "all tags")
                   ,@(tag-cloud (top-tags index 200))))
+           #:etag (assq-ref index 'master)
            #:title (string-append "all tags -- " *title*)))
 
 (define (page-show-tag request body index tag)
@@ -268,6 +272,7 @@
                    ,@(map (lambda (post) `(p ,(post-link post)))
                           posts)
                    ,(related-tag-cloud tag index)) 
+                 #:etag (assq-ref index 'master)
                  #:title (string-append "posts tagged \"" tag "\""))
         (respond `((h2 "Unknown tag " ,tag)
                    (p "No posts were found tagged as \"" ,tag "\"."))
@@ -305,6 +310,7 @@
                #:last-modified (and=> last-modified timestamp->date)
                #:doctype #f
                #:content-type "application/atom+xml"
+               #:etag (assq-ref index 'master)
                #:sxml (append (atom-header last-modified)
                               (map
                                (lambda (post)