Make a better client API

8 files changed, 821 insertions, 619 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 4db767f..57c3930 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -89,3 +89,4 @@ webidoidcgo_DATA += \
 EXTRA_DIST += %reldir%/ChangeLog
 
 include %reldir%/server/Makefile.am
+include %reldir%/client/Makefile.am
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 67928db..4fdb824 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -24,6 +24,7 @@
   #: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 (web uri)
   #:use-module (web client)
   #:use-module (web request)
@@ -32,434 +33,154 @@
   #:use-module (web http)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 i18n)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 suspendable-ports)
-  #:use-module (sxml simple))
+  #:use-module (ice-9 match)
+  #:use-module (sxml simple)
+  #:export
+  (
+   <client>
+   make-client
+   client?
+   client-id
+   client-key
+   client-redirect-uri
 
-(define*-public (authorize host-or-webid
-                           #:key
-                           (client-id #f)
-                           (redirect-uri #f)
-                           (state #f)
-                           (http-get http-get))
-  (define cannot-be-webid #f)
-  (define candidate-errors '())
-  ;; host-or-webid can be: the host (as a string), an URI (as a string
-  ;; or an URI). 3 differents things.
-  (when (string? host-or-webid)
-    ;; If it’s a string, it can be either a host name or a URI.
-    (set! host-or-webid
-          (catch #t
-            (lambda ()
-              (let ((urified (string->uri host-or-webid)))
-                (if urified
-                    urified
-                    (error "It’s not a string representing an URI."))))
-            (lambda error
-              (build-uri 'https #:host host-or-webid)))))
-  ;; client-id and redirect-uri are required, state must be a string.
-  (when (string? client-id)
-    (set! client-id (string->uri client-id)))
-  (when (string? redirect-uri)
-    (set! redirect-uri (string->uri redirect-uri)))
-  (let ((host-candidates
-         (with-exception-handler
-             (lambda (why-not-webid)
-               ;; try as an identity provider
-               (set! cannot-be-webid why-not-webid)
-               (build-uri 'https
-                          #:userinfo (uri-userinfo host-or-webid)
-                          #:host (uri-host host-or-webid)
-                          #:port (uri-port host-or-webid)))
-           (lambda ()
-             (get-provider-confirmations host-or-webid #:http-get http-get))
-           #:unwind? #t)))
-    (let ((configurations
-           (if cannot-be-webid
-               (with-exception-handler
-                   (lambda (why-not-identity-provider)
-                     (raise-neither-identity-provider-nor-webid
-                      host-or-webid
-                      why-not-identity-provider
-                      cannot-be-webid))
-                 (lambda ()
-                   (cons (uri->string host-candidates)
-                         (get-oidc-configuration (uri-host host-candidates)
-                                                 #:userinfo (uri-userinfo host-candidates)
-                                                 #:port (uri-port host-candidates)
-                                                 #:http-get http-get))))
-               (filter
-                (lambda (cfg) cfg)
-                (map
-                 (lambda (host)
-                   (with-exception-handler
-                       (lambda (cause)
-                         (set! candidate-errors (acons host cause candidate-errors))
-                         #f)
-                     (lambda ()
-                       (cons (uri->string host)
-                             (get-oidc-configuration (uri-host host)
-                                                     #:userinfo (uri-userinfo host)
-                                                     #:port (uri-port host)
-                                                     #:http-get http-get)))
-                     #:unwind? #t))
-                 host-candidates)))))
-      (let ((authorization-endpoints
-             (if cannot-be-webid
-                 (with-exception-handler
-                     (lambda (why-not-identity-provider)
-                       (raise-neither-identity-provider-nor-webid
-                        host-or-webid
-                        why-not-identity-provider
-                        cannot-be-webid))
-                   (lambda ()
-                     (let ((host (car configurations))
-                           (cfg (cdr configurations)))
-                       (cons host (oidc-configuration-authorization-endpoint cfg)))))
-                 (map
-                  (lambda (host/cfg)
-                    (let ((host (car host/cfg))
-                          (cfg (cdr host/cfg)))
-                      (with-exception-handler
-                          (lambda (cause)
-                            (set! candidate-errors (acons (string->uri host) cause
-                                                          candidate-errors)))
-                        (lambda ()
-                          (cons host
-                                (oidc-configuration-authorization-endpoint cfg)))
-                        #:unwind? #t)))
-                  configurations))))
-        (if cannot-be-webid
-            (let ((host (car authorization-endpoints))
-                  (authz (cdr authorization-endpoints)))
-              (list
-               (cons
-                host
-                (build-uri (uri-scheme authz)
-                           #:userinfo (uri-userinfo authz)
-                           #:host (uri-host authz)
-                           #:port (uri-port authz)
-                           #:path (uri-path authz)
-                           #:query (format #f "client_id=~a&redirect_uri=~a~a"
-                                           (uri-encode (uri->string client-id))
-                                           (uri-encode (uri->string redirect-uri))
-                                           (if state
-                                               (format #f "&state=~a"
-                                                       (uri-encode state))
-                                               ""))))))
-            (let ((final-candidates
-                   (map
-                    (lambda (host/authorization-endpoint)
-                      (let ((host (car host/authorization-endpoint))
-                            (authorization-endpoint (cdr host/authorization-endpoint)))
-                        (cons
-                         host
-                         (build-uri (uri-scheme authorization-endpoint)
-                                    #:userinfo (uri-userinfo authorization-endpoint)
-                                    #:host (uri-host authorization-endpoint)
-                                    #:port (uri-port authorization-endpoint)
-                                    #:path (uri-path authorization-endpoint)
-                                    #:query (format #f "client_id=~a&redirect_uri=~a~a"
-                                                    (uri-encode (uri->string client-id))
-                                                    (uri-encode (uri->string redirect-uri))
-                                                    (if state
-                                                        (format #f "&state=~a"
-                                                                (uri-encode state))
-                                                        ""))))))
-                    authorization-endpoints)))
-              (when (null? final-candidates)
-                (raise-no-provider-candidates host-or-webid candidate-errors))
-              final-candidates))))))
-
-(define*-public (token host client-key
-                       #:key
-                       (authorization-code #f)
-                       (refresh-token #f)
-                       (http-get http-get)
-                       (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)))
-  (let ((token-endpoint
-         (oidc-configuration-token-endpoint
-          (get-oidc-configuration host #:http-get http-get)))
-        (grant-type
-         (if authorization-code
-             "authorization_code"
-             "refresh_token")))
-    (let ((dpop-proof
-           (issue-dpop-proof
-            client-key
-            #:alg (case (kty client-key)
-                    ((EC) 'ES256)
-                    ((RSA) 'RS256)
-                    (else
-                     (error "Unknown key type of ~S." client-key)))
-            #:htm 'POST
-            #:htu token-endpoint)))
-      (receive (response response-body)
-          (http-post token-endpoint
-                     #:body
-                     (string-join
-                      (map
-                       (lambda (arg)
-                         (string-append (uri-encode (car arg))
-                                        "="
-                                        (uri-encode (cdr arg))))
-                       `(("grant_type" . ,grant-type)
-                         ,@(if authorization-code
-                               `(("code" . ,authorization-code))
-                               '())
-                         ,@(if refresh-token
-                               `(("refresh_token" . ,refresh-token))
-                               '())))
-                      "&")
-                     #:headers
-                     `((content-type application/x-www-form-urlencoded)
-                       (dpop . ,dpop-proof)))
-        (with-exception-handler
-            (lambda (error)
-              (raise-token-request-failed error))
-          (lambda ()
-            (when (bytevector? response-body)
-              (set! response-body (utf8->string response-body)))
-            (with-exception-handler
-                (lambda (error)
-                  (raise-unexpected-response response error))
-              (lambda ()
-                (unless (eqv? (response-code response) 200)
-                  (raise-request-failed-unexpectedly
-                   (response-code response)
-                   (response-reason-phrase response)))
-                (unless (and (response-content-type response)
-                             (eq? (car (response-content-type response 'application/json))))
-                  (raise-unexpected-header-value 'content-type (response-content-type response)))
-                (stubs:json-string->scm response-body)))))))))
-
-(define-public (list-profiles)
-  (map (lambda (profile)
-         (list
-          (string->uri (car profile)) ;; webid
-          (string->uri (cadr profile)) ;; issuer
-          (caddr profile) ;; refresh token
-          (cadddr profile))) ;; key
-       (catch #t
-         (lambda ()
-           (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)
-  (let ((other-profiles (list-profiles)))
-    (stubs:atomically-update-file
-     (string-append (p:data-home) "/profiles")
-     (string-append (p:data-home) "/profiles.lock")
-     (lambda (port)
-       (write
-        (map (lambda (profile)
-               (list
-                (uri->string (car profile)) ;; webid
-                (uri->string (cadr profile)) ;; issuer
-                (caddr profile) ;; refresh token
-                key)) ;; key
-             (cons `(,webid
-                     ,issuer
-                     ,refresh-token)
-                   other-profiles))
-        port)))))
-
-(define*-public (setup get-host/webid choose-provider browse-authorization-uri
-                       #:key
-                       (client-id #f)
-                       (redirect-uri #f)
-                       (http-get http-get)
-                       (http-post http-post))
-  (let ((host/webid (get-host/webid)))
-    (let ((authorization-uris
-           (authorize host/webid
-                      #:client-id client-id
-                      #:redirect-uri redirect-uri
-                      #:http-get http-get))
-          (key (generate-key #:n-size 2048)))
-      (let ((provider (choose-provider (map car authorization-uris))))
-        (let ((authz-uri (assq-ref authorization-uris provider)))
-          (let ((authz-code (browse-authorization-uri authz-uri)))
-            (let ((params
-                   (token host/webid key
-                          #:authorization-code authz-code
-                          #:http-get http-get
-                          #: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))
-                    (refresh-token (assq-ref params 'refresh_token)))
-                (when refresh-token
-                  ;; Save it to disk
-                  (add-profile (id-token-webid id-token)
-                               (id-token-iss id-token)
-                               refresh-token
-                               key))
-                (values (cdr id-token) access-token key)))))))))
-
-(define*-public (login webid issuer refresh-token key
-                       #:key
-                       (http-get http-get)
-                       (http-post http-post))
-  (when (string? webid)
-    (set! webid (string->uri webid)))
-  (when (string? issuer)
-    (set! issuer (string->uri issuer)))
-  (let ((iss-host (uri-host issuer)))
-    (let ((params
-           (token iss-host key
-                  #:refresh-token refresh-token
-                  #:http-get http-get
-                  #: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))
-            (new-refresh-token (assq-ref params 'refresh-token)))
-        (when (and new-refresh-token
-                   (not (equal? refresh-token new-refresh-token)))
-          ;; The refresh token has been updated
-          (add-profile (id-token-webid id-token)
-                       (id-token-iss id-token)
-                       refresh-token
-                       key))
-        (values (cdr id-token) access-token key)))))
+   request
 
-(define*-public (refresh id-token
-                         key
-                         #:key
-                         (http-get http-get)
-                         (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)))
-    (letrec ((find-refresh-token
-              (lambda (profiles)
-                (when (null? profiles)
-                  (raise-profile-not-found (id-token-webid id-token)
-                                           (id-token-iss id-token)
-                                           (p:data-home)))
-                (let ((prof (car profiles))
-                      (others (cdr profiles)))
-                  (let ((webid (car prof))
-                        (issuer (cadr prof))
-                        (refresh (caddr prof)))
-                    (if (and (equal? webid (id-token-webid id-token))
-                             (equal? issuer (id-token-iss id-token)))
-                        refresh
-                        (find-refresh-token others)))))))
-      (login (id-token-webid id-token)
-             (id-token-iss id-token)
-             (find-refresh-token (profiles))
-             key
-             #:http-get http-get
-             #:http-post http-post))))
+   serve-application
+   )
+  #:declarative? #t)
 
-(define* (renew-if-expired id-token access-token key
-                           date
-                           #:key
-                           (http-get http-get)
-                           (http-post http-post))
-  ;; Since we’re not supposed to decode the access token, we’re
-  ;; judging from the ID token to know if it has expired.
-  (when (date? date)
-    (set! date (date->time-utc date)))
-  (when (time? date)
-    (set! date (time-second date)))
-  (when (id-token-payload? id-token)
-    ;; See the refresh function
-    (set! id-token (cons `((alg . "HS256")) id-token)))
-  (let ((exp (id-token-exp id-token)))
-    (set! exp (date->time-utc exp))
-    (set! exp (time-second exp))
-    (if (>= date exp)
-        (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-record-type <client>
+  (make-client id key redirect-uri)
+  client?
+  (id client-id)
+  (key client-key)
+  (redirect-uri client-redirect-uri))
 
-(define*-public (make-client id-token access-token key
-                             #:key
-                             (http-get http-get)
-                             (http-post http-post)
-                             (http-request http-request))
+;; subject is optional, if you don’t know who the user is.
+(define* (request client subject issuer
+                  #:key
+                  (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 retry?)
-    (let ((proof (issue-dpop-proof
-                  key
-                  #:alg (case (kty key)
-                          ((EC) 'ES256)
-                          ((RSA) 'RS256)
-                          (else
-                           (error "Unknown key type of ~S." key)))
-                  #:htm method
-                  #:htu uri
-                  #:access-token access-token)))
-      (receive (response response-body)
-          (apply http-request uri
-                 #:method method
-                 #:headers (append `((dpop . ,proof)
-                                     (Authorization . ,(string-append "DPoP " access-token)))
-                                   headers)
-                 other-args)
-        (let ((server-date (response-date response))
-              (code (response-code response)))
-          (if (and retry? (eqv? code 401))
-              ;; 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
-                                    #:http-get http-get
-                                    #:http-post http-post)
-                (if (equal? access-token new-access-token)
-                    ;; No, it’s just that way.
-                    (values response response-body)
-                    ;; Ah, we have a new access token
-                    (begin
-                      (set! id-token new-id-token)
-                      (set! access-token new-access-token)
-                      (set! key new-key)
-                      (handler uri method headers other-args #f))))
-              (values response response-body))))))
-  (define (parse-args uri method headers other-args-rev rest)
-    (if (null? rest)
-        (handler uri method headers (reverse other-args-rev) #t)
-        (let ((kw (car rest)))
-          (case kw
-            ((#:method)
-             (if (null? (cdr rest))
-                 (parse-args uri method headers (cons kw other-args-rev) '())
-                 (parse-args uri (cadr rest) headers other-args-rev (cddr rest))))
-            ((#:headers)
-             (if (null? (cdr rest))
-                 (parse-args uri method headers (cons kw other-args-rev) '())
-                 (parse-args uri method (append headers (cadr rest)) other-args-rev (cddr rest))))
-            (else
-             (parse-args uri method headers (cons kw other-args-rev) '()))))))
-  (define (parse-http-request-args uri args)
-    (parse-args uri 'GET '() '() args))
-  (lambda (uri . args)
-    (parse-http-request-args uri args)))
+  (declare-header!
+   "WWW-Authenticate"
+   (cute parse-header 'pragma <>)
+   (lambda (value)
+     (and (list? value)
+          (let check-value ((schemes value))
+            (match schemes
+              (() #t)
+              (((hd . args) tl ...)
+               (and (symbol? hd)
+                    (let check-args ((args args))
+                      (match args
+                        (() #t)
+                        (((key . value) tl ...)
+                         (and (symbol? key)
+                              (string? value)
+                              (check-args tl)))))
+                    (check-value tl)))))))
+   (cute write-header 'pragma <> <>))
+  ;; The same applies for the authorization header.
+  (let ((original-parser (header-parser 'authorization))
+        (original-writer (header-writer 'authorization)))
+    (declare-header!
+     "Authorization"
+     original-parser
+     (lambda (value) #t)
+     (match-lambda*
+       ((('dpop . dpop) port)
+        (format port "DPoP ~a" dpop))
+       ((value port)
+        (original-writer value port)))))
+  (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-get my-http-get
+                                #:http-post my-http-post
+                                #:client-id client-id
+                                #:client-key client-key
+                                #:redirect-uri redirect-uri)))
+                (($ <account> subject issuer _ _ _ _)
+                 (client:save-account
+                  (client:login subject issuer
+                                #:http-get my-http-get
+                                #:http-post my-http-post
+                                #: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)))))
 
-(define*-public (serve-application id redirect-uri
-                                   #:key
-                                   (client-name "Example application")
-                                   (client-uri "https://webid-oidc-demo.planete-kraus.eu"))
+(define* (serve-application id redirect-uri
+                            #:key
+                            (client-name "Example application")
+                            (client-uri "https://webid-oidc-demo.planete-kraus.eu"))
   (when (string? id)
     (set! id (string->uri id)))
   (when (string? redirect-uri)
diff --git a/src/scm/webid-oidc/client/Makefile.am b/src/scm/webid-oidc/client/Makefile.am
new file mode 100644
index 0000000..ccb7e35
--- /dev/null
+++ b/src/scm/webid-oidc/client/Makefile.am
@@ -0,0 +1,21 @@
+# disfluid, implementation of the Solid specification
+# Copyright (C) 2021  Vivien Kraus
+
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU Affero General Public License as
+# published by the Free Software Foundation, either version 3 of the
+# License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU Affero General Public License for more details.
+
+# You should have received a copy of the GNU Affero General Public License
+# along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+dist_clientwebidoidcmod_DATA += \
+  %reldir%/accounts.scm
+
+clientwebidoidcgo_DATA += \
+  %reldir%/accounts.go
diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm
new file mode 100644
index 0000000..98fef85
--- /dev/null
+++ b/src/scm/webid-oidc/client/accounts.scm
@@ -0,0 +1,534 @@
+(define-module (webid-oidc client accounts)
+  #:use-module (sxml simple)
+  #:use-module (sxml match)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 i18n)
+  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-19)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module ((webid-oidc oidc-id-token) #:prefix id:)
+  #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:)
+  #:use-module ((webid-oidc jwk) #:prefix jwk:)
+  #:use-module ((webid-oidc dpop-proof) #:prefix dpop:)
+  #:use-module (web uri)
+  #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:export
+  (
+   <account>
+   make-account
+   account?
+   account-subject
+   account-issuer
+   account-id-token
+   account-access-token
+   account-refresh-token
+   account-keypair
+
+   authorization-process
+
+   &authorization-code-required
+   make-authorization-code-required
+   authorization-code-required?
+   authorization-code-required-uri
+
+   &refresh-token-expired
+   make-refresh-token-expired
+   refresh-token-expired?
+
+   &token-request-failed
+   make-token-request-failed
+   token-request-failed?
+   token-request-response
+   token-request-response-body
+
+   read-accounts
+   save-account
+   delete-account
+   invalidate-access-token
+   invalidate-refresh-token
+   login
+   )
+  #:declarative? #t)
+
+(define (G_ text)
+  (let ((out (gettext text)))
+    (if (string=? out text)
+        ;; No translation, disambiguate
+        (car (reverse (string-split text #\|)))
+        out)))
+
+;; This exception is continuable! Continue with the authorization
+;; code.
+(define-exception-type
+  &authorization-code-required
+  &external-error
+  make-authorization-code-required
+  authorization-code-required?
+  (uri authorization-code-required-uri))
+
+(define-exception-type
+  &token-request-failed
+  &external-error
+  make-token-request-failed
+  token-request-failed?
+  (response token-request-response)
+  (response-body token-request-response-body))
+
+(define authorization-process
+  (make-parameter
+   (lambda* (uri #:key issuer)
+     (raise-exception
+      (make-exception
+       (make-authorization-code-required uri)
+       (make-exception-with-message
+        (G_ (format #f "An authorization code is required to log in with ~s, it can be obtained at ~s."
+                    (uri->string issuer)
+                    (uri->string uri)))))
+      #:continuable? #t))))
+
+(define-record-type <account>
+  (make-account subject issuer id-token access-token refresh-token keypair)
+  account?
+  (subject account-subject)
+  (issuer account-issuer)
+  (id-token account-id-token)
+  (access-token account-access-token)
+  (refresh-token account-refresh-token)
+  (keypair account-keypair))
+
+(define (load-account-arguments subject issuer arguments)
+  (let collect-arguments ((id-token #f)
+                          (access-token #f)
+                          (refresh-token #f)
+                          (keypair #f)
+                          (arguments arguments))
+    (match arguments
+      (()
+       (make-account subject
+                     issuer
+                     id-token
+                     access-token
+                     refresh-token
+                     keypair))
+      ((hd tl ...)
+       (sxml-match
+        hd
+        ((disfluid:id-token (@ (sub ,sub) (aud ,aud) (nonce ,nonce) (iat ,iat) (exp ,exp)))
+         (collect-arguments
+          (id:the-id-token-payload
+           `((webid . ,(uri->string subject))
+             (iss . ,(uri->string issuer))
+             (sub . ,sub)
+             (aud . ,aud)
+             (nonce . ,nonce)
+             (iat . ,(string->number iat))
+             (exp . ,(string->number exp))))
+          access-token
+          refresh-token
+          keypair
+          tl))
+        ((disfluid:access-token (@ (access-token ,access-token)))
+         (collect-arguments
+          id-token
+          access-token
+          refresh-token
+          keypair
+          tl))
+        ((disfluid:refresh-token (@ (refresh-token ,refresh-token)))
+         (collect-arguments
+          id-token
+          access-token
+          refresh-token
+          keypair
+          tl))
+        ((disfluid:rsa-keypair (@ (n ,n) (e (,e "AQAB"))
+                                  (d ,d) (p ,p) (q ,q) (dp ,dp) (dq ,dq) (qi ,qi)))
+         (collect-arguments
+          id-token
+          access-token
+          refresh-token
+          `(,@(jwk:make-rsa-public-key n e)
+            ,@(jwk:make-rsa-private-key d p q dp dq qi))
+          tl))
+        ((disfluid:ec-keypair (@ (crv ,crv) (x ,x) (y ,y) (d ,d)))
+         (collect-arguments
+          id-token
+          access-token
+          refresh-token
+          `(,@(jwk:make-ec-point crv x y)
+            ,@(jwk:make-ec-scalar crv d)))))))))
+
+(define (read-accounts)
+  (let generate-list
+      ((content
+        (catch #t
+          (lambda ()
+            (call-with-input-file (string-append (p:data-home) "/profiles.xml")
+              (lambda (port)
+                (xml->sxml port
+                           #:namespaces '((disfluid . "https://disfluid.planete-kraus.eu/client-account/v1"))
+                           #:trim-whitespace? #t))))
+          (lambda error
+            '(*TOP*
+              (disfluid:accounts)))))
+       (parsed-accounts '()))
+    (sxml-match
+     content
+     ((*TOP*
+       (disfluid:accounts))
+      (reverse parsed-accounts))
+     ((*TOP*
+       (disfluid:accounts
+        (disfluid:account
+         (@ (subject ,subject)
+            (issuer ,issuer))
+         ,arguments ...)
+        ,other-accounts ...))
+      (let ((account (load-account-arguments
+                      (string->uri subject)
+                      (string->uri issuer) arguments)))
+        (generate-list
+         `(*TOP* (disfluid:accounts ,@other-accounts))
+         `(,account ,@parsed-accounts))))
+     ((*TOP*
+       (disfluid:accounts
+        (disfluid:account
+         ;; the subject is not set yet
+         (@ (issuer ,issuer))
+         ,arguments ...)
+        ,other-accounts ...))
+      (let ((account (load-account-arguments
+                      #f (string->uri issuer) arguments)))
+        (generate-list
+         `(*TOP* (disfluid:accounts ,@other-accounts))
+         `(,account ,@parsed-accounts))))
+     ((*TOP*
+       (disfluid:accounts
+        ,whatever
+        ,other-accounts ...))
+      (generate-list `(*TOP* (disfluid:accounts ,@other-accounts)) parsed-accounts))
+     ((*TOP*
+       ,whatever)
+      (generate-list `(*TOP* (disfluid:accounts)) parsed-accounts)))))
+
+(define (update-accounts transformer)
+  (stubs:atomically-update-file
+   (string-append (p:data-home) "/profiles.xml")
+   (string-append (p:data-home) "/profiles.xml.lock")
+   (lambda (port)
+     (let ((old-accounts (read-accounts)))
+       (let ((new-accounts (transformer old-accounts)))
+         (chmod port #o600)
+         (sxml->xml
+          `(*TOP*
+            (accounts
+             (@ (xmlns "https://disfluid.planete-kraus.eu/client-account/v1"))
+             ,@(map (match-lambda
+                      (($ <account> subject issuer id-token access-token refresh-token keypair)
+                       (when (string? subject)
+                         (set! subject (string->uri subject)))
+                       (when (string? issuer)
+                         (set! issuer (string->uri issuer)))
+                       `(account
+                         (@ ,@(if subject
+                                  `((subject ,(uri->string subject)))
+                                  '())
+                            (issuer ,(uri->string issuer)))
+                         ,@(if id-token
+                               `((id-token (@ (sub ,(id:id-token-sub id-token))
+                                              (aud ,(uri->string (id:id-token-aud id-token)))
+                                              (nonce ,(id:id-token-nonce id-token))
+                                              (iat
+                                               ,(number->string
+                                                 (time-second
+                                                  (date->time-utc
+                                                   (id:id-token-iat id-token)))))
+                                              (exp
+                                               ,(number->string
+                                                 (time-second
+                                                  (date->time-utc
+                                                   (id:id-token-exp id-token))))))))
+                               '())
+                         ,@(if access-token
+                               `((access-token (@ (access-token ,access-token))))
+                               '())
+                         ,@(if refresh-token
+                               `((refresh-token (@ (refresh-token ,refresh-token))))
+                               '())
+                         ,@(if keypair
+                               (case (jwk:kty keypair)
+                                 ((RSA)
+                                  `((rsa-keypair (@ (n ,(assq-ref keypair 'n))
+                                                    (e ,(assq-ref keypair 'e))
+                                                    (d ,(assq-ref keypair 'd))
+                                                    (p ,(assq-ref keypair 'p))
+                                                    (q ,(assq-ref keypair 'q))
+                                                    (dp ,(assq-ref keypair 'dp))
+                                                    (dq ,(assq-ref keypair 'dq))
+                                                    (qi ,(assq-ref keypair 'qi))))))
+                                 ((EC)
+                                  `((ec-keypair (@ (crv ,(symbol->string (assq-ref keypair 'crv)))
+                                                   (x ,(assq-ref keypair 'x))
+                                                   (y ,(assq-ref keypair 'y))
+                                                   (d ,(assq-ref keypair 'd)))))))))))
+                    new-accounts)))
+          port))))))
+
+(define (filter-out account old-accounts)
+  (match account
+    (($ <account> subject issuer _ _ _ _)
+     (filter
+      (match-lambda
+        (($ <account> other-subject other-issuer _ _ _ _)
+         ;; Keep it only if this is not the same user
+         (or (not (equal? other-subject subject))
+             (not (equal? other-issuer issuer)))))
+      old-accounts))))
+
+(define (save-account account)
+  (update-accounts
+   (lambda (old-accounts)
+     `(,account
+       ,@(filter-out account old-accounts))))
+  account)
+
+(define (delete-account account)
+  (update-accounts
+   (lambda (old-accounts)
+     (filter-out account old-accounts))))
+
+(define invalidate-access-token
+  (match-lambda
+    (($ <account> subject issuer _ _ refresh-token keypair)
+     (make-account subject issuer #f #f refresh-token keypair))))
+
+(define invalidate-refresh-token
+  (match-lambda
+    (($ <account> subject issuer id-token access-token _ keypair)
+     (make-account subject issuer id-token access-token #f keypair))))
+
+;; subject is optional. If the user is unknown, ask for an issuer and
+;; pass #f as subject.
+(define* (login subject issuer
+                #:key
+                (http-get http-get)
+                (http-post http-post)
+                (state #f)
+                client-id
+                client-key
+                redirect-uri)
+  (let ((all-accounts (if subject
+                          ;; we’re expected to know the subject
+                          (read-accounts)
+                          ;; we’re not expected to know the subject
+                          ;; anyway.
+                          '())))
+    (let find-access-token ((accounts (read-accounts))
+                            (available-refresh-token #f))
+      (match accounts
+        (() ;; No access token available (or no ID token, or no key):
+         ;; requires authorization.
+         (receive (authorization-endpoint token-endpoint)
+             (let ((configuration
+                    (cfg:get-oidc-configuration
+                     (uri-host issuer)
+                     #:userinfo (uri-userinfo issuer)
+                     #:port (uri-port issuer)
+                     #:http-get http-get)))
+               (values 
+                (cfg:oidc-configuration-authorization-endpoint configuration)
+                (cfg:oidc-configuration-token-endpoint configuration)))
+           (let ((grant-type
+                  (if available-refresh-token
+                      "refresh_token"
+                      "authorization_code"))
+                 (grant
+                  (or available-refresh-token
+                      ;; Negociate an authorization code
+                      (let ((authorization-uri
+                             (build-uri
+                              (uri-scheme authorization-endpoint)
+                              #:userinfo (uri-userinfo authorization-endpoint)
+                              #:host (uri-host authorization-endpoint)
+                              #:port (uri-port authorization-endpoint)
+                              #:path (uri-path authorization-endpoint)
+                              #:query
+                              (string-join
+                               (map (match-lambda
+                                      ((key . value)
+                                       (string-join `(,(symbol->string key)
+                                                      ,(uri-encode value))
+                                                    "=")))
+                                    `((client_id . ,(uri->string client-id))
+                                      (redirect_uri . ,(uri->string redirect-uri))
+                                      ,@(if state
+                                            `((state . ,state))
+                                            '())))
+                               "&"))))
+                        ((authorization-process) authorization-uri #:issuer issuer))))
+                 (dpop-proof
+                  (dpop:issue-dpop-proof
+                   client-key
+                   #:alg (case (jwk:kty client-key)
+                           ((EC) 'ES256)
+                           ((RSA) 'RS256))
+                   #:htm 'POST
+                   #:htu token-endpoint)))
+             ;; Post the token request with the correct grant:
+             (receive (response response-body)
+                 (http-post token-endpoint
+                            #:body
+                            (string-join
+                             (map
+                              (match-lambda
+                                ((key . value)
+                                 (string-append (uri-encode key)
+                                                "="
+                                                (uri-encode value))))
+                              `(("grant_type" . ,grant-type)
+                                (,(if available-refresh-token
+                                      "refresh_token"
+                                      "code") . ,grant)))
+                             "&")
+                            #:headers
+                            `((content-type application/x-www-form-urlencoded)
+                              (dpop . ,dpop-proof)))
+               ;; Check that the token endpoint responded correctly.
+               (when (eqv? (response-code response) 403)
+                 (when subject
+                   (save-account
+                    (invalidate-refresh-token
+                     (make-account subject issuer #f #f #f #f))))
+                 (raise-exception
+                  (make-refresh-token-expired)
+                  (make-exception-with-message
+                   (G_ (format #f "The refresh token has expired.")))))
+               (unless (eqv? (response-code response) 200)
+                 (raise-exception
+                  (make-exception
+                   (make-token-request-failed response response-body)
+                   (make-exception-with-message
+                    (G_ (format #f "The token request failed with code ~s (~s).")
+                        (response-code response)
+                        (response-reason-phrase response))))))
+               (unless (response-content-type response)
+                 (raise-exception
+                  (make-exception
+                   (make-token-request-failed response response-body)
+                   (make-exception-with-message
+                    (G_ (format #f "The token response did not set the content type."))))))
+               (with-exception-handler
+                   (lambda (encoding-error)
+                     (raise-exception
+                      (make-exception
+                       (make-token-request-failed response response-body)
+                       (make-exception-with-message
+                        (G_ (format #f "The token endpoint did not respond in UTF-8.")))
+                       encoding-error)))
+                 (lambda ()
+                   (when (bytevector? response-body)
+                     (set! response-body (utf8->string response-body)))))
+               (unless (eq? (car (response-content-type response))
+                            'application/json)
+                 (raise-exception
+                  (make-exception
+                   (make-token-request-failed response response-body)
+                   (make-exception-with-message
+                    (G_ (format #f "The token response has content-type ~s, not application/json.")
+                        (response-content-type response))))))
+               (let ((data
+                      (with-exception-handler
+                          (lambda (json-error)
+                            (raise-exception
+                             (make-exception
+                              (make-token-request-failed response response-body)
+                              (make-exception-with-message
+                               (G_ (format #f "The token response is not valid JSON.")))
+                              json-error)))
+                        (lambda ()
+                          (stubs:json-string->scm response-body)))))
+                 (let ((id-token (assq-ref data 'id_token))
+                       (access-token (assq-ref data 'access_token))
+                       (refresh-token (assq-ref data 'refresh_token)))
+                   (unless id-token
+                     (raise-exception
+                      (make-exception
+                       (make-token-request-failed response response-body)
+                       (make-exception-with-message
+                        (G_ (format #f "The token response did not include an ID token: ~s")
+                            data)))))
+                   (unless access-token
+                     (raise-exception
+                      (make-exception
+                       (make-token-request-failed response response-body)
+                       (make-exception-with-message
+                        (G_ (format #f "The token response did not include an access token: ~s
+")
+                            data)))))
+                   (with-exception-handler
+                       (lambda (decoding-error)
+                         (raise-exception
+                          (make-exception
+                           (make-token-request-failed response response-body)
+                           (make-exception-with-message
+                            (G_ (format #f "The ID token signature is invalid.")))
+                           decoding-error)))
+                     (lambda ()
+                       (match (id:id-token-decode id-token #:http-get http-get)
+                         ((header . payload)
+                          (set! id-token payload)))))
+                   ;; We are not interested in the ID token
+                   ;; signature anymore, because it won’t be
+                   ;; transmitted to other parties and we know that
+                   ;; it is valid.
+                   (when (and subject
+                              (not (equal? subject (id:id-token-webid id-token))))
+                     (raise-exception
+                      (make-exception
+                       (make-token-request-failed response response-body)
+                       (make-exception-with-message
+                        (G_ (format #f "The ID token delivered by the identity provider for ~s has ~s as webid.")
+                            (uri->string subject)
+                            (id:id-token-webid id-token))))))
+                   (when (not (equal? issuer (id:id-token-iss id-token)))
+                     (raise-exception
+                      (make-exception
+                       (make-token-request-failed response response-body)
+                       (make-exception-with-message
+                        (G_ (format #f "The ID token delivered by the identity provider ~s is for issuer ~s.")
+                            (uri->string issuer)
+                            (id:id-token-iss id-token))))))
+                   (make-account
+                    (id:id-token-webid id-token)
+                    issuer
+                    id-token
+                    access-token
+                    refresh-token
+                    client-key)))))))
+        ;; There is an account with an access token that was still
+        ;; valid last time we used it.
+        ((($ <account> hd-subject hd-issuer hd-id-token hd-access-token hd-refresh-token hd-keypair) tl ...)
+         (cond
+          ((and (equal? hd-subject subject)
+                (equal? hd-issuer issuer)
+                hd-id-token
+                hd-access-token
+                hd-keypair)
+           ;; We can use it as is.
+           (make-account hd-subject hd-issuer
+                         hd-id-token hd-access-token hd-refresh-token hd-keypair))
+          ((and (equal? hd-subject subject)
+                (equal? hd-issuer issuer))
+           ;; We know that user, but the access token has been
+           ;; invalidated. If it still has a refresh token, maybe try
+           ;; it.
+           (find-access-token '() hd-refresh-token))
+          (else
+           ;; We can’t even use this refresh token, so we will try
+           ;; with the previous one.
+           (find-access-token tl available-refresh-token))))))))
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index beccc35..1c7d539 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -21,7 +21,8 @@
   #:use-module (ice-9 i18n)
   #:use-module (srfi srfi-19)
   #:use-module (web uri)
-  #:use-module (web response))
+  #:use-module (web response)
+  #:use-module (web client))
 
 (define (G_ text)
   (let ((out (gettext text)))
@@ -883,16 +884,6 @@
    ((record-constructor &neither-identity-provider-nor-webid)
     uri why-not-identity-provider why-not-webid)))
 
-(define-public &token-request-failed
-  (make-exception-type
-   '&token-request-failed
-   &external-error
-   '(cause)))
-
-(define-public (raise-token-request-failed cause)
-  (raise-exception
-   ((record-constructor &token-request-failed) cause)))
-
 (define-public &profile-not-found
   (make-exception-type
    '&profile-not-found
@@ -1420,9 +1411,6 @@
                    (uri->string (get 'uri))
                    (recurse (get 'why-not-identity-provider))
                    (recurse (get 'why-not-webid))))
-          ((&token-request-failed)
-           (format #f (G_ "the token request failed (because ~a)")
-                   (recurse (get 'cause))))
           ((&profile-not-found)
            (format #f (G_ "you don’t have a refresh token for identity ~a certified by ~a in ~s")
                    (uri->string (get 'webid))
@@ -1529,6 +1517,6 @@
           ((&error)
            (format #f (G_ "there is an error")))
           (else
-           (error (format #f (G_ "Unhandled exception type ~a.")
-                          (record-type-name type))))))
+           (format #f (G_ "there is an unknown exception of kind ~s")
+                   (record-type-name type)))))
       (format #f "~a" err)))
diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm
index f0fcdd3..d6ef2a0 100644
--- a/src/scm/webid-oidc/example-app.scm
+++ b/src/scm/webid-oidc/example-app.scm
@@ -15,25 +15,30 @@
 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 (define-module (webid-oidc example-app)
-  #:use-module (webid-oidc client)
+  #:use-module ((webid-oidc client) #:prefix client:)
+  #:use-module ((webid-oidc client accounts) #:prefix client:)
   #:use-module (webid-oidc errors)
   #:use-module ((webid-oidc cache) #:prefix cache:)
   #:use-module (webid-oidc dpop-proof)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
+  #:use-module ((webid-oidc jwk) #:prefix jwk:)
   #:use-module (web uri)
   #:use-module (web client)
+  #:use-module (web request)
   #:use-module (web response)
   #:use-module (web server)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 receive)
   #:use-module (srfi srfi-19)
   #:use-module (ice-9 i18n)
+  #:use-module (srfi srfi-26)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 suspendable-ports)
   #:use-module (ice-9 textual-ports)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
   #:use-module (sxml simple)
   #:use-module (rnrs bytevectors))
 
@@ -44,187 +49,102 @@
         (car (reverse (string-split text #\|)))
         out)))
 
-(define (enumerate-profiles profiles)
-  (define (aux i)
-    (when (< i (vector-length profiles))
-      (let ((prof (vector-ref profiles i)))
-        (format #t (G_ "~a.\t~a, certified by ~a;\n")
-                (+ i 1)
-                (uri->string (car prof))
-                (uri->string (cadr prof))))
-      (aux (+ i 1))))
-  (aux 0))
-
-(define (enumerate-providers providers)
-  (define (aux i)
-    (when (< i (vector-length providers))
-      (let ((prov (vector-ref providers i)))
-        (format #t (G_ "~a – ~a\n")
-                (+ i 1)
-                (prov)))
-      (aux (+ i 1))))
-  (aux 0))
-
-(define (select-choice mini maxi question)
-  (format #t "~a" question)
-  (let* ((line
-          (read-line (current-input-port) 'trim))
-         (number (false-if-exception (string->number line))))
-    (cond
-     ((eof-object? line)
-      (exit 0))
-     ((and (integer? number)
-           (>= number mini)
-           (<= number maxi))
-      number)
-     (else
-      (format #t (G_ "I’m expecting a number between ~a and ~a.\n")
-              mini maxi)
-      (select-choice mini maxi question)))))
-
-(define cache-http-get (cache:with-cache))
-
-(define (inner-main-loop http-request)
-  (format #t (G_ "Please enter an URI to GET: "))
-  (let ((line (read-line (current-input-port) 'trim)))
-    (unless (eof-object? line)
-      (let ((uri (string->uri line)))
-        (receive (response response-body)
-            (http-request uri)
-          (let ((write-body
-                 (write-response response (current-output-port))))
-            (when (string? response-body)
-              (set! response-body (string->utf8 response-body)))
-            (when response-body
-              (write-response-body write-body response-body)))))
-      (inner-main-loop http-request))))
-
-(define (main-loop id-token access-token key)
-  (let ((my-http-request
-         (make-client id-token access-token key
-                      #:http-request
-                      (lambda args
-                        (format (current-error-port) (G_ "Sending a request: ~s\n") args)
-                        (apply http-request args)))))
-    (inner-main-loop my-http-request)))
-
-(define-public (inner-main)
-  (setlocale LC_ALL "")
-  (bindtextdomain cfg:package cfg:localedir)
-  (textdomain cfg:package)
-  (let ((version-sym
-         (string->symbol (G_ "command-line|version")))
-        (help-sym
-         (string->symbol (G_ "comand-line|help"))))
-    (let ((options
-           (let ((option-spec
-                  `((,version-sym (single-char #\v) (value #f))
-                    (,help-sym (single-char #\h) (value #f)))))
-             (getopt-long (command-line) option-spec))))
-      (cond
-       ((option-ref options help-sym #f)
-        (format #t (G_ "Usage: ~a [OPTIONS]...
-
-Demonstrate a webid-oidc application.
-
-Options:
-  -h, --~a:
-      display this help message and exit.
-  -v, --~a:
-      display the version information (~a) and exit.
-
-Environment variables:
-
-  LANG: set the locale. Currently ~a.
-
-  XDG_CACHE_HOME: where the seed for the key generator is
-stored. Currently ~a.
-
-  XDG_DATA_HOME: where the login credentials are stored. Currently ~a.
-
-  HOME: to compute a default value for XDG_CACHE_HOME and
-XDG_DATA_HOME, if missing. Currently ~a.
-
-If you find a bug, send a report to ~a.
-")
-                (car (command-line))
-                help-sym version-sym
-                cfg:version
-                (or (getenv "LANG") "")
-                (or (getenv "XDG_CACHE_HOME") "")
-                (or (getenv "XDG_DATA_HOME") "")
-                (or (getenv "HOME") "")
-                cfg:package-bugreport))
-       ((option-ref options version-sym #f)
-        (format #t (G_ "~a version ~a\n")
-                cfg:package cfg:version))
-       (else
-        (let ((profiles (list->vector (list-profiles))))
-          (format #t (G_ "First, let’s log in. Here are your options:\n"))
-          (enumerate-profiles profiles)
-          (format #t (G_ "0.\tLog in with a different identity.\n"))
-          (let ((i-profile
-                 (select-choice
-                  0
-                  (vector-length profiles)
-                  (G_ "Please indicate your choice number: "))))
-            (receive (id-token access-token key)
-                (if (eqv? i-profile 0)
-                    (setup
-                     (lambda ()
-                       (format #t (G_ "Please enter your webid, or identity server: "))
-                       (read-line (current-input-port) 'trim))
-                     (lambda (providers)
-                       (cond
-                        ((null? providers)
-                         (error "No, this cannot happen."))
-                        ((null? (cdr providers))
-                         (car providers))
-                        (else
-                         (set! providers (list->vector providers))
-                         (format #t (G_ "There are different possible identity providers for your webid:\n"))
-                         (enumerate-providers providers)
-                         (let ((i-provider
-                                (select-choice 1 (- (vector-length providers) 1)
-                                               (G_ "Please indicate your choice number: "))))
-                           (vector-ref providers i-provider)))))
-                     (lambda (uri)
-                       (format #t (G_ "Please visit the following URI with a web browser:\n~a\n")
-                               (uri->string uri))
-                       (format #t (G_ "Please paste your authorization code: "))
-                       (read-line (current-input-port) 'trim))
-                     #:client-id "https://webid-oidc-demo.planete-kraus.eu/example-application#id"
-                     #:redirect-uri "https://webid-oidc-demo.planete-kraus.eu/authorized"
-                     #:http-get cache-http-get)
-                    (let ((profile (vector-ref profiles (- i-profile 1))))
-                      (let ((webid (car profile))
-                            (issuer (cadr profile))
-                            (refresh-token (caddr profile))
-                            (key (cadddr profile)))
-                        (login webid issuer refresh-token key #:http-get cache-http-get))))
-              (format #t (G_ "Log in success. Keep this identity token for yourself:
-
-~a
-
-Now, you can do authenticated request by presenting the following access token:
-
-~a
-
-and signing DPoP proofs with the following key:
-
-~a
+(define (main)
+  (define (do-the-trick subject issuer)
+    (client:request
+     (client:make-client
+      (string->uri
+       "https://webid-oidc-demo.planete-kraus.eu/example-application#id")
+      (jwk:generate-key #:n-size 2048)
+      (string->uri
+       "https://webid-oidc-demo.planete-kraus.eu/authorized"))
+     subject issuer))
+  (let ((accounts (list->vector (client:read-accounts))))
+    (format #t (G_ "Main menu:\n"))
+    (let enumerate-accounts ((i 0))
+      (when (< i (vector-length accounts))
+        (format #t (G_ "~a. Log in with ~a (issued by ~a): ~a
 ")
-                      (stubs:scm->json-string id-token #:pretty #t)
-                      access-token
-                      (stubs:scm->json-string key #:pretty #t))
-              (main-loop id-token access-token key)))))))))
-
-(define-public (main)
-  (with-exception-handler
-      (lambda (error)
-        (format (current-error-port)
-                (G_ "There was an error: ~a\n")
-                (error->str error)))
-    (lambda ()
-      (inner-main))
-    #:unwind? #t))
+                (1+ i)
+                (or (let ((subject (client:account-subject (vector-ref accounts i))))
+                      (and subject (uri->string subject)))
+                    (format #f (G_ "a new user")))
+                (uri->string (client:account-issuer (vector-ref accounts i)))
+                (if (client:account-subject (vector-ref accounts i))
+                    (if (client:account-id-token (vector-ref accounts i))
+                        (format #f (G_ "status|currently logged in"))
+                        (if (client:account-refresh-token (vector-ref accounts i))
+                            (format #f (G_ "status|offline (but accessible)"))
+                            (format #f (G_ "status|offline (inaccessible)"))))
+                    (format #f (G_ "status|not initialized yet"))))
+        (enumerate-accounts (1+ i))))
+    (format #t (G_ "Type a number to log in, prefix it with '-' to delete the account, or type + to create a new account.
+"))
+    (match (read-line (current-input-port) 'trim)
+      ((? string?
+          (= string->number
+             (and (? integer? _)
+                  (? (cute >= <> 1) _)
+                  (? (cute <= <> (vector-length accounts)))
+                  (= (cute - <> 1) choice))))
+       (let ((account (vector-ref accounts choice)))
+         (parameterize
+             ((client:authorization-process
+               ;; There’s a problem with guile continuable
+               ;; exceptions: we can’t handle errors in a handler for
+               ;; continuable exceptions. Until this is clarified, we
+               ;; avoid continuable exceptions.
+               (lambda* (uri #:key issuer)
+                 (format (current-error-port) (G_ "Please visit: ~a\n") (uri->string uri))
+                 (format (current-error-port) (G_ "Then, paste the authorization code you get:\n"))
+                 (read-line (current-input-port) 'trim))))
+           (with-exception-handler
+               (lambda (error)
+                 (cond
+                  ((client:token-request-failed? error)
+                   (format (current-error-port) (G_ "I could not negociate an access token.  ~a")
+                           (exception-message error))
+                   (main))
+                  ((client:refresh-token-expired? error)
+                   (format (current-error-port) (G_ "The refresh token has expired, it is not possible to use that account offline.\n"))
+                   (main))
+                  (else
+                   (raise-exception error))))
+             (lambda ()
+               (format #t (G_ "Please enter an URI to GET:\n"))
+               (let ((uri (string->uri (read-line (current-input-port) 'trim)))
+                     (handler (do-the-trick (client:account-subject account)
+                                            (client:account-issuer account))))
+                 (receive (response response-body)
+                     (handler (build-request uri) "")
+                   (let ((ad-hoc-port (write-response response (current-output-port))))
+                     (unless (response-must-not-include-body? response)
+                       (when (string? response-body)
+                         (set! response-body (string->utf8 response-body)))
+                       (write-response-body ad-hoc-port response-body)))))
+               (format #t "\n")
+               (main))))))
+      ((? string?
+          (= string->number
+             (and (? integer? _)
+                  (= (cute - <>)
+                     (and (? (cute >= <> 1) _)
+                          (? (cute <= <> (vector-length accounts)) _)
+                          (= (cute - <> 1) choice))))))
+       ;; Delete
+       (client:delete-account (vector-ref accounts choice))
+       (main))
+      ("+"
+       ;; Create an account
+       (format #t (G_ "Please type your identity provider:\n"))
+       (let ((issuer (read-line (current-input-port) 'trim)))
+         (when (and (string? issuer) (string->uri issuer))
+           (client:save-account
+            (client:make-account #f (string->uri issuer) #f #f #f #f))))
+       (main))
+      ((? eof-object? _)
+       (exit 0))
+      (else
+       (main)))))
+
+(main)
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index 14d8b81..5ee84db 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluid, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -42,6 +42,7 @@
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 suspendable-ports)
   #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
   #:use-module (sxml simple)
   #:use-module (srfi srfi-19))
 
@@ -87,7 +88,18 @@
                              (error->str error))
                      #f)
                  (lambda ()
-                   (let* ((lit-access-token (symbol->string (cadr authz)))
+                   ;; Sometimes the access is the cadr as a symbol,
+                   ;; sometimes it is the cdr as a string. It depends
+                   ;; whether the response has been written and read,
+                   ;; or preserved as a guile object.
+                   (let* ((lit-access-token
+                           (match authz
+                             ;; That’s when the request is parsed:
+                             (('dpop (? symbol? symbol-value))
+                              (symbol->string symbol-value))
+                             ;; That’s when it’s not:
+                             (('dpop . (? string? string-value))
+                              string-value)))
                           (access-token
                            (access-token-decode lit-access-token
                                                 #:http-get http-get))
diff --git a/src/scm/webid-oidc/testing.scm b/src/scm/webid-oidc/testing.scm
index aec9504..f4de433 100644
--- a/src/scm/webid-oidc/testing.scm
+++ b/src/scm/webid-oidc/testing.scm
@@ -17,7 +17,12 @@
 (define-module (webid-oidc testing)
   #:use-module (webid-oidc stubs)
   #:use-module (webid-oidc errors)
-  #:use-module (webid-oidc parameters))
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 optargs)
+  #:use-module (webid-oidc parameters)
+  #:use-module (webid-oidc resource-server)
+  #:use-module (webid-oidc refresh-token)
+  #:use-module (webid-oidc client))
 
 ;; This module is used only when running tests.