From fc386dcb71d3691e19a08ac623e4ec4e9e97c4dc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 5 Dec 2010 20:23:01 +0100 Subject: 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. --- tekuti/cache.scm | 67 ++++++++++++++++++++++++++++++++++++++++---------------- tekuti/index.scm | 54 ++++++++++++++++++++++++++------------------- tekuti/web.scm | 43 ++++++++++++++++++++++-------------- 3 files changed, 106 insertions(+), 58 deletions(-) diff --git a/tekuti/cache.scm b/tekuti/cache.scm index 73228e0..4fef371 100644 --- a/tekuti/cache.scm +++ b/tekuti/cache.scm @@ -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)) - -(define (cache-ref cache master request) - (apply values (assoc-ref (cdr cache) (request-uri request)))) - -(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) - '()))) + (cacheable-request? request) + (or-map (lambda (entry) + (and ((entry-matcher entry) request) + (entry-response-body-pair entry))) + 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)) + (or cache '()))) diff --git a/tekuti/index.scm b/tekuti/index.scm index ab28d9c..da23423 100644 --- a/tekuti/index.scm +++ b/tekuti/index.scm @@ -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))))) diff --git a/tekuti/web.scm b/tekuti/web.scm index a6fad73..f81b59a 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -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))) -- cgit v1.2.3-54-g00ecf