From 86bd90866fdc2ab5234c6e09e39bfa972f7fa395 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Thu, 16 Sep 2021 18:11:38 +0200
Subject: Application state: make it fully immutable

---
 src/scm/webid-oidc/client/application.scm | 279 +++++++++++++++++-------------
 1 file changed, 154 insertions(+), 125 deletions(-)

(limited to 'src/scm/webid-oidc/client/application.scm')

diff --git a/src/scm/webid-oidc/client/application.scm b/src/scm/webid-oidc/client/application.scm
index 655ee16..74fcefe 100644
--- a/src/scm/webid-oidc/client/application.scm
+++ b/src/scm/webid-oidc/client/application.scm
@@ -24,6 +24,7 @@
   #:use-module (ice-9 threads)
   #:use-module (ice-9 atomic)
   #:use-module (ice-9 pretty-print)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-19)
   #:use-module (webid-oidc errors)
@@ -45,17 +46,20 @@
   #:declarative? #t
   #:export
   (
+   <job>
+   description result-box thread
+   result join
+
    <application-state>
-   main-account other-accounts client error-messages authorization-prompts
-   
-   <multitask-application-state>
-   current-state pending-operations
+   main-account other-accounts client error-messages authorization-prompts running-jobs pages
 
-   check-pending-operations
    add-account
    choose-account
    set-client
-   process-authorization-prompts
+   fold-authorization-prompts
+   add-page
+   set-page-uri
+   close-page
 
    ->sexp
    )
@@ -64,6 +68,13 @@
 (define <client:client> client:<client>)
 (define <account:account> account:<account>)
 
