Add an application state class to handle multi-threaded actions

1 files changed, 343 insertions, 0 deletions

diff --git a/src/scm/webid-oidc/client/application.scm b/src/scm/webid-oidc/client/application.scm
new file mode 100644
index 0000000..655ee16
--- /dev/null
+++ b/src/scm/webid-oidc/client/application.scm
@@ -0,0 +1,343 @@
+;; 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 application)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 i18n)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 futures)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-19)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module ((webid-oidc oidc-id-token) #:prefix id:)
+  #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:)
+  #:use-module ((webid-oidc jwk) #:prefix jwk:)
+  #:use-module ((webid-oidc dpop-proof) #:prefix dpop:)
+  #:use-module ((webid-oidc client client) #:prefix client:)
+  #:use-module ((webid-oidc client accounts) #:prefix account:)
+  #:use-module ((webid-oidc cache) #:prefix cache:)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (web uri)
+  #:use-module (web response)
+  #:use-module (web client)
+  #:use-module (rnrs bytevectors)
+  #:use-module (oop goops)
+  #:declarative? #t
+  #:export
+  (
+   <application-state>
+   main-account other-accounts client error-messages authorization-prompts
+   
+   <multitask-application-state>
+   current-state pending-operations
+
+   check-pending-operations
+   add-account
+   choose-account
+   set-client
+   process-authorization-prompts
+
+   ->sexp
+   )
+  #:declarative? #t)
+
+(define <client:client> client:<client>)
+(define <account:account> account:<account>)
+
+(define-class <application-state> ()
+  (main-account
+   #:init-keyword #:main-account
+   #:getter main-account
+   #:init-value #f)
+  (other-accounts
+   #:init-keyword #:other-accounts
+   #:getter other-accounts
+   #:init-value '())
+  (client
+   #:init-keyword #:client
+   #:getter client
+   #:init-thunk (lambda ()
+                  (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")))
+  (error-messages
+   #:init-keyword #:error-messages
+   #:getter error-messages
+   #:init-value '())
+  ;; This is a list of pairs: URI * procedure to call on the
+  ;; authorization code
+  (authorization-prompts
+   #:init-keyword #:authorization-prompts
+   #:getter authorization-prompts
+   #:init-value '()))
+
+(define-method (->sexp (state <application-state>))
+  `(begin
+     (use-modules (oop goops) (webid-oidc client application))
+     (make <application-state>
+       ,@(let ((main-account (main-account state)))
+           (if main-account
+               `(#:main-account ,(account:->sexp main-account))
+               '()))
+       #:other-accounts (list ,@(map account:->sexp (other-accounts state)))
+       ,@(let ((client (client state)))
+           (if client
+               `(#:client ,(client:->sexp client))
+               '()))
+       #:error-messages (list ,@(error-messages state)))))
+
+(define-method (write (state <application-state>) port)
+  (pretty-print (->sexp state) port))
+
+(define-method (display (state <application-state>) port)
+  (format port "#<<application-state> main-account=~a client=~a error-messages=~a authorization-prompts=~a>"
+          (call-with-output-string
+            (lambda (port)
+              (display (main-account state) port)))
+          (call-with-output-string
+            (lambda (port)
+              (display (client state) port)))
+          (error-messages state)
+          (map (match-lambda (((= uri->string uri) . _) uri))
+               (authorization-prompts state))))
+
+(define-class <multitask-application-state> ()
+  (current-state
+   #:init-keyword #:current-state
+   #:getter current-state
+   #:init-thunk (lambda () (make <application-state>)))
+  ;; This is an atomic box to a list of state -> state functions that
+  ;; should be executed as soon as possible, in reverse order.
+  (pending-operations
+   #:init-keyword #:pending-operations
+   #:getter pending-operations
+   #:init-thunk (lambda () (make-atomic-box '()))))
+
+(define-method (->sexp (state <multitask-application-state>))
+  `(begin
+     (use-modules (oop goops) (webid-oidc client application))
+     (make <multitask-application-state>
+       #:current-state ,(->sexp (current-state state)))))
+
+(define-method (write (state <multitask-application-state>) port)
+  (pretty-print (->sexp state) port))
+
+(define-method (display (state <multitask-application-state>) port)
+  (format port "#<<multitask-application-state> current-state=~a n-pending-operations=~a>"
+          (call-with-output-string
+            (lambda (port)
+              (display (current-state state) port)))
+          (length (atomic-box-ref (pending-operations state)))))
+
+(define-method (check-pending-operations (state <multitask-application-state>))
+  (let steal-pending-operations ()
+    (let* ((box (pending-operations state))
+           (stolen-pending-operations
+            (atomic-box-ref (pending-operations state)))
+           (confirmed-pending-operations
+            (atomic-box-compare-and-swap! box stolen-pending-operations '())))
+      (if (eq? stolen-pending-operations confirmed-pending-operations)
+          (let apply-all ((state (current-state state))
+                          (ops (reverse stolen-pending-operations)))
+            (match ops
+              (()
+               (make <multitask-application-state>
+                 #:current-state state
+                 #:pending-operations box))
+              ((hd tl ...)
+               (apply-all (hd state) tl))))
+          ;; Concurrent update, retry
+          (steal-pending-operations)))))
+
+(define-method (push-pending-operation (state <multitask-application-state>) f)
+  (let ((other-pending-operations
+         (atomic-box-ref (pending-operations state))))
+    (let ((confirmed (atomic-box-compare-and-swap!
+                      (pending-operations state)
+                      other-pending-operations
+                      `(,f ,@other-pending-operations))))
+      (unless (eq? confirmed other-pending-operations)
+        ;; Retry
+        (push-pending-operation state f)))))
+
+(define http-request-with-cache
+  (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)))))))
+
+(define-method (run-async (state <multitask-application-state>) f)
+  (call-with-new-thread
+   (lambda ()
+     (let ((tag (make-prompt-tag)))
+       (define (handle-authorization-prompts f)
+         (call-with-prompt tag
+           (lambda ()
+             (parameterize
+                 ((client:client (client (current-state state)))
+                  (account:authorization-process
+                   (lambda* (uri #:key issuer)
+                     (abort-to-prompt
+                      tag
+                      (lambda (continuation)
+                        ;; This is a state updating function. It just
+                        ;; registers the continuation as a new
+                        ;; authorization prompt.
+                        (define (continuation-with-dynamic-state authorization-code)
+                          (handle-authorization-prompts
+                           (lambda ()
+                             (continuation authorization-code))))
+                        (lambda (previous-state)
+                          ;; This code is ran in the main thread.
+                          (let ((ret (shallow-clone previous-state)))
+                            (slot-set! ret 'authorization-prompts
+                                       `((,uri . ,continuation-with-dynamic-state)
+                                         ,@(authorization-prompts previous-state)))
+                            ret))))))
+                  (account:anonymous-http-request http-request-with-cache))
+               (with-exception-handler
+                   (lambda (exn)
+                     (let ((msg (if (exception-with-message? exn)
+                                    (exception-message exn)
+                                    (format #f "~s" exn))))
+                       (abort-to-prompt
+                        tag
+                        (lambda (_)
+                          ;; We won’t continue, but we will show the error message
+                          (lambda (previous-state)
+                            (let ((ret (shallow-clone previous-state)))
+                              (slot-set! ret 'error-messages
+                                         `(,msg ,@(error-messages previous-state)))
+                              ret))))))
+                 f)))
+           (lambda (continuation get-updater)
+             (push-pending-operation state (get-updater continuation)))))
+       (handle-authorization-prompts
+        (lambda ()
+          (let ((updater (f)))
+            (push-pending-operation state updater))))))))
+
+(define-method (add-account (state <multitask-application-state>) issuer)
+  (run-async
+   state
+   (lambda ()
+     (let ((new-account (make <account:account> #:issuer issuer)))
+       ;; The updater either sets the main account, or adds it to the
+       ;; other accounts. If there is already an account with the same
+       ;; subject and issuer, print an error message instead.
+       (lambda (previous-state)
+         (let ((current-main-account (main-account previous-state)))
+           (if current-main-account
+               (if (and (equal? (subject current-main-account) (subject new-account))
+                        (equal? (issuer current-main-account) (issuer new-account)))
+                   ;; First kind of duplicate
+                   (let ((ret (shallow-clone previous-state)))
+                     (slot-set! ret 'error-messages
+                                `(,(format #f (G_ "You already have an account for ~a issued by ~a and it is currently selected.")
+                                           (uri->string (subject new-account))
+                                           (uri->string (issuer new-account)))))
+                     ret)
+                   ;; The main account slot is already taken, add it to the other accounts
+                   (let check ((other (other-accounts previous-state)))
+                     (match other
+                       (()
+                        ;; The account does not already exist
+                        (let ((ret (shallow-clone previous-state)))
+                          (slot-set! ret 'other-accounts
+                                     `(,new-account ,@(other-accounts previous-state)))
+                          ret))
+                       ((existing other ...)
+                        (if (and (equal? (subject existing) (subject new-account))
+                                 (equal? (issuer existing) (issuer new-account)))
+                            ;; Second kind of duplicate
+                            (let ((ret (shallow-clone previous-state)))
+                              (slot-set! ret 'error-messages
+                                         `(,(format #f (G_ "You already have an account for ~a issued by ~a.")
+                                                    (uri->string (subject new-account))
+                                                    (uri->string (issuer new-account)))))
+                              ret)
+                            (check other))))))
+               ;; No main account yet
+               (let ((ret (shallow-clone previous-state)))
+                 (slot-set! ret 'main-account new-account)
+                 ret)))))))
+  state)
+
+(define-method (choose-account (state <multitask-application-state>) (account <account:account>))
+  (let ((ret (shallow-clone state)))
+    (let ((new-state
+           (let ((current (shallow-clone (current-state state))))
+             (slot-set! current 'main-account account)
+             (slot-set! current 'other-accounts
+                        (filter (lambda (other)
+                                  (not (equal? other account)))))
+             current)))
+      (slot-set! ret 'current-state new-state))
+    ret))
+
+(define-method (set-client (state <multitask-application-state>) (client <client:client>))
+  (let ((ret (shallow-clone state)))
+    (let ((new-state
+           (let ((current (shallow-clone (current-state state))))
+             (slot-set! current 'client client)
+             current)))
+      (slot-set! ret 'current-state new-state))
+    ret))
+
+(define-method (process-authorization-prompts (state <application-state>) f seed)
+  (let iter ((prompts (authorization-prompts state))
+             (unsolved '())
+             (seed seed))
+    (match prompts
+      (()
+       (let ((ret (shallow-clone state)))
+         (slot-set! ret 'authorization-prompts
+                    (reverse unsolved))
+         (values seed ret)))
+      (((uri . continue) prompts ...)
+       (receive (seed code) (f seed uri)
+         (when code
+           (continue code))
+         (iter prompts
+               (if code
+                   unsolved
+                   `((,uri . ,continue) ,@unsolved))
+               seed))))))
+
+(define-method (process-authorization-prompts (state <multitask-application-state>) f seed)
+  (let ((ret (shallow-clone state)))
+    (receive (seed new-state)
+        (process-authorization-prompts (current-state state) f seed)
+      (slot-set! ret 'current-state new-state)
+      (values seed ret))))