Use guile parameters

With parameters, the API does not need to care about the directory
where to load files and how to get the time.

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