diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-14 21:55:05 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-15 12:41:09 +0200 |
commit | a050fc5ee9c795742fc6bd0830dc657721628eb8 (patch) | |
tree | c9084e51ab10a3b5f3bd00aa9ea1d157e8291ae2 | |
parent | 328b4957d05fc9b0f9ff87f2a4932ae0296ab069 (diff) |
Add an application state class to handle multi-threaded actions
-rw-r--r-- | po/POTFILES.in | 1 | ||||
-rw-r--r-- | po/disfluid.pot | 13 | ||||
-rw-r--r-- | po/fr.po | 15 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/Makefile.am | 6 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/application.scm | 343 |
5 files changed, 373 insertions, 5 deletions
diff --git a/po/POTFILES.in b/po/POTFILES.in index e485ef5..ceb991f 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -34,6 +34,7 @@ src/scm/webid-oidc/catalog.scm src/scm/webid-oidc/client-manifest.scm src/scm/webid-oidc/client.scm src/scm/webid-oidc/client/accounts.scm +src/scm/webid-oidc/client/application.scm src/scm/webid-oidc/client/client.scm src/scm/webid-oidc/dpop-proof.scm src/scm/webid-oidc/errors.scm diff --git a/po/disfluid.pot b/po/disfluid.pot index 00ee614..2527da6 100644 --- a/po/disfluid.pot +++ b/po/disfluid.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: disfluid SNAPSHOT\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-09-14 16:04+0200\n" +"POT-Creation-Date: 2021-09-15 12:40+0200\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" "Language-Team: LANGUAGE <LL@li.org>\n" @@ -552,6 +552,17 @@ msgstr "" msgid "The issuer should be a string or URI." msgstr "" +#: src/scm/webid-oidc/client/application.scm:267 +#, scheme-format +msgid "" +"You already have an account for ~a issued by ~a and it is currently selected." +msgstr "" + +#: src/scm/webid-oidc/client/application.scm:286 +#, scheme-format +msgid "You already have an account for ~a issued by ~a." +msgstr "" + #: src/scm/webid-oidc/client/client.scm:87 msgid "" "Client ID and redirect URIs should be URIs, and key pair should be a key " @@ -2,8 +2,8 @@ msgid "" msgstr "" "Project-Id-Version: webid-oidc 0.0.0\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-09-14 16:04+0200\n" -"PO-Revision-Date: 2021-09-14 16:02+0200\n" +"POT-Creation-Date: 2021-09-15 12:40+0200\n" +"PO-Revision-Date: 2021-09-15 12:41+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" "Language: fr\n" @@ -577,6 +577,17 @@ msgstr "Le sujet doit être une chaîne de caractères ou une URI." msgid "The issuer should be a string or URI." msgstr "L’émetteur doit être une chaîne de caractères ou une URI." +#: src/scm/webid-oidc/client/application.scm:267 +#, scheme-format +msgid "" +"You already have an account for ~a issued by ~a and it is currently selected." +msgstr "Vous avez déjà un compte pour ~a émis par ~a et il est actuellement sélectionné." + +#: src/scm/webid-oidc/client/application.scm:286 +#, scheme-format +msgid "You already have an account for ~a issued by ~a." +msgstr "Vous avez déjà un compte pour ~a émis par ~a." + #: src/scm/webid-oidc/client/client.scm:87 msgid "" "Client ID and redirect URIs should be URIs, and key pair should be a key " diff --git a/src/scm/webid-oidc/client/Makefile.am b/src/scm/webid-oidc/client/Makefile.am index 583193e..313efcb 100644 --- a/src/scm/webid-oidc/client/Makefile.am +++ b/src/scm/webid-oidc/client/Makefile.am @@ -16,8 +16,10 @@ dist_clientwebidoidcmod_DATA += \ %reldir%/accounts.scm \ - %reldir%/client.scm + %reldir%/client.scm \ + %reldir%/application.scm clientwebidoidcgo_DATA += \ %reldir%/accounts.go \ - %reldir%/client.go + %reldir%/client.go \ + %reldir%/application.go 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)))) |