Restructure the client API

The client API had several problems:
- using records instead of GOOPS means that we aren’t flexible enough
to introduce accounts protected by a password, for a multi-user
application;
- saving the user database to disk means we can’t have a proper
immutable API;
- it was difficult to predict when the users database would change,
and inform the user interface about this change;
- it had two different ways to negociate an access token, one when we
had a refresh token and one when we did not;
- it was supposed to either use account objects or a subject / issuer
pair, now we only use account objects.

1 files changed, 73 insertions, 102 deletions

diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 461c4a7..d340e41 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -24,8 +24,9 @@
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
-  #:use-module ((webid-oidc client accounts) #:prefix client:)
   #:use-module ((webid-oidc cache) #:prefix cache:)
+  #:use-module ((webid-oidc client accounts) #:prefix account:)
+  #:use-module ((webid-oidc client client) #:prefix client:)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (web request)
@@ -43,31 +44,30 @@
   #:use-module (ice-9 suspendable-ports)
   #:use-module (ice-9 match)
   #:use-module (sxml simple)
-  #:export
+  #:use-module (oop goops)
+  #:re-export
   (
-   <client>
-   make-client
-   client?
-   client-id
-   client-key
-   client-redirect-uri
+   (client:<client> . <client>)
+   (client:client-id . client-id)
+   (client:client-key-pair . client-key-pair)
+   (client:client-redirect-uri . client-redirect-uri)
 
-   initial-login
+   (client:client . client)
+   (account:authorization-process . authorization-process)
+   (account:authorization-state . authorization-state)
+   (account:anonymous-http-request . anonymous-http-request)
+   )
+  #:export
+  (
    request
 
    serve-application
    )
   #:declarative? #t)
 
-;; Better for syntax highlighting
-(define <client:account> client:<account>)
-
-(define-record-type <client>
-  (make-client id key redirect-uri)
-  client?
-  (id client-id)
-  (key client-key)
-  (redirect-uri client-redirect-uri))
+;; For syntax highlighting
+(define <account:account> account:<account>)
+(define <client:client> client:<client>)
 
 (define (setup-headers!)
   ;; HACK: guile does not support other authentication schemes in
@@ -105,7 +105,7 @@
        ((value port)
         (original-writer value port))))))
 
-(define* default-http-get-with-cache
+(define default-http-get-with-cache
   (cache:with-cache))
 
 (define* (default-http-request uri . all-args)
@@ -122,91 +122,62 @@
                         #:key
                         (http-request default-http-request))
   (setup-headers!)
-  (match client
-    (($ <client> client-id client-key redirect-uri)
-     (client:save-account
-      (client:login #f issuer
-                    #:http-request http-request
-                    #:client-id client-id
-                    #:client-key client-key
-                    #:redirect-uri redirect-uri)))))
+  (parameterize ((account:anonymous-http-request default-http-request)
+                 (client:client client))
+    (make <account:account>
+      #:issuer issuer)))
 
-(define* (request client subject issuer
-                  #:key
-                  (http-request default-http-request))
+(define (request account uri . other-args)
   (setup-headers!)
-  (match client
-    (($ <client> client-id client-key redirect-uri)
-     (let ((do-login
-            (let ((my-http-get
-                   (lambda* (uri . args)
-                     (apply http-request uri
-                            #:method 'GET
-                            args)))
-                  (my-http-post
-                   (lambda* (uri . args)
-                     (apply http-request uri
-                            #:method 'POST
-                            args))))
-              (match-lambda*
-                ((subject issuer)
-                 (client:save-account
-                  (client:login subject issuer
-                                #:http-request http-request
-                                #:client-id client-id
-                                #:client-key client-key
-                                #:redirect-uri redirect-uri)))
-                ((($ <client:account> subject issuer _ _ _ _))
-                 (client:save-account
-                  (client:login subject issuer
-                                #:http-request http-request
-                                #:client-id client-id
-                                #:client-key client-key
-                                #:redirect-uri redirect-uri)))))))
-       (let ((current-account (do-login subject issuer)))
-         (define (handle request request-body)
-           (receive (response response-body)
-               (let* ((access-token (client:account-access-token current-account))
-                      (dpop-proof
-                       (issue-dpop-proof
-                        (client:account-keypair current-account)
-                        #:alg (case (kty client-key)
-                                ((EC) 'ES256)
-                                ((RSA) 'RS256))
-                        #:htm (request-method request)
-                        #:htu (request-uri request)
-                        #:access-token access-token)))
-                 (let ((headers
-                        `((dpop . ,dpop-proof)
-                          (authorization . (dpop . ,access-token))
-                          ,@(request-headers request))))
-                   (http-request
-                    (request-uri request)
-                    #:method (request-method request)
-                    #:headers headers)))
-             (if (eqv? (response-code response) 401)
-                 ;; Maybe the accesss token expired
-                 (let ((server-date (time-second (date->time-utc (response-date response))))
-                       (exp (assq-ref (client:account-id-token current-account) 'exp)))
-                   (if (>= server-date exp)
-                       ;; The ID token expired, renew it.
-                       (begin
-                         (set! current-account
-                               (client:save-account
-                                (do-login
-                                 (client:save-account
-                                  (client:invalidate-access-token current-account)))))
-                         ;; Read it that way: invalidate the current
-                         ;; account access token, then save it so that
-                         ;; noone uses the invalid access token, then
-                         ;; try to log in again, and finally save the
-                         ;; new access token.
-                         (handle request request-body))
-                       ;; The ID token has not expired, we don’t care.
-                       (values response response-body)))
-                 ;; OK or other error, we don’t care.
-                 (values response response-body))))
-         handle)))))
+  (unless (account:access-token account)
+    (set! account (account:refresh account)))
+  (define (do-with-headers method headers non-header-args can-fail?)
+    (let* ((access-token (account:access-token account))
+           (dpop-proof
+            (let ((key-pair (account:key-pair account)))
+              (issue-dpop-proof
+               key-pair
+               #:alg (case (kty key-pair)
+                       ((EC) 'ES256)
+                       ((RSA) 'RS256))
+               #:htm method
+               #:htu uri
+               #:access-token access-token))))
+      (let ((all-headers
+             `((dpop . ,dpop-proof)
+               (authorization . (dpop . ,access-token))
+               ,@headers)))
+        (receive (response body)
+            (apply (account:anonymous-http-request) uri
+                   #:headers all-headers
+                   non-header-args)
+          (let ((code (response-code response)))
+            (if (and (eqv? code 401) can-fail?)
+                ;; Code expired
+                (begin
+                  (set! account (account:refresh (account:invalidate-access-token account)))
+                  ;; retry
+                  (do-with-headers method headers non-header-args #f))
+                (values account response body)))))))
+  (let scan-arguments ((args other-args)
+                       (headers #f)
+                       (non-header-args '())
+                       (method #f))
+    (match args
+      (()
+       (cond
+        ((not headers)
+         (scan-arguments args '() non-header-args method))
+        ((not method)
+         (scan-arguments args headers non-header-args 'GET))
+        (else
+         (do-with-headers method headers (reverse non-header-args) #t))))
+      ((#:method new-method args ...)
+       (scan-arguments args headers non-header-args (or method new-method)))
+      ((#:headers (new-headers ...) args ...)
+       (scan-arguments args (or headers new-headers) non-header-args method))
+      ((kw value args ...)
+       (scan-arguments args headers `(,value ,kw ,@non-header-args) method)))))
 
 (define* (serve-application id redirect-uri
                             #:key