fix caching
* 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
parent
aa86b62d79
commit
fc386dcb71
3 changed files with 104 additions and 56 deletions
|
|
@ -20,29 +20,58 @@
|
|||
|
||||
;;; 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:
|
||||
|
||||
(define-module (tekuti cache)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (web request)
|
||||
#:export (cache-hit?
|
||||
cache-ref
|
||||
cache-set))
|
||||
#:use-module (web response)
|
||||
#:export (make-empty-cache
|
||||
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
|
||||
(equal? (car cache) master)
|
||||
(eq? (request-method request) 'GET)
|
||||
(assoc (request-uri request) (cdr cache))
|
||||
#t))
|
||||
(cacheable-request? request)
|
||||
(or-map (lambda (entry)
|
||||
(and ((entry-matcher entry) request)
|
||||
(entry-response-body-pair entry)))
|
||||
cache)))
|
||||
|
||||
(define (cache-ref cache master request)
|
||||
(apply values (assoc-ref (cdr cache) (request-uri request))))
|
||||
(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 (cache-set cache master request . args)
|
||||
(cons* master
|
||||
(cons (request-uri request) args)
|
||||
(if (and cache (equal? (car cache) master))
|
||||
(list-head (cdr cache) 9)
|
||||
'())))
|
||||
(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))
|
||||
(or cache '())))
|
||||
|
|
|
|||
|
|
@ -30,11 +30,13 @@
|
|||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti tags)
|
||||
#:export (maybe-reindex read-index))
|
||||
#:use-module (tekuti cache)
|
||||
#:export (maybe-reindex read-index update-index))
|
||||
|
||||
(define index-specs
|
||||
`((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)
|
||||
(with-time-debugging
|
||||
|
|
@ -60,11 +62,14 @@
|
|||
(define (write-index index oldref)
|
||||
(let ((new (git-commit-tree
|
||||
(git-mktree
|
||||
(pk (map (lambda (pair)
|
||||
(list (car pair)
|
||||
(index->blob (car pair) (cdr pair))
|
||||
'blob))
|
||||
index)))
|
||||
(let lp ((index index))
|
||||
(cond
|
||||
((null? index) '())
|
||||
((eq? (caar index) 'index) (lp (cdr index)))
|
||||
(else (cons (list (caar index)
|
||||
(index->blob (caar index) (cdar index))
|
||||
'blob)
|
||||
(lp (cdr index)))))))
|
||||
oldref "reindex\n"
|
||||
(commit-utc-timestamp (assq-ref index 'master)))))
|
||||
(or (false-if-git-error
|
||||
|
|
@ -75,26 +80,31 @@
|
|||
(define (read-index)
|
||||
(let* ((ref (false-if-git-error (git-rev-parse "refs/heads/index")))
|
||||
(dents (if ref (git-ls-tree ref #f) '())))
|
||||
(cons ref
|
||||
(and (and-map (lambda (spec)
|
||||
(assoc (symbol->string (car spec)) dents))
|
||||
index-specs)
|
||||
(map (lambda (dent)
|
||||
(cons (string->symbol (car dent))
|
||||
(blob->index (car dent) (cadr dent))))
|
||||
dents)))))
|
||||
(acons 'index ref
|
||||
(and (and-map (lambda (spec)
|
||||
(assoc (symbol->string (car spec)) dents))
|
||||
index-specs)
|
||||
(map (lambda (dent)
|
||||
(cons (string->symbol (car dent))
|
||||
(blob->index (car dent) (cadr dent))))
|
||||
dents)))))
|
||||
|
||||
(define (maybe-reindex old-index)
|
||||
(let ((master (git-rev-parse "refs/heads/master"))
|
||||
(old-index-sha1 (and=> old-index car))
|
||||
(old-index-data (if old-index (cdr old-index) '())))
|
||||
(if (equal? (assq-ref old-index-data 'master) master)
|
||||
(let ((master (git-rev-parse "refs/heads/master")))
|
||||
(if (equal? (assq-ref old-index 'master) master)
|
||||
old-index
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(let ((new-index (reindex old-index-data master)))
|
||||
(cons (write-index new-index old-index-sha1)
|
||||
new-index)))
|
||||
(let ((new-index (reindex old-index master)))
|
||||
(acons
|
||||
'index (write-index new-index (assq-ref old-index 'index))
|
||||
new-index)))
|
||||
(lambda (key . args)
|
||||
(warn "error while reindexing:" key args)
|
||||
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)))))
|
||||
|
|
|
|||
|
|
@ -58,29 +58,38 @@
|
|||
((GET debug) page-debug)
|
||||
(else page-not-found)))
|
||||
|
||||
(define handler
|
||||
(lambda (request body index cache)
|
||||
(let ((index (maybe-reindex index)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(if (cache-hit? cache (car index) request)
|
||||
(cache-ref cache (car index) request)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
((choose-handler request) request body (cdr index)))
|
||||
(lambda (response body)
|
||||
(sanitize-response request response body)))))
|
||||
(define (cache-ref index request)
|
||||
(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)))
|
||||
(cond
|
||||
((cache-ref index request)
|
||||
=> (lambda (cached)
|
||||
(values (car cached) (cdr cached) index)))
|
||||
(else
|
||||
(call-with-values (lambda ()
|
||||
((choose-handler request) request body index))
|
||||
(lambda (response body)
|
||||
(values response body index
|
||||
(cache-set cache (car index) request response body)))))))
|
||||
(call-with-values (lambda ()
|
||||
(sanitize-response request response body))
|
||||
(lambda (response body)
|
||||
(let ((index (cache-set index request response body)))
|
||||
(values response body index))))))))))
|
||||
|
||||
;; The seemingly useless lambda is to allow for `handler' to be
|
||||
;; redefined at runtime.
|
||||
(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*
|
||||
(if (list? *server-impl-args*)
|
||||
*server-impl-args*
|
||||
(*server-impl-args*))
|
||||
(read-index)
|
||||
#f))
|
||||
(read-index)))
|
||||
|
|
|
|||
Loading…
Reference in a new issue