From 839d2e27eb11a39dd3945052ba680c9c6d998296 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 6 Dec 2010 13:00:53 +0100 Subject: 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. --- tekuti/cache.scm | 88 ++++++++++++++++++++++++++++++++++++++----------- tekuti/page-helpers.scm | 3 ++ tekuti/page.scm | 12 +++++-- 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) -- cgit v1.2.3-54-g00ecf