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, 27 insertions, 83 deletions

diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index e8796c0..67928db 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -21,8 +21,8 @@
   #:use-module (webid-oidc oidc-id-token)
   #:use-module (webid-oidc dpop-proof)
   #:use-module (webid-oidc jwk)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
-  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
   #:use-module (web uri)
   #:use-module (web client)
@@ -174,28 +174,17 @@
                 (raise-no-provider-candidates host-or-webid candidate-errors))
               final-candidates))))))
 
-(define the-current-time current-time)
-
 (define*-public (token host client-key
                        #:key
                        (authorization-code #f)
                        (refresh-token #f)
                        (http-get http-get)
-                       (http-post http-post)
-                       (current-time #f))
+                       (http-post http-post))
   (unless (or authorization-code refresh-token)
     (scm-error 'wrong-type-arg "token"
                "You need to either set #:authorization-code or #:refresh-token."
                '()
                (list authorization-code)))
-  (unless current-time
-    (set! 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)))
   (let ((token-endpoint
          (oidc-configuration-token-endpoint
           (get-oidc-configuration host #:http-get http-get)))
@@ -212,8 +201,7 @@
                     (else
                      (error "Unknown key type of ~S." client-key)))
             #:htm 'POST
-            #:htu token-endpoint
-            #:iat current-time)))
+            #:htu token-endpoint)))
       (receive (response response-body)
           (http-post token-endpoint
                      #:body
@@ -253,17 +241,7 @@
                   (raise-unexpected-header-value 'content-type (response-content-type response)))
                 (stubs:json-string->scm response-body)))))))))
 
-(define (default-dir)
-  (let ((xdg-data-home
-         (or
-          (getenv "XDG_DATA_HOME")
-          (format #f "~a/.local/share"
-                  (getenv "HOME")))))
-    (format #f "~a/disfluid" xdg-data-home)))
-
-(define*-public (list-profiles #:key (dir default-dir))
-  (when (thunk? dir)
-    (set! dir (dir)))
+(define-public (list-profiles)
   (map (lambda (profile)
          (list
           (string->uri (car profile)) ;; webid
@@ -272,20 +250,17 @@
           (cadddr profile))) ;; key
        (catch #t
          (lambda ()
-           (call-with-input-file (string-append dir "/profiles")
+           (call-with-input-file (string-append (p:data-home) "/profiles")
              read))
          (lambda error
            (format (current-error-port) "Could not read profiles: ~s\n" error)
            '()))))
 
-(define* (add-profile webid issuer refresh-token key
-                      #:key (dir default-dir))
-  (when (thunk? dir)
-    (set! dir (dir)))
-  (let ((other-profiles (list-profiles #:dir dir)))
+(define (add-profile webid issuer refresh-token key)
+  (let ((other-profiles (list-profiles)))
     (stubs:atomically-update-file
-     (string-append dir "/profiles")
-     (string-append dir "/profiles.lock")
+     (string-append (p:data-home) "/profiles")
+     (string-append (p:data-home) "/profiles.lock")
      (lambda (port)
        (write
         (map (lambda (profile)
@@ -304,12 +279,8 @@
                        #:key
                        (client-id #f)
                        (redirect-uri #f)
-                       (dir default-dir)
                        (http-get http-get)
-                       (http-post http-post)
-                       (current-time #f))
-  (when (thunk? dir)
-    (set! dir (dir)))
+                       (http-post http-post))
   (let ((host/webid (get-host/webid)))
     (let ((authorization-uris
            (authorize host/webid
@@ -324,8 +295,7 @@
                    (token host/webid key
                           #:authorization-code authz-code
                           #:http-get http-get
-                          #:http-post http-post
-                          #:current-time current-time)))
+                          #:http-post http-post)))
               (let ((id-token (id-token-decode (assq-ref params 'id_token)
                                                #:http-get http-get))
                     (access-token (assq-ref params 'access_token))
@@ -335,16 +305,13 @@
                   (add-profile (id-token-webid id-token)
                                (id-token-iss id-token)
                                refresh-token
-                               key
-                               #:dir dir))
+                               key))
                 (values (cdr id-token) access-token key)))))))))
 
 (define*-public (login webid issuer refresh-token key
                        #:key
-                       (dir default-dir)
                        (http-get http-get)
-                       (http-post http-post)
-                       (current-time #f))
+                       (http-post http-post))
   (when (string? webid)
     (set! webid (string->uri webid)))
   (when (string? issuer)
@@ -354,8 +321,7 @@
            (token iss-host key
                   #:refresh-token refresh-token
                   #:http-get http-get
-                  #:http-post http-post
-                  #:current-time current-time)))
+                  #:http-post http-post)))
       (let ((id-token (id-token-decode (assq-ref params 'id_token)
                                        #:http-get http-get))
             (access-token (assq-ref params 'access_token))
@@ -366,30 +332,25 @@
           (add-profile (id-token-webid id-token)
                        (id-token-iss id-token)
                        refresh-token
-                       key
-                       #:dir dir))
+                       key))
         (values (cdr id-token) access-token key)))))
 
 (define*-public (refresh id-token
                          key
                          #:key
-                         (dir default-dir)
                          (http-get http-get)
-                         (http-post http-post)
-                         (current-time #f))
-  (when (thunk? dir)
-    (set! dir (dir)))
+                         (http-post http-post))
   (when (id-token-payload? id-token)
     ;; For convenience, we’d like a full ID token to use the ID token
     ;; API.
     (set! id-token (cons `((alg . "HS256")) id-token)))
-  (let ((profiles (list-profiles #:dir dir)))
+  (let ((profiles (list-profiles)))
     (letrec ((find-refresh-token
               (lambda (profiles)
                 (when (null? profiles)
                   (raise-profile-not-found (id-token-webid id-token)
                                            (id-token-iss id-token)
-                                           dir))
+                                           (p:data-home)))
                 (let ((prof (car profiles))
                       (others (cdr profiles)))
                   (let ((webid (car prof))
@@ -403,15 +364,12 @@
              (id-token-iss id-token)
              (find-refresh-token (profiles))
              key
-             #:dir dir
              #:http-get http-get
-             #:http-post http-post
-             #:current-time current-time))))
+             #:http-post http-post))))
 
 (define* (renew-if-expired id-token access-token key
                            date
                            #:key
-                           (dir default-dir)
                            (http-get http-get)
                            (http-post http-post))
   ;; Since we’re not supposed to decode the access token, we’re
@@ -427,25 +385,22 @@
     (set! exp (date->time-utc exp))
     (set! exp (time-second exp))
     (if (>= date exp)
-        (refresh id-token key
-                 #:dir dir
-                 #:http-get http-get
-                 #:http-post http-post
-                 #:current-time date)
+        (parameterize ((p:current-date (lambda () date)))
+          (refresh id-token key
+                   #:http-get http-get
+                   #:http-post http-post))
         (values id-token access-token key))))
 
 (define*-public (make-client id-token access-token key
                              #:key
-                             (dir default-dir)
                              (http-get http-get)
                              (http-post http-post)
-                             (http-request http-request)
-                             (current-time the-current-time))
+                             (http-request http-request))
   ;; HACK: guile does not support other authentication schemes in
   ;; WWW-Authenticate than Basic, so it will crash when a response
   ;; containing that header will be issued.
   (declare-header! "WWW-Authenticate" string->symbol symbol? write)
-  (define (handler uri method headers other-args current-time retry?)
+  (define (handler uri method headers other-args retry?)
     (let ((proof (issue-dpop-proof
                   key
                   #:alg (case (kty key)
@@ -455,7 +410,6 @@
                            (error "Unknown key type of ~S." key)))
                   #:htm method
                   #:htu uri
-                  #:iat current-time
                   #:access-token access-token)))
       (receive (response response-body)
           (apply http-request uri
@@ -470,7 +424,6 @@
               ;; Maybe the access token has expired?
               (receive (new-id-token new-access-token new-key)
                   (renew-if-expired id-token access-token key server-date
-                                    #:dir dir
                                     #:http-get http-get
                                     #:http-post http-post)
                 (if (equal? access-token new-access-token)
@@ -481,18 +434,11 @@
                       (set! id-token new-id-token)
                       (set! access-token new-access-token)
                       (set! key new-key)
-                      (handler uri method headers other-args current-time #f))))
+                      (handler uri method headers other-args #f))))
               (values response response-body))))))
   (define (parse-args uri method headers other-args-rev rest)
     (if (null? rest)
-        (let ((the-current-time current-time))
-          (when (thunk? the-current-time)
-            (set! the-current-time (the-current-time)))
-          (when (integer? the-current-time)
-            (set! the-current-time (make-time time-utc 0 the-current-time)))
-          (when (time? the-current-time)
-            (set! the-current-time (time-utc->date the-current-time)))
-          (handler uri method headers (reverse other-args-rev) the-current-time #t))
+        (handler uri method headers (reverse other-args-rev) #t)
         (let ((kw (car rest)))
           (case kw
             ((#:method)
@@ -618,5 +564,3 @@
                          (title "Not Found"))
                         (body
                          (p "This page does not exist on the server."))))))))))))))
-
-