1 files changed, 69 insertions, 19 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 '())))