diff options
Diffstat (limited to 'src/scm/webid-oidc/cache.scm')
| -rw-r--r-- | src/scm/webid-oidc/cache.scm | 171 |
1 files changed, 72 insertions, 99 deletions
diff --git a/src/scm/webid-oidc/cache.scm b/src/scm/webid-oidc/cache.scm index dbf0112..e98f87f 100644 --- a/src/scm/webid-oidc/cache.scm +++ b/src/scm/webid-oidc/cache.scm @@ -16,6 +16,7 @@ (define-module (webid-oidc cache) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web client) #:use-module (web request) #:use-module (web response) @@ -24,7 +25,17 @@ #:use-module (ice-9 receive) #:use-module (ice-9 optargs) #:use-module (srfi srfi-19) - #:use-module (rnrs bytevectors)) + #:use-module (rnrs bytevectors) + #:export + ( + clean-cache + add + read + varies? + valid? + revalidate + with-cache + )) ;; The cache follows the recommendations of ;; https://developer.mozilla.org/en-US/docs/Web/HTTP/Caching @@ -48,36 +59,26 @@ ;; There is a global lock file at the root of the cache, which serves ;; for region locking. Do not remove it! -(define (default-cache-dir) - (let ((xdg-cache-home - (or (getenv "XDG_CACHE_HOME") - (format #f "~a/.cache" (getenv "HOME"))))) - (format #f "~a/disfluid" xdg-cache-home))) +(define (web-cache-dir) + (string-append (p:cache-home) "/web-cache/")) -(define (web-cache-dir dir) - (when (thunk? dir) - (set! dir (dir))) - (string-append dir - "/web-cache/")) - -(define (file-name uri dir) +(define (file-name uri) (when (string? uri) (set! uri (string->uri uri))) - (string-append (web-cache-dir dir) + (string-append (web-cache-dir) (stubs:hash 'SHA-256 (uri->string uri)))) -(define (lock-file-name dir) - (string-append (web-cache-dir dir) ".lock")) +(define (lock-file-name) + (string-append (web-cache-dir) ".lock")) (define (event? percents) (<= (* (random:uniform) 100) percents)) -(define*-public (clean-cache - #:key - (percents 5) - (dir default-cache-dir)) - (define lock-file (lock-file-name dir)) +(define* (clean-cache + #:key + (percents 5)) + (define lock-file (lock-file-name)) (define (survives?) (not (event? percents))) (define (enter? name stat result) @@ -104,14 +105,13 @@ name (strerror errno)) result) (file-system-fold enter? leaf down up skip error 0 - (web-cache-dir dir))) + (web-cache-dir))) (define (maybe-clean-cache pc-happen - pc-cleaned - dir) + pc-cleaned) (when (event? pc-happen) - (clean-cache #:percents pc-cleaned #:dir dir))) + (clean-cache #:percents pc-cleaned))) (define (remove-uncacheable-headers response) (let ((headers (response-headers response))) @@ -129,16 +129,15 @@ #:headers filtered #:port #f)))) -(define*-public (add request response response-body - #:key (dir default-cache-dir)) +(define (add request response response-body) ;; Don’t store it if there’s a cache-control no-store (unless (let ((cc (response-cache-control response '()))) (assq-ref cc 'no-store)) (set! response (remove-uncacheable-headers response)) - (let ((final-file-name (file-name (request-uri request) dir)) - (lock-file (lock-file-name dir))) - (maybe-clean-cache 5 5 dir) + (let ((final-file-name (file-name (request-uri request))) + (lock-file (lock-file-name))) + (maybe-clean-cache 5 5) (stubs:atomically-update-file final-file-name lock-file @@ -152,14 +151,8 @@ (write-response-body file-response response-body)) #t)))))) -(define (the-current-time) - (time-utc->date - (current-time))) - -(define*-public (read uri - #:key - (dir default-cache-dir)) - (let ((final-file-name (file-name uri dir))) +(define (read uri) + (let ((final-file-name (file-name uri))) (catch 'system-error (lambda () (call-with-input-file final-file-name @@ -183,60 +176,46 @@ (or (varies-header? request-a request-b (car headers)) (varies-any-header? request-a request-b (cdr headers))))) -(define-public (varies? request-a request-b response) +(define (varies? request-a request-b response) (let ((vary (response-vary response))) (or (eq? vary '*) (varies-any-header? request-a request-b vary)))) -(define*-public (valid? response - #:key - (current-time the-current-time)) - (when (thunk? current-time) - (set! current-time (current-time))) - (when (integer? current-time) - (set! current-time - (make-time time-utc 0 current-time))) - (when (time? current-time) - (set! current-time (time-utc->date current-time))) - (set! current-time - (date->time-utc current-time)) - (set! current-time - (time-second current-time)) - (let ((cc (response-cache-control response #f)) - (date (response-date response - (time-utc->date - (make-time time-utc 0 current-time)))) - (last-modified (response-last-modified response))) - (set! date (date->time-utc date)) - (set! date (time-second date)) - (when last-modified - (set! last-modified (date->time-utc last-modified)) - (set! last-modified (time-second last-modified))) - (if cc - ;; Use cache-control - (let ((cc-no-cache (assq-ref cc 'no-cache)) - (cc-no-store (assq-ref cc 'no-store)) - (cc-max-age - (or (assq-ref cc 'max-age) - ;; Heuristic freshness - (and last-modified - (/ (- date last-modified) 10))))) - (and (not cc-no-cache) - (not cc-no-store) - cc-max-age - (>= (+ date cc-max-age) current-time))) - ;; Use expires - (let ((exp (response-expires response))) - (when exp - (set! exp (date->time-utc exp)) - (set! exp (time-second exp))) - (and exp - (>= exp current-time)))))) +(define (valid? response) + ;; current-date is a thunk parameter + (let* ((current-date ((p:current-date))) + (current-time (time-second (date->time-utc current-date)))) + (let ((cc (response-cache-control response #f)) + (date (time-second (date->time-utc (response-date response current-date)))) + (last-modified + (let ((as-date (response-last-modified response))) + (and as-date + (time-second (date->time-utc as-date)))))) + (if cc + ;; Use cache-control + (let ((cc-no-cache (assq-ref cc 'no-cache)) + (cc-no-store (assq-ref cc 'no-store)) + (cc-max-age + (or (assq-ref cc 'max-age) + ;; Heuristic freshness + (and last-modified + (/ (- date last-modified) 10))))) + (and (not cc-no-cache) + (not cc-no-store) + cc-max-age + (>= (+ date cc-max-age) current-time))) + ;; Use expires + (let ((exp + (let ((as-date (response-expires response))) + (and as-date + (time-second (date->time-utc as-date)))))) + (and exp + (>= exp current-time))))))) -(define*-public (revalidate uri response body - #:key - (headers '()) - (http-get http-get)) +(define* (revalidate uri response body + #:key + (headers '()) + (http-get http-get)) (define (keep-header? h) (case (car h) ((if-none-match if-unmodified-since) #f) @@ -266,20 +245,14 @@ (values new-response new-response-body))) (http-get uri #:headers headers)))) -(define*-public (with-cache - #:key - (current-time the-current-time) - (http-get http-get) - (dir default-cache-dir)) +(define* (with-cache #:key (http-get http-get)) (lambda* (uri #:key (headers '())) (when (string? uri) (set! uri (string->uri uri))) - (let ((dir (if (thunk? dir) (dir) dir)) - (request (build-request uri #:headers headers))) - (receive (stored-request stored-response body) - (read uri #:dir dir) + (let ((request (build-request uri #:headers headers))) + (receive (stored-request stored-response body) (read uri) (if stored-response - (let ((valid (valid? stored-response #:current-time the-current-time)) + (let ((valid (valid? stored-response)) (invariant (not (varies? request stored-request stored-response)))) (unless invariant (format (current-error-port) "Cache entry for ~a varies.\n" (uri->string uri))) @@ -289,9 +262,9 @@ (revalidate uri stored-response body #:headers headers #:http-get http-get) - (add request final-response final-body #:dir dir) + (add request final-response final-body) (values final-response final-body)))) (receive (final-response final-body) (http-get uri #:headers headers) - (add request final-response final-body #:dir dir) + (add request final-response final-body) (values final-response final-body))))))) |