diff options
Diffstat (limited to 'src/scm/webid-oidc/client/application.scm')
| -rw-r--r-- | src/scm/webid-oidc/client/application.scm | 245 |
1 files changed, 162 insertions, 83 deletions
diff --git a/src/scm/webid-oidc/client/application.scm b/src/scm/webid-oidc/client/application.scm index 6263a82..5185cfb 100644 --- a/src/scm/webid-oidc/client/application.scm +++ b/src/scm/webid-oidc/client/application.scm @@ -48,18 +48,21 @@ description result-box thread result join + <authorization-prompt> + authorization-uri reason continuation + <application-state> main-account other-accounts client error-messages authorization-prompts running-jobs pages add-account choose-account + remove-account + set-accounts set-client fold-authorization-prompts add-page set-page-uri close-page - - ->sexp ) #:declarative? #t) @@ -70,9 +73,23 @@ (description #:init-keyword #:description #:getter description) (result-box #:init-thunk (lambda () (make-atomic-box #f)) #:getter result-box)) +(define-method (equal? (x <job>) (y <job>)) + (and (equal? (description x) (description y)) + (eq? (result-box x) (result-box y)))) + (define-method (result (job <job>)) (atomic-box-ref (result-box job))) +(define-class <authorization-prompt> () + (authorization-uri #:init-keyword #:authorization-uri #:getter authorization-uri) + (reason #:init-keyword #:reason #:getter reason) + (continuation #:init-keyword #:continuation #:getter continuation)) + +(define-method (equal? (x <authorization-prompt>) (y <authorization-prompt>)) + (and (equal? (authorization-uri x) (authorization-uri y)) + (equal? (reason x) (reason y)) + (eq? (continuation x) (continuation y)))) + (define-class <application-state> () (main-account #:init-keyword #:main-account @@ -95,9 +112,6 @@ #:init-keyword #:error-messages #:getter error-messages #:init-value '()) - ;; 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 @@ -111,34 +125,32 @@ #:getter pages #: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 (equal? (x <application-state>) (y <application-state>)) + (and (equal? (main-account x) (main-account y)) + (equal? (other-accounts x) (other-accounts y)) + (equal? (client x) (client y)) + (equal? (error-messages x) (error-messages y)) + (equal? (authorization-prompts x) (authorization-prompts y)) + (equal? (running-jobs x) (running-jobs y)) + (equal? (pages x) (pages y)))) (define-method (display (state <application-state>) port) - (format port "#<<application-state> main-account=~a client=~a error-messages=~a authorization-prompts=~a running-jobs=~a>" + (format port "#<<application-state> main-account=~a other-accounts=~a client=~a error-messages=~a authorization-prompts=~a running-jobs=~a>" (call-with-output-string (lambda (port) (display (main-account state) port))) (call-with-output-string (lambda (port) + (display (map (lambda (acct) + (uri->string (account:subject acct))) + (other-accounts state)) + port))) + (call-with-output-string + (lambda (port) (display (client state) port))) (error-messages state) - (map (match-lambda (((= uri->string uri) . _) uri)) + (map (lambda (prompt) + (uri->string (authorization-uri prompt))) (authorization-prompts state)) (map description (running-jobs state)))) @@ -151,6 +163,8 @@ (jobs (map result finished))) (match jobs (() state) + ((#f tl ...) + (apply-finished-jobs state tl)) ((hd tl ...) (apply-finished-jobs (hd state) tl))))))) @@ -159,50 +173,65 @@ (call-with-new-thread (lambda () (let ((tag (make-prompt-tag))) - (call-with-prompt tag - (lambda () - (parameterize - ((client:client (client state)) - (account:authorization-process - (lambda* (uri #:key (reason #f)) - (abort-to-prompt - tag - (lambda (continuation) - ;; This is a state updating function. It just - ;; registers the continuation as a new - ;; authorization prompt. - (lambda (previous-state) - ;; 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 . ,continue) - ,@(authorization-prompts previous-state))) - ret))))))) - (cache:use-cache - (lambda () - (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)))))) - (lambda () - (let ((updater (f))) - (atomic-box-set! (result-box job) updater)))))))) - (lambda (continuation get-updater) - (atomic-box-set! (result-box job) (get-updater continuation))))))) + (atomic-box-set! + (result-box job) + ;; The following code returns an updater. The updater takes + ;; a previous state and returns a new state. + ;; + ;; There are 2 possible branches: + ;; + ;; 1. If everything works, the updater is what’s returned by + ;; (f); + ;; + ;; 2. If (f) calls the authorization process, the updater is + ;; a function that adds an authorization prompts to further + ;; continue the call in a new job. In that case, continuing + ;; yields an updater too, because it is delimited by this + ;; prompt. + (call-with-prompt tag + (lambda () + (parameterize + ((client:client (client state)) + (account:authorization-process + (lambda* (uri #:key (reason #f)) + (abort-to-prompt + tag + (lambda (continuation) + ;; This is a state updating function. It just + ;; registers the continuation as a new + ;; authorization prompt. + (lambda (previous-state) + ;; 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 + `(,(make <authorization-prompt> + #:authorization-uri uri + #:reason reason + #:continuation continue) + ,@(authorization-prompts previous-state))) + ret))))))) + (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)))))) + (lambda () + (f))))) + (lambda (continuation get-updater) + (get-updater continuation))))))) (let ((ret (shallow-clone state))) (slot-set! ret 'running-jobs `(,job ,@(running-jobs ret))) ret))) @@ -220,14 +249,14 @@ (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))) + (if (and (equal? (account:subject current-main-account) (account:subject new-account)) + (equal? (account:issuer current-main-account) (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))))) + (uri->string (account:subject new-account)) + (uri->string (account:issuer new-account))))) ret) ;; The main account slot is already taken, add it to the other accounts (let check ((other (other-accounts previous-state))) @@ -239,30 +268,59 @@ `(,new-account ,@(other-accounts previous-state))) ret)) ((existing other ...) - (if (and (equal? (subject existing) (subject new-account)) - (equal? (issuer existing) (issuer new-account))) + (if (and (equal? (account:subject existing) (account:subject new-account)) + (equal? (account:issuer existing) (account: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))))) + (uri->string (account:subject new-account)) + (uri->string (account: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) + ret)))))))) (define-method (choose-account (state <application-state>) (account <account:account>)) (let ((ret (shallow-clone state))) (slot-set! ret 'main-account account) (slot-set! ret 'other-accounts (filter (lambda (other) - (not (equal? other account))))) + (not (equal? other account))) + `(,(main-account state) ,@(other-accounts state)))) ret)) +(define-method (remove-account (state <application-state>) (account <account:account>)) + (let ((ret (shallow-clone state))) + (let ((main (main-account ret)) + (other (other-accounts ret))) + (let* ((all `(,main ,@other)) + (kept (filter (lambda (a) (not (equal? a account))) all))) + (match kept + (() + (slot-set! ret 'main-account #f) + (slot-set! ret 'other-accounts '())) + ((main other ...) + (slot-set! ret 'main-account main) + (slot-set! ret 'other-accounts other))))) + ret)) + +(define-method (set-accounts (state <application-state>) (accounts <list>)) + (let ((ret (shallow-clone state))) + (match accounts + (() + (slot-set! ret 'main-account #f) + (slot-set! ret 'other-accounts '())) + ((main other ...) + (slot-set! ret 'main-account main) + (slot-set! ret 'other-accounts other))) + ret)) + +(define-method (set-accounts (state <application-state>) (main <account:account>) (other <list>)) + (set-accounts state `(,main ,@other))) + (define-method (set-client (state <application-state>) (client <client:client>)) (let ((ret (shallow-clone state))) (slot-set! ret 'client client) @@ -278,46 +336,67 @@ (match prompts (() (values seed state)) - (((uri . continue) prompts ...) - (receive (seed code) (f seed uri) + ((prompt prompts ...) + (receive (seed code) (f seed (authorization-uri prompt)) (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) + ((continuation prompt) state code) (let ((with-unresolved-prompt (shallow-clone state))) (slot-set! ret 'authorization-prompts - `((,uri . ,continue) ,@(authorization-prompts state))) + `(,prompt ,@(authorization-prompts state))) with-unresolved-prompt)))) (iter prompts seed state))))))) (define-class <page> () (identifier #:init-keyword #:identifier #:getter identifier)) +(define-method (equal? (x <page>) (y <page>)) + (and (equal? (identifier x) (identifier y)))) + (define-class <new-page> (<page>)) (define-class <page-with-uri> (<page>) (uri #:init-keyword #:uri #:getter uri)) +(define-method (equal? (x <page-with-uri>) (y <page-with-uri>)) + (and (equal? (uri x) (uri y)))) + (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-method (equal? (x <error-page>) (y <error-page>)) + (and (equal? (code x) (code y)) + (equal? (reason-phrase x) (reason-phrase y)))) + (define-class <loaded-page> (<page-with-uri>) (etag #:init-keyword #:etag #:getter etag) (links #:init-keyword #:links #:getter links)) +(define-method (equal? (x <loaded-page>) (y <loaded-page>)) + (and (equal? (etag x) (etag y)) + (equal? (links x) (links y)))) + (define-class <rdf-page> (<loaded-page>) (triples #:init-keyword #:triples #:getter triples)) +(define-method (equal? (x <rdf-page>) (y <rdf-page>)) + (and (equal? (triples x) (triples y)))) + (define-class <non-rdf-page> (<loaded-page>) (content-type #:init-keyword #:content-type #:getter content-type) (content #:init-keyword #:content #:getter content)) +(define-method (equal? (x <non-rdf-page>) (y <non-rdf-page>)) + (and (equal? (content-type x) (content-type y)) + (equal? (content x) (content y)))) + (define-method (add-page (state <application-state>) (identifier <string>)) (let ((ret (shallow-clone state))) (slot-set! ret 'pages |