aliens/tekuti
1
0
Fork 0
Code Activity

cache returns 304 as appropriate; more pages set etags

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-12-06 13:00:53 +01:00
parent 15f024a12d
commit 839d2e27eb
3 changed files with 81 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

88
tekuti/cache.scm
View file

@ -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 '())))

3
tekuti/page-helpers.scm
View file

@ -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

12
tekuti/page.scm
View file

@ -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)