aliens/tekuti
1
0
Fork 0
Code Activity

fix caching

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-12-05 20:23:01 +01:00
parent aa86b62d79
commit fc386dcb71
3 changed files with 104 additions and 56 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

63
tekuti/cache.scm
View file

@ -20,29 +20,58 @@
;;; Commentary: ;;; 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: ;;; Code:
(define-module (tekuti cache) (define-module (tekuti cache)
#:use-module (tekuti util)
#:use-module (web request) #:use-module (web request)
#:export (cache-hit? #:use-module (web response)
cache-ref #:export (make-empty-cache
cache-set)) 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 (and cache
(equal? (car cache) master) (cacheable-request? request)
(eq? (request-method request) 'GET) (or-map (lambda (entry)
(assoc (request-uri request) (cdr cache)) (and ((entry-matcher entry) request)
#t)) (entry-response-body-pair entry)))
cache)))
(define (cache-ref cache master request) (define (make-matcher request response)
(apply values (assoc-ref (cdr cache) (request-uri request)))) (let ((uri (request-uri request))
(method (request-method request)))
(lambda (request)
(and (equal? (request-uri request) uri)
(eq? (request-method request) method)))))
(define (cache-set cache master request . args) (define (update-cache cache request response body)
(cons* master (if (and (cacheable-request? request)
(cons (request-uri request) args) (cacheable-response? response))
(if (and cache (equal? (car cache) master)) (cons (make-entry (make-matcher request response) response body)
(list-head (cdr cache) 9) (take-max (or cache '()) 9))
'()))) (or cache '())))

38
tekuti/index.scm
View file

@ -30,11 +30,13 @@
#:use-module (tekuti git) #:use-module (tekuti git)
#:use-module (tekuti post) #:use-module (tekuti post)
#:use-module (tekuti tags) #:use-module (tekuti tags)
#:export (maybe-reindex read-index)) #:use-module (tekuti cache)
#:export (maybe-reindex read-index update-index))
(define index-specs (define index-specs
`((posts ,reindex-posts ,write ,read) `((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) (define (reindex oldindex master)
(with-time-debugging (with-time-debugging
@ -60,11 +62,14 @@
(define (write-index index oldref) (define (write-index index oldref)
(let ((new (git-commit-tree (let ((new (git-commit-tree
(git-mktree (git-mktree
(pk (map (lambda (pair) (let lp ((index index))
(list (car pair) (cond
(index->blob (car pair) (cdr pair)) ((null? index) '())
'blob)) ((eq? (caar index) 'index) (lp (cdr index)))
index))) (else (cons (list (caar index)
(index->blob (caar index) (cdar index))
'blob)
(lp (cdr index)))))))
oldref "reindex\n" oldref "reindex\n"
(commit-utc-timestamp (assq-ref index 'master))))) (commit-utc-timestamp (assq-ref index 'master)))))
(or (false-if-git-error (or (false-if-git-error
@ -75,7 +80,7 @@
(define (read-index) (define (read-index)
(let* ((ref (false-if-git-error (git-rev-parse "refs/heads/index"))) (let* ((ref (false-if-git-error (git-rev-parse "refs/heads/index")))
(dents (if ref (git-ls-tree ref #f) '()))) (dents (if ref (git-ls-tree ref #f) '())))
(cons ref (acons 'index ref
(and (and-map (lambda (spec) (and (and-map (lambda (spec)
(assoc (symbol->string (car spec)) dents)) (assoc (symbol->string (car spec)) dents))
index-specs) index-specs)
@ -85,16 +90,21 @@
dents))))) dents)))))
(define (maybe-reindex old-index) (define (maybe-reindex old-index)
(let ((master (git-rev-parse "refs/heads/master")) (let ((master (git-rev-parse "refs/heads/master")))
(old-index-sha1 (and=> old-index car)) (if (equal? (assq-ref old-index 'master) master)
(old-index-data (if old-index (cdr old-index) '())))
(if (equal? (assq-ref old-index-data 'master) master)
old-index old-index
(catch #t (catch #t
(lambda () (lambda ()
(let ((new-index (reindex old-index-data master))) (let ((new-index (reindex old-index master)))
(cons (write-index new-index old-index-sha1) (acons
'index (write-index new-index (assq-ref old-index 'index))
new-index))) new-index)))
(lambda (key . args) (lambda (key . args)
(warn "error while reindexing:" key args) (warn "error while reindexing:" key args)
old-index))))) 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)))))

39
tekuti/web.scm
View file

@ -58,29 +58,38 @@
((GET debug) page-debug) ((GET debug) page-debug)
(else page-not-found))) (else page-not-found)))
(define handler (define (cache-ref index request)
(lambda (request body index cache) (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))) (let ((index (maybe-reindex index)))
(call-with-values (cond
(lambda () ((cache-ref index request)
(if (cache-hit? cache (car index) request) => (lambda (cached)
(cache-ref cache (car index) request) (values (car cached) (cdr cached) index)))
(call-with-values (else
(lambda () (call-with-values (lambda ()
((choose-handler request) request body (cdr index))) ((choose-handler request) request body index))
(lambda (response body) (lambda (response body)
(sanitize-response request response body))))) (call-with-values (lambda ()
(sanitize-response request response body))
(lambda (response body) (lambda (response body)
(values response body index (let ((index (cache-set index request response body)))
(cache-set cache (car index) request response body))))))) (values response body index))))))))))
;; The seemingly useless lambda is to allow for `handler' to be ;; The seemingly useless lambda is to allow for `handler' to be
;; redefined at runtime. ;; redefined at runtime.
(define (main-loop) (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* *server-impl*
(if (list? *server-impl-args*) (if (list? *server-impl-args*)
*server-impl-args* *server-impl-args*
(*server-impl-args*)) (*server-impl-args*))
(read-index) (read-index)))
#f))