+(define-class <job> ()
+  (description #:init-keyword #:description #:getter description)
+  (result-box #:init-thunk (lambda () (make-atomic-box #f)) #:getter result-box))
+
+(define-method (result (job <job>))
+  (atomic-box-ref (result-box job)))
+
 (define-class <application-state> ()
   (main-account
    #:init-keyword #:main-account
@@ -86,11 +97,20 @@
    #:init-keyword #:error-messages
    #:getter error-messages
    #:init-value '())
-  ;; This is a list of pairs: URI * procedure to call on the
-  ;; authorization code
+  ;; This is a list of pairs: URI * procedure to call with the
+  ;; authorization code. The procedure takes 2 arguments: the code and
+  ;; a state, and it returns the updated state.
   (authorization-prompts
    #:init-keyword #:authorization-prompts
    #:getter authorization-prompts
+   #:init-value '())
+  (running-jobs
+   #:init-keywords #:running-jobs
+   #:getter running-jobs
+   #:init-value '())
+  (pages
+   #:init-keyword #:pages
+   #:getter pages
    #:init-value '()))
 
 (define-method (->sexp (state <application-state>))
@@ -112,7 +132,7 @@
   (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>"
+  (format port "#<<application-state> main-account=~a client=~a error-messages=~a authorization-prompts=~a running-jobs=~a>"
           (call-with-output-string
             (lambda (port)
               (display (main-account state) port)))
@@ -121,66 +141,20 @@
               (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)))))
+               (authorization-prompts state))
+          (map description (running-jobs 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-method (join (state <application-state>))
+  (let ((ret (shallow-clone state)))
+    (receive (finished unfinished)
+        (partition result (reverse (running-jobs state)))
+      (slot-set! ret 'running-jobs (reverse unfinished))
+      (let apply-finished-jobs ((state ret)
+                                (jobs (map result finished)))
+        (match jobs
+          (() state)
+          ((hd tl ...)
+           (apply-finished-jobs (hd state) tl)))))))
 
 (define http-request-with-cache
   (let ((default-http-get-with-cache (cache:with-cache)))
@@ -197,15 +171,15 @@
           (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)
+(define-method (add-job (state <application-state>) (description <string>) f)
+  (let ((job (make <job> #:description description)))
+    (call-with-new-thread
+     (lambda ()
+       (let ((tag (make-prompt-tag)))
          (call-with-prompt tag
            (lambda ()
              (parameterize
-                 ((client:client (client (current-state state)))
+                 ((client:client (client state))
                   (account:authorization-process
                    (lambda* (uri #:key issuer)
                      (abort-to-prompt
@@ -214,15 +188,15 @@
                         ;; 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.
+                          ;; This code runs in the main thread.
+                          (define (continue state code)
+                            (add-job state description
+                                     (lambda ()
+                                       (continuation code))))
                           (let ((ret (shallow-clone previous-state)))
                             (slot-set! ret 'authorization-prompts
-                                       `((,uri . ,continuation-with-dynamic-state)
+                                       `((,uri . ,continue)
                                          ,@(authorization-prompts previous-state)))
                             ret))))))
                   (account:anonymous-http-request http-request-with-cache))
@@ -240,17 +214,20 @@
                               (slot-set! ret 'error-messages
                                          `(,msg ,@(error-messages previous-state)))
                               ret))))))
-                 f)))
+                 (lambda ()
+                   (let ((updater (f)))
+                     (atomic-box-set! (result-box job) updater))))))
            (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
+             (atomic-box-set! (result-box job) (get-updater continuation)))))))
+    (let ((ret (shallow-clone state)))
+      (slot-set! ret 'running-jobs `(,job ,@(running-jobs ret)))
+      ret)))
+
+(define-method (add-account (state <application-state>) issuer)
+  (add-job
    state
+   (format #f (G_ "Add an account on ~a")
+           (uri->string issuer))
    (lambda ()
      (let ((new-account (make <account:account> #:issuer issuer)))
        ;; The updater either sets the main account, or adds it to the
@@ -294,50 +271,102 @@
                  ret)))))))
   state)
 
-(define-method (choose-account (state <multitask-application-state>) (account <account:account>))
+(define-method (choose-account (state <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))
+    (slot-set! ret 'main-account account)
+    (slot-set! ret 'other-accounts
+               (filter (lambda (other)
+                         (not (equal? other account)))))
     ret))
 
-(define-method (set-client (state <multitask-application-state>) (client <client:client>))
+(define-method (set-client (state <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))
+    (slot-set! ret 'client client)
     ret))
 
-(define-method (process-authorization-prompts (state <application-state>) f seed)
-  (let iter ((prompts (authorization-prompts state))
-             (unsolved '())
-             (seed seed))
+(define-method (fold-authorization-prompts (state <application-state>) f seed)
+  (let iter ((prompts (reverse (authorization-prompts state)))
+             (seed seed)
+             (state
+              (let ((ret (shallow-clone state)))
+                (slot-set! ret 'authorization-prompts '())
+                ret)))
     (match prompts
       (()
-       (let ((ret (shallow-clone state)))
-         (slot-set! ret 'authorization-prompts
-                    (reverse unsolved))
-         (values seed ret)))
+       (values seed state))
       (((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 ((state
+                ;; If I have a code, transform state by calling the
+                ;; continuation function (i.e., add a job that will
+                ;; finish the task). If I don’t, I need to keep this
+                ;; prompt around.
+                (if code
+                    (continue state code)
+                    (let ((with-unresolved-prompt (shallow-clone state)))
+                      (slot-set! ret 'authorization-prompts
+                                 `((,uri . ,continue) ,@(authorization-prompts state)))
+                      with-unresolved-prompt))))
+           (iter prompts seed state)))))))
+
+(define-class <page> ()
+  (identifier #:init-keyword #:identifier #:getter identifier))
+
+(define-class <new-page> (<page>))
+
+(define-class <page-with-uri> (<page>)
+  (uri #:init-keyword #:uri #:getter uri))
+
+(define-class <loading-page> (<page-with-uri>))
+
+(define-class <error-page> (<page-with-uri>)
+  (code #:init-keyword #:code #:getter code)
+  (reason-phrase #:init-keyword #:reason-phrase #:getter reason-phrase))
+
+(define-class <loaded-page> (<page-with-uri>)
+  (etag #:init-keyword #:etag #:getter etag)
+  (links #:init-keyword #:links #:getter links))
+
+(define-class <rdf-page> (<loaded-page>)
+  (triples #:init-keyword #:triples #:getter triples))
+
+(define-class <non-rdf-page> (<loaded-page>)
+  (content-type #:init-keyword #:content-type #:getter content-type)
+  (content #:init-keyword #:content #:getter content))
+
+(define-method (add-page (state <application-state>) (identifier <string>))
   (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))))
+    (slot-set! ret 'pages
+               `(,(make <new-page> #:identifier identifier)
+                 ,@(pages state)))
+    ret))
+
+(define-method (set-page-uri (state <application-state>) (id <string>) uri)
+  (let ((ret (shallow-clone state)))
+    (slot-set! ret 'pages
+               (let replace-page ((pages (pages state))
+                                  (untouched-pages '()))
+                 (match pages
+                   (()
+                    (reverse untouched-pages))
+                   ((hd tl ...)
+                    (let ((replaced
+                           (if (equal? (identifier hd) id)
+                               (make <loading-page>
+                                           #:identifier id
+                                           #:uri uri)
+                               hd)))
+                      (replace-page
+                       tl
+                       `(,replaced
+                         ,@(untouched-pages))))))))
+    ;; TODO: add a job to load the page…
+    ret))
+
+(define-method (close-page (state <application-state>) (id <string>))
+  (let ((ret (shallow-clone state)))
+    (slot-set! ret 'pages
+               (filter (lambda (page)
+                         (not (equal? (identifier page) id)))
+                       (pages state)))
+    ret))
-- 
cgit v1.2.3