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.

5 files changed, 983 insertions, 656 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
diff --git a/src/scm/webid-oidc/client/Makefile.am b/src/scm/webid-oidc/client/Makefile.am
index ccb7e35..583193e 100644
--- a/src/scm/webid-oidc/client/Makefile.am
+++ b/src/scm/webid-oidc/client/Makefile.am
@@ -15,7 +15,9 @@
 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 dist_clientwebidoidcmod_DATA += \
-  %reldir%/accounts.scm
+  %reldir%/accounts.scm \
+  %reldir%/client.scm
 
 clientwebidoidcgo_DATA += \
-  %reldir%/accounts.go
+  %reldir%/accounts.go \
+  %reldir%/client.go
diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm
index cd69c59..f978257 100644
--- a/src/scm/webid-oidc/client/accounts.scm
+++ b/src/scm/webid-oidc/client/accounts.scm
@@ -1,3 +1,19 @@
+;; 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/>.
+
 (define-module (webid-oidc client accounts)
   #:use-module (sxml simple)
   #:use-module (sxml match)
@@ -5,6 +21,7 @@
   #:use-module (ice-9 exceptions)
   #:use-module (ice-9 i18n)
   #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (webid-oidc errors)
@@ -14,24 +31,31 @@
   #: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 ((webid-oidc client client) #:prefix client:)
   #:use-module (web uri)
   #:use-module (web response)
   #:use-module (web client)
   #:use-module (rnrs bytevectors)
+  #:use-module (oop goops)
   #:declarative? #t
   #:export
   (
    <account>
-   make-account
-   account?
-   account-subject
-   account-issuer
-   account-id-token
-   account-access-token
-   account-refresh-token
-   account-keypair
+   subject set-subject
+   issuer set-issuer
+   id-token set-id-token
+   access-token set-access-token
+   refresh-token set-refresh-token
+   key-pair set-key-pair
+
+   <protected-account>
+   username set-username
+   encrypted-password set-encrypted-password
+   check-credentials
 
    authorization-process
+   authorization-state
+   anonymous-http-request
 
    &authorization-code-required
    make-authorization-code-required
@@ -48,12 +72,13 @@
    token-request-response
    token-request-response-body
 
-   read-accounts
-   save-account
-   delete-account
+   &login-failed
+   make-login-failed
+   login-failed?
+
    invalidate-access-token
    invalidate-refresh-token
-   login
+   refresh
    )
   #:declarative? #t)
 
@@ -100,453 +125,361 @@
          (make-exception-with-message final-message))
         #: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 (@ (alg ,alg) (sub ,sub) (aud ,aud) (nonce ,nonce) (iat ,iat) (exp ,exp)))
