Restructure the client API

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

1 files changed, 426 insertions, 97 deletions

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