-         (collect-arguments
-          (id:the-id-token
-           `(((alg . ,alg))
-             . ((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))
-          tl)))))))
-
-(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
-        ,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
-                         (@ (subject ,(uri->string subject))
-                            (issuer ,(uri->string issuer)))
-                         ,@(if id-token
-                               `((id-token (@ (alg ,(symbol->string (id:id-token-alg 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))))
+(define authorization-state
+  (make-parameter #f))
+
+(define anonymous-http-request
+  (make-parameter http-request))
 
 (define (http-request->http-get http-request)
   (lambda* (uri . all-args)
     (apply http-request uri #:method 'GET all-args)))
 
-;; subject is optional. If the user is unknown, ask for an issuer and
-;; pass #f as subject.
-(define* (login subject issuer
-                #:key
-                (http-request http-request)
-                (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-request->http-get http-request))))
-               (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-request token-endpoint
-                               #:method 'POST
-                               #:body
-                               (string-join
-                                (map
-                                 (match-lambda
+(define (http-get-implementation)
+  (http-request->http-get (anonymous-http-request)))
+
+(define-class <account> ()
+  (subject #:init-keyword #:subject #:getter subject)
+  (issuer #:init-keyword #:issuer #:getter issuer)
+  (id-token #:init-keyword #:id-token #:getter id-token #:init-value #f)
+  (access-token #:init-keyword #:access-token #:getter access-token #:init-value #f)
+  (refresh-token #:init-keyword #:refresh-token #:getter refresh-token #:init-value #f)
+  (key-pair #:init-keyword #:key-pair #:getter key-pair))
+
+(define-method (equal? (a <account>) (b <account>))
+  (and (equal? (subject a) (subject b))
+       (equal? (issuer a) (issuer b))
+       (equal? (id-token a) (id-token b))
+       (equal? (access-token a) (access-token b))
+       (equal? (refresh-token a) (refresh-token b))
+       (equal? (key-pair a) (key-pair b))))
+
+(define-exception-type
+  &login-failed
+  &external-error
+  make-login-failed
+  login-failed?)
+
+(define-method (initialize (account <account>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((subject #f)
+    (issuer #f)
+    (id-token #f)
+    (access-token #f)
+    (refresh-token #f)
+    (key-pair #f))
+   (match `(,subject ,issuer)
+     (((or (? string? (= string->uri (? uri? subject)))
+           (? uri? subject))
+       (or (? string? (= string->uri (? uri? issuer)))
+           (? uri? issuer)))
+      (slot-set! account 'subject subject)
+      (slot-set! account 'issuer issuer))
+     ((#f
+       (or (? string? (= string->uri (? uri? issuer)))
+           (? uri? issuer)))
+      ;; Create the account
+      (let ((client (client:client)))
+        (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-implementation))))
+              (values
+               (cfg:oidc-configuration-authorization-endpoint configuration)
+               (cfg:oidc-configuration-token-endpoint configuration)))
+          (receive (grant-type grant)
+              (if refresh-token
+                  (values "refresh_token" refresh-token)
+                  (values
+                   "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-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))))
-                 (let ((final-message
-                        (format #f (G_ "The refresh token has expired."))))
-                   (raise-exception
-                    (make-exception
-                     (make-refresh-token-expired)
-                     (make-exception-with-message final-message)))))
-               (unless (eqv? (response-code response) 200)
-                 (let ((final-message
-                        (format #f (G_ "The token request failed with code ~s (~s).")
-                                (response-code response)
-                                (response-reason-phrase response))))
-                   (raise-exception
-                    (make-exception
-                     (make-token-request-failed response response-body)
-                     (make-exception-with-message final-message)))))
-               (unless (response-content-type response)
-                 (let ((final-message
-                        (format #f (G_ "The token response did not set the content type."))))
-                   (raise-exception
-                    (make-exception
-                     (make-token-request-failed response response-body)
-                     (make-exception-with-message final-message)))))
-               (with-exception-handler
-                   (lambda (encoding-error)
-                     (let ((final-message
-                            (format #f (G_ "The token endpoint did not respond in UTF-8."))))
-                       (raise-exception
-                        (make-exception
-                         (make-token-request-failed response response-body)
-                         (make-exception-with-message final-message)
-                         encoding-error))))
-                 (lambda ()
-                   (when (bytevector? response-body)
-                     (set! response-body (utf8->string response-body)))))
-               (unless (eq? (car (response-content-type response))
-                            'application/json)
-                 (let ((final-message
-                        (format #f (G_ "The token response has content-type ~s, not application/json.")
-                                (response-content-type response))))
-                   (raise-exception
-                    (make-exception
-                     (make-token-request-failed response response-body)
-                     (make-exception-with-message final-message)))))
-               (let ((data
-                      (with-exception-handler
-                          (lambda (json-error)
-                            (let ((final-message
-                                   (format #f (G_ "The token response is not valid JSON."))))
-                              (raise-exception
-                               (make-exception
-                                (make-token-request-failed response response-body)
-                                (make-exception-with-message final-message)
-                                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
-                     (let ((final-message
-                            (format #f (G_ "The token response did not include an ID token: ~s")
-                                    data)))
-                       (raise-exception
-                        (make-exception
-                         (make-token-request-failed response response-body)
-                         (make-exception-with-message final-message)))))
-                   (unless access-token
-                     (let ((final-message
-                            (format #f (G_ "The token response did not include an access token: ~s
+                                    (string-join `(,(symbol->string key)
+                                                   ,(uri-encode value))
+                                                 "=")))
+                                 `((client_id . ,(uri->string (client:client-id client)))
+                                   (redirect_uri . ,(uri->string (client:client-redirect-uri client)))
+                                   ,@(let ((state (authorization-state)))
+                                       (if state
+                                           `((state . ,state))
+                                           '()))))
+                            "&"))))
+                     ((authorization-process) authorization-uri #:issuer issuer))))
+            (unless key-pair
+              (set! key-pair (client:client-key-pair client)))
+            (let ((dpop-proof
+                   (dpop:issue-dpop-proof
+                    key-pair
+                    #:alg (case (jwk:kty key-pair)
+                            ((EC) 'ES256)
+                            ((RSA) 'RS256))
+                    #:htm 'POST
+                    #:htu token-endpoint)))
+              (receive (response response-body)
+                  ((anonymous-http-request) token-endpoint
+                   #:method 'POST
+                   #:body
+                   (string-join
+                    (map
+                     (match-lambda
+                       ((key . value)
+                        (string-append (uri-encode key)
+                                       "="
+                                       (uri-encode value))))
+                     `(("grant_type" . ,grant-type)
+                       (,(if (equal? grant-type "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)
+                  (let ((final-message
+                         (format #f (G_ "The refresh token has expired."))))
+                    (raise-exception
+                     (make-exception
+                      (make-refresh-token-expired)
+                      (make-exception-with-message final-message)))))
+                (unless (eqv? (response-code response) 200)
+                  (let ((final-message
+                         (format #f (G_ "The token request failed with code ~s (~s).")
+                                 (response-code response)
+                                 (response-reason-phrase response))))
+                    (raise-exception
+                     (make-exception
+                      (make-token-request-failed response response-body)
+                      (make-exception-with-message final-message)))))
+                (unless (response-content-type response)
+                  (let ((final-message
+                         (format #f (G_ "The token response did not set the content type."))))
+                    (raise-exception
+                     (make-exception
+                      (make-token-request-failed response response-body)
+                      (make-exception-with-message final-message)))))
+                (with-exception-handler
+                    (lambda (encoding-error)
+                      (let ((final-message
+                             (format #f (G_ "The token endpoint did not respond in UTF-8."))))
+                        (raise-exception
+                         (make-exception
+                          (make-token-request-failed response response-body)
+                          (make-exception-with-message final-message)
+                          encoding-error))))
+                  (lambda ()
+                    (when (bytevector? response-body)
+                      (set! response-body (utf8->string response-body)))))
+                (unless (eq? (car (response-content-type response))
+                             'application/json)
+                  (let ((final-message
+                         (format #f (G_ "The token response has content-type ~s, not application/json.")
+                                 (response-content-type response))))
+                    (raise-exception
+                     (make-exception
+                      (make-token-request-failed response response-body)
+                      (make-exception-with-message final-message)))))
+                (let ((data
+                       (with-exception-handler
+                           (lambda (json-error)
+                             (let ((final-message
+                                    (format #f (G_ "The token response is not valid JSON."))))
+                               (raise-exception
+                                (make-exception
+                                 (make-token-request-failed response response-body)
+                                 (make-exception-with-message final-message)
+                                 json-error))))
+                         (lambda ()
+                           (stubs:json-string->scm response-body)))))
+                  (set! id-token (assq-ref data 'id_token))
+                  (set! access-token (assq-ref data 'access_token))
+                  (set! refresh-token
+                        (assq-ref data 'refresh_token))
+                  (unless id-token
+                    (let ((final-message
+                           (format #f (G_ "The token response did not include an ID token: ~s")
+                                   data)))
+                      (raise-exception
+                       (make-exception
+                        (make-token-request-failed response response-body)
+                        (make-exception-with-message final-message)))))
+                  (unless access-token
+                    (let ((final-message
+                           (format #f (G_ "The token response did not include an access token: ~s
 ")
-                                    data)))
-                       (raise-exception
-                        (make-exception
-                         (make-token-request-failed response response-body)
-                         (make-exception-with-message final-message)))))
-                   (with-exception-handler
-                       (lambda (decoding-error)
-                         (let ((final-message
-                                (if (exception-with-message? decoding-error)
-                                    (format #f (G_ "the ID token signature is invalid: ~a")
-                                            (exception-message decoding-error))
-                                    (format #f (G_ "the ID token signature is invalid")))))
-                           (raise-exception
-                            (make-exception
-                             (make-token-request-failed response response-body)
-                             (make-exception-with-message final-message)
-                             decoding-error))))
-                     (lambda ()
-                       (set! id-token
-                             (id:id-token-decode id-token
-                                                 #:http-get
-                                                 (http-request->http-get http-request)))))
-                   ;; 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))))
-                     (let ((final-message
-                            (format #f (G_ "the ID token delivered by the identity provider for ~s has ~s as webid")
-                                    (uri->string subject)
-                                    (id:id-token-webid id-token))))
-                       (raise-exception
-                        (make-exception
-                         (make-token-request-failed response response-body)
-                         (make-exception-with-message final-message)))))
-                   (when (not (equal? issuer (id:id-token-iss id-token)))
-                     (let ((final-message
-                            (format #f (G_ "The ID token delivered by the identity provider ~s is for issuer ~s.")
-                                    (uri->string issuer)
-                                    (id:id-token-iss id-token))))
-                       (raise-exception
-                        (make-exception
-                         (make-token-request-failed response response-body)
-                         (make-exception-with-message final-message)))))
-                   (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))))))))
+                                   data)))
+                      (raise-exception
+                       (make-exception
+                        (make-token-request-failed response response-body)
+                        (make-exception-with-message final-message)))))
+                  (with-exception-handler
+                      (lambda (decoding-error)
+                        (let ((final-message
+                               (if (exception-with-message? decoding-error)
+                                   (format #f (G_ "the ID token signature is invalid: ~a")
+                                           (exception-message decoding-error))
+                                   (format #f (G_ "the ID token signature is invalid")))))
+                          (raise-exception
+                           (make-exception
+                            (make-token-request-failed response response-body)
+                            (make-exception-with-message final-message)
+                            decoding-error))))
+                    (lambda ()
+                      (set! id-token
+                            (id:id-token-decode id-token
+                                                #:http-get
+                                                (http-request->http-get (anonymous-http-request))))))
+                  ;; 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))))
+                    (let ((final-message
+                           (format #f (G_ "the ID token delivered by the identity provider for ~s has ~s as webid")
+                                   (uri->string subject)
+                                   (id:id-token-webid id-token))))
+                      (raise-exception
+                       (make-exception
+                        (make-token-request-failed response response-body)
+                        (make-exception-with-message final-message)))))
+                  (set! subject (id:id-token-webid id-token))
+                  (when (not (equal? issuer (id:id-token-iss id-token)))
+                    (let ((final-message
+                           (format #f (G_ "The ID token delivered by the identity provider ~s is for issuer ~s.")
+                                   (uri->string issuer)
+                                   (id:id-token-iss id-token))))
+                      (raise-exception
+                       (make-exception
+                        (make-token-request-failed response response-body)
+                        (make-exception-with-message final-message)))))
+                  (slot-set! account 'subject subject)
+                  (slot-set! account 'issuer issuer)
+                  (slot-set! account 'id-token id-token)
+                  (slot-set! account 'access-token access-token)
+                  (slot-set! account 'refresh-token refresh-token)
+                  (slot-set! account 'key-pair key-pair))))))))
+     ((#f #f)
+      (scm-error 'wrong-type-arg "make <account>"
+                 (G_ "The issuer is required.")
+                 '()
+                 (list issuer)))
+     (else
+      (scm-error 'wrong-type-arg "make <account>"
+                 (G_ "The optional subject and required issuer should be strings or URI.")
+                 '()
+                 (list subject issuer))))))
+
+(define-class <protected-account> (<account>)
+  (username #:init-keyword #:username #:getter username)
+  (encrypted-password #:init-keyword #:encrypted-password #:getter encrypted-password))
+
+(define-method (check-credentials (account <protected-account>) (username <string>) (password <string>))
+  (let ((c (crypt password (encrypted-password account))))
+    (unless (string=? c (encrypted-password account))
+      (raise-exception
+       (make-exception
+        (make-login-failed)
+        (make-exception-with-message
+         (G_ "Cannot check the username and/or password.")))))))
+
+(define-method (set-subject (a <account>) uri)
+  (let ((ret (shallow-clone a))
+        (uri
+         (match uri
+           ((? uri? uri) uri)
+           ((? string? (= string->uri (? uri? uri))) uri)
+           (else
+            (scm-error 'wrong-type-arg "set-subject"
+                       (G_ "The subject should be a string or URI.")
+                       '()
+                       (list subject))))))
+    (slot-set! ret 'subject uri)
+    ret))
+
+(define-method (set-issuer (a <account>) uri)
+  (let ((ret (shallow-clone a))
+        (uri
+         (match uri
+           ((? uri? uri) uri)
+           ((? string? (= string->uri (? uri? uri))) uri)
+           (else
+            (scm-error 'wrong-type-arg "set-issuer"
+                       (G_ "The issuer should be a string or URI.")
+                       '()
+                       (list issuer))))))
+    (slot-set! ret 'issuer uri)
+    ret))
+
+(define-method (set-id-token (a <account>) id-token)
+  (let ((ret (shallow-clone a)))
+    (slot-set! ret 'id-token id-token)
+    ret))
+
+(define-method (set-access-token (a <account>) access-token)
+  (let ((ret (shallow-clone a)))
+    (slot-set! ret 'access-token access-token)
+    ret))
+
+(define-method (set-refresh-token (a <account>) refresh-token)
+  (let ((ret (shallow-clone a)))
+    (slot-set! ret 'refresh-token refresh-token)
+    ret))
+
+(define-method (set-key-pair (a <account>) key-pair)
+  (let ((ret (shallow-clone a)))
+    (slot-set! ret 'key-pair key-pair)
+    ret))
+
+(define-method (set-username (a <protected-account>) username)
+  (let ((ret (shallow-clone a)))
+    (slot-set! ret 'username username)
+    ret))
+
+(define-method (set-encrypted-password (a <protected-account>) encrypted-password)
+  (let ((ret (shallow-clone a)))
+    (slot-set! ret 'encrypted-password encrypted-password)
+    ret))
+
+(define-method (invalidate-access-token (a <account>))
+  (set-id-token
+   (set-access-token a #f)
+   #f))
+
+(define-method (invalidate-refresh-token (a <account>))
+  (set-refresh-token a #f))
+
+(define-method (refresh (a <account>))
+  ;; Fill the holes made by invalidate-access-token
+  (let ((full
+         (make <account>
+           #:issuer (issuer a)
+           #:refresh-token (refresh-token a)
+           #:key-pair (key-pair a))))
+    (unless (equal? (subject a) (subject full))
+      (set! a (set-subject a (subject full))))
+    (unless (equal? (issuer a) (issuer full))
+      (set! a (set-issuer a (issuer full))))
+    (unless (equal? (id-token a) (id-token full))
+      (set! a (set-id-token a (id-token full))))
+    (unless (equal? (access-token a) (access-token full))
+      (set! a (set-access-token a (access-token full))))
+    (unless (equal? (refresh-token a) (refresh-token full))
+      (set! a (set-refresh-token a (refresh-token full))))
+    (unless (equal? (key-pair a) (key-pair full))
+      (set! a (set-key-pair a (key-pair full))))
+    a))
diff --git a/src/scm/webid-oidc/client/client.scm b/src/scm/webid-oidc/client/client.scm
new file mode 100644
index 0000000..66f8b74
--- /dev/null
+++ b/src/scm/webid-oidc/client/client.scm
@@ -0,0 +1,92 @@
+;; 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/>.
+
+(define-module (webid-oidc client client)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc provider-confirmation)
+  #:use-module (webid-oidc oidc-configuration)
+  #:use-module (webid-oidc oidc-id-token)
+  #:use-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module ((webid-oidc jwk) #:prefix jwk:)
+  #: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)
+  #:use-module (web response)
+  #:use-module (web server)
+  #: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 (ice-9 match)
+  #:use-module (sxml simple)
+  #:use-module (oop goops)
+  #:export
+  (
+   <client>
+   client-id
+   client-key-pair
+   client-redirect-uri
+
+   client
+   )
+  #:declarative? #t)
+
+(define-class <client> ()
+  (client-id #:init-keyword #:client-id #:getter client-id)
+  (key-pair #:init-keyword #:key-pair #:getter client-key-pair)
+  (redirect-uri #:init-keyword #:redirect-uri #:getter client-redirect-uri))
+
+(define-method (initialize (client <client>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((client-id #f)
+    (key-pair #t) ;; We’ll generate one if not #f
+    (redirect-uri #f))
+   (let convert-args ((client-id client-id)
+                      (key-pair key-pair)
+                      (redirect-uri redirect-uri))
+     (match `(,client-id ,key-pair ,redirect-uri)
+       (((or (? string? (= string->uri (? uri? client-id)))
+             (? uri? client-id))
+         (? jwk:jwk? client-key)
+         (or (? string? (= string->uri (? uri? redirect-uri)))
+             (? uri? redirect-uri)))
+        (begin
+          (slot-set! client 'client-id client-id)
+          (slot-set! client 'key-pair client-key)
+          (slot-set! client 'redirect-uri redirect-uri)))
+       ((_ #t _)
+        (convert-args client-id (jwk:generate-key #:n-size 2048) redirect-uri))
+       (else
+        (scm-error 'wrong-type-arg "make <account>"
+                   (G_ "Client ID and redirect URIs should be URIs, and key pair should be a key pair..")
+                   '()
+                   (list client-id key-pair redirect-uri)))))))
+
+(define client
+  (make-parameter #f))
diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm
index 16e19ae..9bf99c1 100644
--- a/src/scm/webid-oidc/example-app.scm
+++ b/src/scm/webid-oidc/example-app.scm
@@ -16,7 +16,7 @@
 
 (define-module (webid-oidc example-app)
   #:use-module ((webid-oidc client) #:prefix client:)
-  #:use-module ((webid-oidc client accounts) #:prefix client:)
+  #:use-module ((webid-oidc client accounts) #:prefix account:)
   #:use-module ((webid-oidc cache) #:prefix cache:)
   #:use-module (webid-oidc dpop-proof)
   #:use-module (webid-oidc web-i18n)
@@ -29,8 +29,10 @@
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web server)
+  #:use-module (web http)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 getopt-long)
@@ -39,105 +41,432 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 match)
   #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 readline)
   #:use-module (sxml simple)
   #:use-module (rnrs bytevectors)
-  #:declarative? #t)
+  #:use-module (oop goops)
+  #:declarative? #t
+  #:export (main))
 
-(define example-app
-  (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")))
+(define <client:client> client:<client>)
+(define <account:account> account:<account>)
+
+(define-class <app-state> ()
+  (account #:init-keyword #:account #:getter app-state-account)
+  (unused-accounts #:init-keyword #:unused-accounts #:getter app-state-unused-accounts)
+  (uri #:init-keyword #:uri #:getter app-state-uri)
+  (method #:init-keyword #:method #:getter app-state-method #:init-value 'GET)
+  (headers #:init-keyword #:headers #:getter app-state-headers #:init-value '()))
+
+(define-method (equal? (a <app-state>) (b <app-state>))
+  ;; This method will let us know if an action is a re-do or a novel
+  ;; update
+  (and (equal? (app-state-account a) (app-state-account b))
+       (equal? (app-state-unused-accounts a) (app-state-unused-accounts b))
+       (equal? (app-state-uri a) (app-state-uri b))
+       (eq? (app-state-method a) (app-state-method b))
+       (equal? (app-state-headers a) (app-state-headers b))))
+
+(define-method (add-account (app <app-state>) (account <account:account>))
+  (let ((ret (shallow-clone app)))
+    ;; If we have already selected an account, make it unused,
+    ;; otherwise select it as default.
+    (if (app-state-account ret)
+        (slot-set! ret 'unused-accounts
+                   `(,account ,@(app-state-unused-accounts app)))
+        (slot-set! ret 'account account))
+    ret))
+
+(define-method (enumerate-accounts (app <app-state>))
+  (let construct ((all-accounts `(,(app-state-account app)
+                                  ,@(app-state-unused-accounts app)))
+                  (i 1)
+                  (constructed '()))
+    (match all-accounts
+      (()
+       (reverse constructed))
+      ((next rest ...)
+       (construct rest (+ i 1) `((,i . ,next) ,@constructed))))))
+
+(define-method (account-summary (account <account:account>))
+  (let ((subject (account:subject account))
+        (issuer (account:issuer account))
+        (access-token (account:access-token account))
+        (refresh-token (account:refresh-token account)))
+    (cond
+     ((and access-token refresh-token)
+      (format #f (G_ "~a (issued by ~a): no interaction required")
+              (uri->string subject) (uri->string issuer)))
+     (refresh-token
+      (format #f (G_ "~a (issued by ~a): offline but accessible")
+              (uri->string subject) (uri->string issuer)))
+     (access-token
+      (format #f (G_ "~a (issued by ~a): online")
+              (uri->string subject) (uri->string issuer)))
+     (else
+      (format #f (G_ "~a (issued by ~a): inaccessible")
+              (uri->string subject) (uri->string issuer))))))
+
+(define-method (choose-account (app <app-state>) (i <integer>))
+  (let ((ret (shallow-clone app))
+        (all-accounts (enumerate-accounts app)))
+    (let find-the-account ((accounts all-accounts)
+                           (past '()))
+      (match accounts
+        (()
+         (raise-exception
+          (make-exception
+           (make-exception-with-message
+            (format #f (G_ "Your choice ~a does not exist.\n") i)))))
+        ((((? (cute eqv? <> i)) . hd) tl ...)
+         (begin
+           (slot-set! ret 'account hd)
+           (slot-set! ret 'unused-accounts
+                      (let ((tl (map (match-lambda ((_ . account) account)) tl)))
+                        (append-reverse past tl)))))
+        (((_ . hd) tl ...)
+         (find-the-account tl `(,hd ,@past)))))
+    ret))
+
+(define-method (set-uri (app <app-state>) uri)
+  (let ((ret (shallow-clone app)))
+    (when (string? uri)
+      (set! uri (string->uri uri)))
+    (unless (uri? uri)
+      (raise-exception
+       (make-exception
+        (make-exception-with-message (G_ "Your choice is not a valid URI.\n")))))
+    (slot-set! ret 'uri uri)
+    ret))
+
+(define-method (set-method (app <app-state>) method)
+  (with-exception-handler
+      (lambda (exn)
+        (raise-exception
+         (make-exception
+          (make-exception-with-message (G_ "This is not a valid HTTP method.\n")))))
+    (lambda ()
+      (let ((ret (shallow-clone app)))
+        (slot-set! ret 'method (string->symbol method))
+        ret))))
+
+(define-method (clear-headers (app <app-state>))
+  (let ((ret (shallow-clone app)))
+    (slot-set! ret 'headers '())
+    ret))
+
+(define-method (add-header (app <app-state>) (header <string>) (value <string>))
+  (with-exception-handler
+      (lambda (exn)
+        (raise-exception
+         (make-exception
+          (make-exception-with-message (G_ "This is not a valid value for this header.\n")))))
+    (lambda ()
+      (let ((ret (shallow-clone app))
+            (new-header (parse-header (string->symbol header) value)))
+        (slot-set! ret 'headers
+                   `((,(string->symbol header) . ,new-header)
+                     ,@(app-state-headers ret)))
+        ret))))
+
+(define-class <undoable-app-state> ()
+  (previous-states
+   #:init-keyword #:previous-states
+   #:getter app-previous-states
+   #:init-value '())
+  (undone-states
+   #:init-keyword #:undone-states
+   #:getter app-undone-states
+   #:init-value '()))
+
+(define-method (current-state (app <undoable-app-state>))
+  (match (app-previous-states app)
+    ((state _ ...)
+     state)
+    (else
+     (make <app-state> #:account #f #:unused-accounts '() #:uri #f))))
+
+(define-method (can-undo? (app <undoable-app-state>))
+  (not (null? (app-previous-states app))))
+
+(define-method (can-redo? (app <undoable-app-state>))
+  (not (null? (app-undone-states app))))
+
+(define-method (undo (app <undoable-app-state>))
+  (let ((ret (shallow-clone app)))
+    (match (app-previous-states ret)
+      (()
+       (raise-exception
+        (make-exception
+         (make-exception-with-message (G_ "Nothing to undo.\n")))))
+      ((undone other-done ...)
+       (slot-set! ret 'previous-states other-done)
+       (slot-set! ret 'undone-states `(,undone ,@(app-undone-states ret)))))
+    ret))
+
+(define-method (redo (app <undoable-app-state>))
+  (let ((ret (shallow-clone app)))
+    (match (app-undone-states ret)
+      (()
+       (raise-exception
+        (make-exception
+         (make-exception-with-message (G_ "Nothing to redo.\n")))))
+      ((redone other-undone ...)
+       (slot-set! ret 'previous-states `(,redone ,@(app-previous-states ret)))
+       (slot-set! ret 'undone-states other-undone)))
+    ret))
+
+(define-method (push-state (app <undoable-app-state>) (state <app-state>))
+  ;; Maybe it’s a redo
+  (match (app-undone-states app)
+    (((? (cute equal? <> state)) _ ...)
+     ;; This is a redo
+     (redo app))
+    (else
+     ;; This is not a redo
+     (let ((ret (shallow-clone app)))
+       (slot-set! ret 'previous-states `(,state ,@(app-previous-states ret)))
+       (slot-set! ret 'undone-states '())
+       ret))))
+
+(define-method (add-account (app <undoable-app-state>) (account <account:account>))
+  (push-state
+   app
+   (add-account (current-state app) account)))
+
+(define-method (enumerate-accounts (app <undoable-app-state>))
+  (enumerate-accounts (current-state app)))
+
+(define-method (choose-account (app <undoable-app-state>) (i <integer>))
+  (push-state app (choose-account (current-state app) i)))
+
+(define-method (set-uri (app <undoable-app-state>) (uri <string>))
+  (push-state app (set-uri (current-state app) uri)))
+
+(define-method (set-method (app <undoable-app-state>) (method <string>))
+  (push-state app (set-method (current-state app) method)))
+
+(define-method (clear-headers (app <undoable-app-state>))
+  (push-state app (clear-headers (current-state app))))
+
+(define-method (add-header (app <undoable-app-state>) (header <string>) (value <string>))
+  (push-state app (add-header (current-state app) header value)))
+
+(define (with-sigint-handler handler f)
+  ;; I don’t know how to re-install the previous sigaction
+  (dynamic-wind
+    (lambda ()
+      (sigaction SIGINT
+        (lambda (sig)
+          (handler))))
+    f
+    (lambda ()
+      (sigaction SIGINT #f))))
 
 (define (main)
-  (define (do-the-trick subject issuer)
-    (client:request example-app 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
+  (setvbuf (current-output-port) 'none)
+  (setvbuf (current-error-port) 'none)
+  (setlocale LC_ALL "")
+  (bindtextdomain cfg:package cfg:localedir)
+  (textdomain cfg:package)
+  (define add-account-command
+    (G_ "Example app command|add-account"))
+  (define choose-account-command
+    (G_ "Example app command|choose-account"))
+  (define set-uri-command
+    (G_ "Example app command|set-uri"))
+  (define set-method-command
+    (G_ "Example app command|set-method"))
+  (define view-headers-command
+    (G_ "Example app command|view-headers"))
+  (define clear-headers-command
+    (G_ "Example app command|clear-headers"))
+  (define add-header-command
+    (G_ "Example app command|add-header"))
+  (define ok-command
+    (G_ "Example app command|ok"))
+  (define undo-command
+    (G_ "Example app command|undo"))
+  (define redo-command
+    (G_ "Example app command|redo"))
+  (parameterize
+      ((client:client
+        (make <client:client>
+          #:client-id
+          "https://webid-oidc-demo.planete-kraus.eu/example-application#id"
+          #:redirect-uri
+          "https://webid-oidc-demo.planete-kraus.eu/authorized"))
+       (client:authorization-process
+        (lambda* (uri #:key issuer)
+          (format (current-error-port) (G_ "To log in on ~a, please visit: ~a\n")
+                  (uri->string issuer)
+                  (uri->string uri))
+          (format (current-error-port) (G_ "Then, paste the authorization code you get:\n"))
+          (read-line (current-input-port) 'trim)))
+       (client:authorization-state #f)
+       (client:anonymous-http-request
+        (let ((default-http-get-with-cache (cache:with-cache)))
+          (lambda* (uri . all-args)
+            (let try-get-with-cache ((args all-args)
+                                     (args-for-get '()))
+              (match args
+                (()
+                 (apply default-http-get-with-cache uri (reverse args-for-get)))
+                ((#:headers arg other-args ...)
+                 (try-get-with-cache other-args `(,arg #:headers ,@args-for-get)))
+                ((#:method 'GET other-args ...)
+                 (try-get-with-cache other-args args-for-get))
+                (else
+                 (apply http-request uri all-args))))))))
+    (let menu ((state (make <undoable-app-state>)))
+      (format #t (G_ "Account: ~a
+URI: ~a
+Method: ~a
+Headers: ~a
+
+Available commands:
+  - ~a: add an account
+  - ~a: change the account
+  - ~a: change the URI
+  - ~a: change the method
+  - ~a: view all headers
+  - ~a: clear all the headers
+  - ~a: add a new header
+  - ~a: perform the request.
+
 ")
-                (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-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)")))))
-        (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.
-"))
-    (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))))
-      (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)))
-           (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:initial-login example-app (string->uri issuer)))))
-         (main))
-        ((? eof-object? _)
-         (exit 0))
-        (else
-         (main))))))
-
-(main)
+              (let ((acct (app-state-account (current-state state))))
+                (if acct
+                    (account-summary acct)
+                    (G_ "Account:|unset")))
+              (let ((uri (app-state-uri (current-state state))))
+                (if uri
+                    (uri->string uri)
+                    (G_ "URI:|unset")))
+              (let ((method (app-state-method (current-state state))))
+                (if method
+                    (symbol->string method)
+                    (G_ "Method:|unset")))
+              (let ((headers (app-state-headers (current-state state))))
+                (if (null? headers)
+                    (G_ "Headers:|none")
+                    (string-join
+                     (map (match-lambda ((header . _) (symbol->string header)))
+                          headers)
+                     (G_ "list separator|, "))))
+              add-account-command
+              choose-account-command
+              set-uri-command
+              set-method-command
+              view-headers-command
+              clear-headers-command
+              add-header-command
+              ok-command)
+      (when (can-undo? state)
+        (format #t (G_ "You can undo your last command with \"~a\".\n") undo-command))
+      (when (can-redo? state)
+        (format #t (G_ "You can re-apply your last undone command with \"~a\".\n") redo-command))
+      (let ((command (readline (G_ "Readline prompt|Command: "))))
+        (if (eof-object? command)
+            (exit 0)
+            (with-exception-handler
+                (lambda (exn)
+                  (if (exception-with-message? exn)
+                      (begin
+                        (format #t (G_ "An error happened: ~a.\n")
+                                (exception-message exn))
+                        (menu state))
+                      (raise-exception exn)))
+              (lambda ()
+                (cond
+                 ((equal? command add-account-command)
+                  (let ((identity-provider
+                         (with-sigint-handler
+                          (lambda ()
+                            (menu state))
+                          (lambda ()
+                            (readline (G_ "Please enter your identity provider: "))))))
+                    (menu (add-account state (make <account:account> #:issuer identity-provider)))))
+                 ((equal? command choose-account-command)
+                  (let ((accounts (enumerate-accounts state)))
+                    (if (null? accounts)
+                        (begin
+                          (format #t (G_ "You don’t have other accounts available. Please add one with \"add-account\".\n"))
+                          (menu state))
+                        (begin
+                          (let enumerate-accounts ((accounts accounts))
+                            (match accounts
+                              (((i . account) rest ...)
+                               (format #t (G_ "- ~a: ~a\n") i (account-summary account))
+                               (enumerate-accounts rest))
+                              (() #t)))
+                          (with-sigint-handler
+                           (lambda ()
+                             (menu state))
+                           (lambda ()
+                             (let ((choice (string->number
+                                            (readline (format #f (G_ "[1-~a] ")
+                                                              (length accounts))))))
+                               (menu (choose-account state choice)))))))))
+                 ((equal? command set-uri-command)
+                  (with-sigint-handler
+                   (lambda ()
+                     (menu state))
+                   (lambda ()
+                     (menu (set-uri state (readline (G_ "Visit this URI: ")))))))
+                 ((equal? command set-method-command)
+                  (with-sigint-handler
+                   (lambda ()
+                     (menu state))
+                   (lambda ()
+                     (let ((method (readline (G_ "Use this HTTP method [GET]: "))))
+                       (when (equal? method "")
+                         (set! method "GET"))
+                       (menu (set-method state method))))))
+                 ((equal? command view-headers-command)
+                  (write-headers (app-state-headers (current-state state))
+                                 (current-output-port))
+                  (newline)
+                  (menu state))
+                 ((equal? command clear-headers-command)
+                  (menu (clear-headers state)))
+                 ((equal? command add-header-command)
+                  (with-sigint-handler
+                   (lambda ()
+                     (menu state))
+                   (lambda ()
+                     (let ((header (string-downcase (readline (G_ "Which header? ")))))
+                       (let ((value
+                              (readline
+                               (format #f (G_ "Which header value for ~a? ")
+                                       header))))
+                         (menu (add-header state header value)))))))
+                 ((equal? command ok-command)
+                  (receive (account uri)
+                      (let ((state (current-state state)))
+                        (values
+                         (app-state-account state)
+                         (app-state-uri state)))
+                    (if (and account uri)
+                        (receive (account response body)
+                            (client:request (app-state-account (current-state state))
+                                            (app-state-uri (current-state state))
+                                            #:method (app-state-method (current-state state))
+                                            #:headers (app-state-headers (current-state state)))
+                          (let ((ready-to-write-body
+                                 (write-response response (current-output-port))))
+                            (unless (response-must-not-include-body? ready-to-write-body)
+                              (write-response-body ready-to-write-body
+                                                   (if (string? body)
+                                                       (string->utf8 body)
+                                                       body)))
+                            (newline)))
+                        (format #t (G_ "Please define an account and the URI.\n")))
+                    (menu state)))
+                 ((equal? command undo-command)
+                  (menu (undo state)))
+                 ((equal? command redo-command)
+                  (menu (redo state)))
+                 (else
+                  (format #t (G_ "I don’t know that command.\n"))
+                  (menu state))))))))))