diff options
Diffstat (limited to 'src/scm/webid-oidc')
-rw-r--r-- | src/scm/webid-oidc/client/application.scm | 245 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui.scm | 13 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/account-widget.scm | 64 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/accounts-widget-logic.scm | 15 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/accounts-widget.scm | 119 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/application-hooks.scm | 4 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/application.scm | 80 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/authorization-prompt.scm | 60 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/authorizations-widget.scm | 105 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/client-widget.scm | 113 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/clock.scm | 5 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/gui/settings.scm | 135 |
12 files changed, 479 insertions, 479 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 diff --git a/src/scm/webid-oidc/client/gui.scm b/src/scm/webid-oidc/client/gui.scm index 29bf556..3fbd291 100644 --- a/src/scm/webid-oidc/client/gui.scm +++ b/src/scm/webid-oidc/client/gui.scm @@ -37,6 +37,7 @@ #:use-module (webid-oidc client accounts) #:use-module ((webid-oidc client gui settings) #:prefix settings:) #:use-module ((webid-oidc client gui application) #:prefix app:) + #:use-module (webid-oidc client gui application-hooks) #:use-module ((webid-oidc cache) #:prefix cache:) #:use-module ((webid-oidc catalog) #:prefix catalog:) #:use-module (web uri) @@ -58,15 +59,9 @@ (use-typelibs (("Gio" "2.0") #:renamer (protect 'application:new)) ("Gtk" "3.0")) -(add-hook! settings:client-changed-hook - (lambda (client) - (format #t (G_ "The client changed: it is now ~a.\n") client) - ((@ (webid-oidc client) client) client))) - -(add-hook! settings:accounts-changed-hook - (lambda (main other) - (format #t (G_ "The accounts changed: the main account is ~a, and the others are ~a.\n") - main other))) +(add-hook! application-state-changed-hook + (lambda (state) + (format #t (G_ "The application state changed: it is now ~a.\n") state))) (define (main) (parameterize ((p:anonymous-http-request (@ (web client) http-request))) diff --git a/src/scm/webid-oidc/client/gui/account-widget.scm b/src/scm/webid-oidc/client/gui/account-widget.scm index f92e271..4449049 100644 --- a/src/scm/webid-oidc/client/gui/account-widget.scm +++ b/src/scm/webid-oidc/client/gui/account-widget.scm @@ -29,11 +29,14 @@ #:use-module (srfi srfi-26) #:use-module (webid-oidc errors) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc config) #:prefix config:) + #:use-module ((webid-oidc client gui settings) #:prefix settings:) #:use-module (webid-oidc web-i18n) #:use-module (webid-oidc client client) #:use-module (webid-oidc client accounts) #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-id-token) + #:use-module (webid-oidc client application) #:use-module (web uri) #:use-module (web response) #:use-module (rnrs bytevectors) @@ -42,7 +45,7 @@ #:duplicates (merge-generics) #:export ( - make-account-widget + ->widget )) (push-duplicate-handler! 'merge-generics) @@ -53,29 +56,36 @@ ;; The created account does not handle signals. -(define (make-account-widget account) - ;; Return many values: - ;; - the builder - ;; - the whole widget - ;; - the discard button - ;; - the use button - (if account - (let ((builder - (builder:new-from-file - (string-append config:uidir "/account-widget.glade")))) - (let ((whole-widget - (builder:get-object builder "account_widget")) - (webid - (builder:get-object builder "webid")) - (issuer - (builder:get-object builder "issuer")) - (discard-button - (builder:get-object builder "discard_button")) - (use-button - (builder:get-object builder "use_button"))) - (link-button:set-uri webid (uri->string (subject account))) - (link-button:set-uri issuer (uri->string (issuer account))) - (button:set-label webid (uri->string (subject account))) - (button:set-label issuer (uri->string (issuer account))) - (values builder whole-widget discard-button use-button))) - (values #f (label:new (G_ "You don’t have set up an account yet.")) #f #f))) +(define-method (->widget (account <account>) (can-use? <boolean>)) + (let ((builder + (builder:new-from-file + (string-append config:uidir "/account-widget.glade")))) + (let ((whole-widget + (builder:get-object builder "account_widget")) + (webid + (builder:get-object builder "webid")) + (issuer-link + (builder:get-object builder "issuer")) + (discard-button + (builder:get-object builder "discard_button")) + (use-button + (builder:get-object builder "use_button"))) + (link-button:set-uri webid (uri->string (subject account))) + (link-button:set-uri issuer-link (uri->string (issuer account))) + (button:set-label webid (uri->string (subject account))) + (button:set-label issuer-link (uri->string (issuer account))) + (unless can-use? + (widget:set-sensitive use-button #f)) + (connect discard-button clicked + (lambda _ + (widget:set-sensitive use-button #f) + (widget:set-sensitive discard-button #f) + (settings:application-state + (remove-account (settings:application-state) account)))) + (connect use-button clicked + (lambda _ + (widget:set-sensitive use-button #f) + (widget:set-sensitive discard-button #f) + (settings:application-state + (choose-account (settings:application-state) account)))) + (values builder whole-widget)))) diff --git a/src/scm/webid-oidc/client/gui/accounts-widget-logic.scm b/src/scm/webid-oidc/client/gui/accounts-widget-logic.scm index 2ea9024..8121b10 100644 --- a/src/scm/webid-oidc/client/gui/accounts-widget-logic.scm +++ b/src/scm/webid-oidc/client/gui/accounts-widget-logic.scm @@ -33,6 +33,7 @@ #:use-module (webid-oidc offloading) #:use-module (webid-oidc client client) #:use-module (webid-oidc client accounts) + #:use-module (webid-oidc client application) #:use-module (webid-oidc client gui account-widget) #:use-module ((webid-oidc client gui settings) #:prefix settings:) #:use-module ((webid-oidc client gui clock) #:prefix clock:) @@ -59,17 +60,7 @@ ((or (? string? (= string->uri (? uri? uri))) (? string? (= as-host-name (? uri? uri)))) (clear-issuer-entry!) - (use-authorizations-widget - (lambda () - (let ((new-account - (make <account> - #:issuer uri))) - (clock:wait - (lambda () - (let ((old (settings:main-account)) - (other (settings:other-accounts))) - (if old - (settings:other-accounts `(,new-account ,@other)) - (settings:main-account new-account))))))))) + (settings:application-state + (add-account (settings:application-state) uri))) (else (format (current-error-port) (G_ "Stub: please enter an URI or a host name...\n"))))) diff --git a/src/scm/webid-oidc/client/gui/accounts-widget.scm b/src/scm/webid-oidc/client/gui/accounts-widget.scm index b9e5403..be95960 100644 --- a/src/scm/webid-oidc/client/gui/accounts-widget.scm +++ b/src/scm/webid-oidc/client/gui/accounts-widget.scm @@ -38,6 +38,7 @@ #:use-module (webid-oidc client gui application-hooks) #:use-module (webid-oidc client gui authorizations-widget) #:use-module (webid-oidc client gui accounts-widget-logic) + #:use-module (webid-oidc client application) #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-id-token) #:use-module (web uri) @@ -48,7 +49,7 @@ #:duplicates (merge-generics) #:export ( - accounts-widget + ->widget )) (push-duplicate-handler! 'merge-generics) @@ -57,88 +58,50 @@ (use-typelibs ("GdkPixbuf" "2.0") ("Gtk" "3.0")) -(define builder #f) -(define accounts-widget #f) +(define srfi-1:map (@ (srfi srfi-1) map)) -(define current-main-child '()) -(define current-other-children '()) +(define account:->widget + (@ (webid-oidc client gui account-widget) ->widget)) -(define (build-accounts-widget app) - (unless accounts-widget - (set! builder - (builder:new-from-file (string-append config:uidir "/accounts-widget.glade"))) - (set! accounts-widget - (builder:get-object builder "accounts_widget")) - (let ((main-account-box +(define-method (->widget (application <application-state>)) + (let ((builder + (builder:new-from-file (string-append config:uidir "/accounts-widget.glade")))) + (let ((accounts-widget + (builder:get-object builder "accounts_widget")) + (main-account-box (builder:get-object builder "main_account_box")) (other-accounts-box (builder:get-object builder "other_accounts_box")) (identity-provider-entry (builder:get-object builder "identity_provider_entry")) (add-account-button - (builder:get-object builder "add_account_button"))) - (define (set-accounts main other) - (for-each - (match-lambda - ((_ widget) - (container:remove main-account-box widget))) - current-main-child) - (set! current-main-child '()) - (for-each - (match-lambda - ((_ widget) - (container:remove other-accounts-box widget))) - current-other-children) - (set! current-other-children '()) - (receive (main-builder main-widget discard-button use-button) - (make-account-widget main) - (set! current-main-child - `((,main-builder ,main-widget))) - (when discard-button - ((@ (gi) connect) discard-button clicked - (lambda _ - (match other - ((new-main new-other ...) - (settings:main-account new-main) - (settings:other-accounts new-other)) - (() - (settings:main-account #f)))))) - (when use-button - (widget:set-sensitive use-button #f)) - (box:pack-end main-account-box main-widget #t #t 0)) - (for-each - (lambda (other-account) - (let ((not-represented (filter (lambda (a) (not (eq? a other-account))) - other))) - ;; We’re packing a widget for other-account, and if the - ;; discard button is clicked, replace the list of other - ;; accounts with not-represented. - (receive (builder widget discard-button use-button) - (make-account-widget other-account) - (set! current-other-children - `((,builder ,widget) ,@current-other-children)) - ((@ (gi) connect) discard-button clicked - (lambda _ - (settings:other-accounts not-represented))) - ((@ (gi) connect) use-button clicked - (lambda _ - (settings:main-account other-account) - (settings:other-accounts `(,main ,@not-represented)))) - (box:pack-end main-account-box widget #t #t 0)))) - other) - ((@ (gi) connect) add-account-button clicked - (lambda _ - ((@ (webid-oidc client gui accounts-widget-logic) add-account-button-clicked) - (entry:get-text identity-provider-entry) - (lambda () - (entry:set-text identity-provider-entry ""))))) - ((@ (gi) connect) identity-provider-entry activate - (lambda _ - ((@ (webid-oidc client gui accounts-widget-logic) add-account-button-clicked) - (entry:get-text identity-provider-entry) - (lambda () - (entry:set-text identity-provider-entry "")))))) - (set-accounts (settings:main-account) (settings:other-accounts)) - (add-hook! settings:accounts-changed-hook set-accounts)))) - -(add-hook! application-activated-hook build-accounts-widget) + (builder:get-object builder "add_account_button")) + (builders (list builder))) + (let ((main-widget + (let ((acct (main-account application))) + (if acct + (receive (additional-builder widget) + (account:->widget acct #f) + (set! builders `(,additional-builder ,@builders)) + widget) + (label:new (G_ "Please add an account."))))) + (other-widgets + (srfi-1:map + (lambda (account) + (receive (additional-builder widget) + (account:->widget account #t) + (set! builders `(,additional-builder ,@builders)) + widget)) + (other-accounts application)))) + (define (add-account-activated . _) + (add-account-button-clicked + (entry:get-text identity-provider-entry) + (lambda () + (widget:set-sensitive identity-provider-entry #f) + (widget:set-sensitive add-account-button #f)))) + (box:pack-end main-account-box main-widget #t #t 0) + (for-each (cute box:pack-end other-accounts-box <> #t #t 0) + other-widgets) + (connect identity-provider-entry activate add-account-activated) + (connect add-account-button clicked add-account-activated) + (values builder accounts-widget))))) diff --git a/src/scm/webid-oidc/client/gui/application-hooks.scm b/src/scm/webid-oidc/client/gui/application-hooks.scm index 0d51599..5aca298 100644 --- a/src/scm/webid-oidc/client/gui/application-hooks.scm +++ b/src/scm/webid-oidc/client/gui/application-hooks.scm @@ -40,7 +40,11 @@ #:export ( application-activated-hook + application-state-changed-hook )) (define application-activated-hook (make-hook 1)) + +(define application-state-changed-hook + (make-hook 1)) diff --git a/src/scm/webid-oidc/client/gui/application.scm b/src/scm/webid-oidc/client/gui/application.scm index bfd5f7a..c2ee97d 100644 --- a/src/scm/webid-oidc/client/gui/application.scm +++ b/src/scm/webid-oidc/client/gui/application.scm @@ -21,7 +21,6 @@ #: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 pretty-print) #:use-module (srfi srfi-9) @@ -40,11 +39,13 @@ #:use-module ((webid-oidc client gui accounts-widget) #:prefix accounts:) #:use-module ((webid-oidc client gui authorizations-widget) #:prefix authorizations:) #:use-module (webid-oidc client gui application-hooks) + #:use-module (webid-oidc client application) #:use-module (web uri) #:use-module (web response) #:use-module (rnrs bytevectors) #:use-module (oop goops) #:declarative? #t + #:duplicates (merge-generics) #:export ( application @@ -56,25 +57,72 @@ (use-typelibs ("GdkPixbuf" "2.0")) (use-typelibs (("Gio" "2.0") #:renamer (protect 'application:new)) - ("Gtk" "3.0")) + ("Gtk" "3.0") + ("GLib" "2.0")) + +(define gi:connect + (@ (gi) connect)) + +(define goops:make + (@ (oop goops) make)) + +(define gi:make + (@ (gi) make)) (define application (application:new "eu.planete_kraus.Disfluid" (list->application-flags '(flags-none)))) +(define app:client + (@ (webid-oidc client application) client)) + +(define-method (->widget (application <application-state>)) + (let ((content (box:new (symbol->orientation 'horizontal) 12))) + (call-with-values + (lambda () + (client:->widget (app:client application))) + (lambda (client-builder client) + (call-with-values + (lambda () + (accounts:->widget application)) + (lambda (accounts-builder accounts) + (call-with-values + (lambda () + (authorizations:->widget application)) + (lambda (authorizations-builder authorizations) + (box:pack-start content client #t #t 0) + (box:pack-start content accounts #t #t 0) + (box:pack-start content authorizations #t #t 0) + (values + `(,client-builder ,accounts-builder ,authorizations-builder) + content))))))))) + +(define main-window #f) + +(define current-state #f) +(define current-state-widget #f) +(define additional-gc-roots '()) + +(define-method (set-state! (state <application-state>)) + (when (and main-window current-state-widget) + (remove main-window current-state-widget)) + (set! current-state state) + (call-with-values + (lambda () + (->widget state)) + (lambda (roots widget) + (set! current-state-widget widget) + (set! additional-gc-roots roots))) + (when main-window + (add main-window current-state-widget) + (show-all main-window))) + (define (on-activate application) - (run-hook application-activated-hook application) - (let ((window (make <GtkApplicationWindow> - #:application application)) - (client client:client-widget) - (accounts accounts:accounts-widget) - (authorizations authorizations:authorizations-widget) - (content (box:new (symbol->orientation 'horizontal) 12))) - (box:pack-end content client #t #t 0) - (box:pack-end content accounts #t #t 0) - (box:pack-end content authorizations #t #t 0) - (add window content) - (show-all window))) - -(connect application activate on-activate) + (set! main-window + (gi:make <GtkApplicationWindow> + #:application application)) + (add-hook! application-state-changed-hook set-state! #t) + (run-hook application-activated-hook application)) + +(gi:connect application activate on-activate) diff --git a/src/scm/webid-oidc/client/gui/authorization-prompt.scm b/src/scm/webid-oidc/client/gui/authorization-prompt.scm index 8e9ab81..cd32489 100644 --- a/src/scm/webid-oidc/client/gui/authorization-prompt.scm +++ b/src/scm/webid-oidc/client/gui/authorization-prompt.scm @@ -33,6 +33,8 @@ #:use-module ((webid-oidc config) #:prefix config:) #:use-module (webid-oidc client client) #:use-module (webid-oidc client accounts) + #:use-module (webid-oidc client application) + #:use-module ((webid-oidc client gui settings) #:prefix settings:) #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-id-token) #:use-module (web uri) @@ -43,7 +45,7 @@ #:duplicates (merge-generics) #:export ( - make-authorization-prompt + ->widget )) (push-duplicate-handler! 'merge-generics) @@ -52,11 +54,10 @@ (use-typelibs ("GdkPixbuf" "2.0") ("Gtk" "3.0")) -(define (make-authorization-prompt uri) - ;; Return 3 values: - ;; - the builder - ;; - the whole widget - ;; - a 2-value function (reason, continuation) to add a handler +(define format:format + (@ (ice-9 format) format)) + +(define-method (->widget (prompt <authorization-prompt>)) (let ((builder (builder:new-from-file (string-append config:uidir "/authorization-prompt.glade")))) @@ -69,26 +70,27 @@ (entry (builder:get-object builder "authorization_code_entry")) (ok - (builder:get-object builder "ok_button")) - (reasons '()) - (handlers '())) - (let ((handle (lambda (reason continuation) - (label:set-text reason-label - ((@ (ice-9 format) format) #f - (G_ "Your authorization is required: ~a") - (if (null? reasons) - reason - (format #f (G_ "~a, and ~a") - (string-join (reverse reasons) ", ") - reason)))) - (set! reasons `(,reason ,@reasons)) - (set! handlers `(,continuation ,@handlers))))) - (link-button:set-uri link-button (uri->string uri)) - ((@ (gi) connect) entry activate - (lambda _ - (button:clicked ok))) - ((@ (gi) connect) ok clicked - (lambda _ - (let ((code (entry:get-text entry))) - ((@ (srfi srfi-1) for-each) (cute <> code) (reverse handlers))))) - (values builder whole-widget handle))))) + (builder:get-object builder "ok_button"))) + (label:set-text reason-label + (format:format #f (G_ "Your authorization is required: ~a") + (reason prompt))) + (link-button:set-uri link-button (uri->string (authorization-uri prompt))) + ((@ (gi) connect) entry activate + (lambda _ + (button:clicked ok))) + ((@ (gi) connect) ok clicked + (lambda _ + (let ((code (entry:get-text entry))) + (widget:set-sensitive entry #f) + (widget:set-sensitive ok #f) + (receive (_ new-state) + (fold-authorization-prompts + (settings:application-state) + (match-lambda* + ((_ p) + (values #t + (and (equal? p (authorization-uri prompt)) + code)))) + #t) + (settings:application-state new-state))))) + (values builder whole-widget)))) diff --git a/src/scm/webid-oidc/client/gui/authorizations-widget.scm b/src/scm/webid-oidc/client/gui/authorizations-widget.scm index ba76185..cfe5a7f 100644 --- a/src/scm/webid-oidc/client/gui/authorizations-widget.scm +++ b/src/scm/webid-oidc/client/gui/authorizations-widget.scm @@ -38,6 +38,7 @@ #:use-module ((webid-oidc client gui settings) #:prefix settings:) #:use-module ((webid-oidc client gui clock) #:prefix clock:) #:use-module (webid-oidc client gui application-hooks) + #:use-module (webid-oidc client application) #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-id-token) #:use-module (web uri) @@ -48,8 +49,7 @@ #:duplicates (merge-generics) #:export ( - authorizations-widget - use-authorizations-widget + ->widget )) (push-duplicate-handler! 'merge-generics) @@ -58,93 +58,16 @@ (use-typelibs ("GdkPixbuf" "2.0") ("Gtk" "3.0")) -(define authorizations-widget #f) -(define by-uri (make-hash-table)) +(define prompt:->widget + (@ (webid-oidc client gui authorization-prompt) ->widget)) -(define authorizations-widget #f) - -;; Since authorizations may be requested by any threads, they are -;; collected here and a timer updates the GUI every so often. -(define pending-authorizations - (make-atomic-box '())) - -(define (update-ui) - (let ((authz (atomic-box-ref pending-authorizations))) - (let ((confirmed (atomic-box-compare-and-swap! pending-authorizations authz '()))) - (if (eq? authz confirmed) - (let add-authorization ((authz authz)) - (match authz - (() ;; done - #t) - (((reason uri continuation) authz ...) - (let ((value (uri->string uri))) - (match (or (hash-ref by-uri value) - (receive (builder widget handle) - ((@ (webid-oidc client gui authorization-prompt) - make-authorization-prompt) uri) - (let ((ret `(,builder ,widget ,handle))) - (hash-set! by-uri value ret) - (box:pack-start authorizations-widget widget #t #t 0) - ret))) - ((_ widget handle) - ;; Put it on top - (container:remove authorizations-widget widget) - (box:pack-start authorizations-widget widget #t #t 0) - ;; Add (reason, continuation) to the - ;; existing or created widget - (handle reason - (lambda (code) - ;; When the button is - ;; clicked, first remove - ;; the widget if it still - ;; exists - (when (hash-ref by-uri value) - (hash-remove! by-uri value) - (container:remove authorizations-widget widget)) - ((@ (ice-9 threads) call-with-new-thread) - (lambda () - ;; In case the - ;; continuation expects - ;; further authorizations: - (use-authorizations-widget - (lambda () - (continuation code))))))))))))) - ;; Else, retry - (update-ui))))) - -(define (use-authorizations-widget f) - (let ((prompt (make-prompt-tag))) - (call-with-prompt prompt - (lambda () - (parameterize - ((authorization-process - (lambda* (uri #:key reason) - (abort-to-prompt - prompt - (lambda (continuation) - (let save ((other (atomic-box-ref pending-authorizations))) - (let ((confirmed - (atomic-box-compare-and-swap! - pending-authorizations - other - `((,reason ,uri ,continuation) ,@other)))) - (unless (eq? confirmed other) - (save (atomic-box-ref pending-authorizations)))))))))) - (f))) - (lambda (continuation handler) - (handler continuation))))) - -(define (update-ui-next) - (update-ui) - (clock:wait - (lambda () - (update-ui-next)))) - -(define (build-widget app) - (unless authorizations-widget - (set! authorizations-widget (box:new (symbol->orientation 'vertical) 8)) - (clock:wait - (lambda () - (update-ui-next))))) - -(add-hook! application-activated-hook build-widget) +(define-method (->widget (application <application-state>)) + (let ((builders '()) + (box (box:new (symbol->orientation 'vertical) 8))) + (for-each + (lambda (prompt) + (receive (builder widget) (prompt:->widget prompt) + (set! builders `(,builder ,@builders)) + (box:pack-start box widget #t #t 0))) + (authorization-prompts application)) + (values builders box))) diff --git a/src/scm/webid-oidc/client/gui/client-widget.scm b/src/scm/webid-oidc/client/gui/client-widget.scm index 792b8f8..b4b58aa 100644 --- a/src/scm/webid-oidc/client/gui/client-widget.scm +++ b/src/scm/webid-oidc/client/gui/client-widget.scm @@ -37,6 +37,7 @@ #:use-module ((webid-oidc config) #:prefix config:) #:use-module (webid-oidc client) #:use-module (webid-oidc client accounts) + #:use-module (webid-oidc client application) #:use-module ((webid-oidc client gui settings) #:prefix settings:) #:use-module (webid-oidc client gui application-hooks) #:use-module (web uri) @@ -46,7 +47,7 @@ #:duplicates (merge-generics) #:export ( - client-widget + ->widget )) (push-duplicate-handler! 'merge-generics) @@ -55,16 +56,12 @@ (use-typelibs ("GdkPixbuf" "2.0") ("Gtk" "3.0")) -(define builder #f) -(define client-widget #f) - -(define (build-client-widget app) - (unless client-widget - (set! builder - (builder:new-from-file (string-append config:uidir "/client-widget.glade"))) - (set! client-widget - (builder:get-object builder "client_widget")) - (let ((client-id-entry +(define-method (->widget (client <client>)) + (let ((builder + (builder:new-from-file (string-append config:uidir "/client-widget.glade")))) + (let ((whole-widget + (builder:get-object builder "client_widget")) + (client-id-entry (builder:get-object builder "client_id_entry")) (redirect-uri-entry (builder:get-object builder "redirect_uri_entry")) @@ -76,72 +73,36 @@ (builder:get-object builder "undo_button")) (update-button (builder:get-object builder "update_button"))) - (define (current-edition) - ;; Return the client based on the edited fields - (let/ec return - (with-exception-handler - (lambda (exn) - ((@ (ice-9 format) format) - (current-error-port) - (G_ "The client cannot be constructed: ~a\n") - (if (exception-with-message? exn) - (exception-message exn) - exn)) - (return #f)) - (lambda () - ((@ (oop goops) make) <client> - #:client-id (entry:get-text client-id-entry) - #:redirect-uri (entry:get-text redirect-uri-entry) - #:key-pair - (jwk:jwk->key (stubs:json-string->scm (entry:get-text key-pair-entry)))))))) - (define (on-entry-changed . _) - (let ((current-client (settings:client)) - (edited (current-edition))) - (receive (can-undo? can-update?) - (cond - ((and edited (equal? edited current-client)) - ;; The undo button is disabled and the update button too - (values #f #f)) - (edited - ;; We have changed something and it’s valid - (values #t #t)) - (else - ;; We have changed something, but it’s invalid - (values #t #f))) - (widget:set-sensitive undo-button can-undo?) - (widget:set-sensitive update-button can-update?)))) - (define (set-client client) + (define (undo) (entry:set-text client-id-entry (uri->string (client-id client))) (entry:set-text redirect-uri-entry (uri->string (redirect-uri client))) (entry:set-text key-pair-entry (stubs:scm->json-string - (jwk:key->jwk (key-pair client)))) - (on-entry-changed)) - ((@ (gi) connect) client-id-entry activate on-entry-changed) - ((@ (gi) connect) redirect-uri-entry activate on-entry-changed) - ((@ (gi) connect) key-pair-entry activate on-entry-changed) - ((@ (gi) connect) - generate-key-pair-button clicked - (lambda _ - (entry:set-text key-pair-entry - (stubs:scm->json-string - (jwk:key->jwk - (jwk:generate-key #:n-size 2048)))) - (on-entry-changed))) - ((@ (gi) connect) undo-button clicked - (lambda _ - (set-client (settings:client)) - (on-entry-changed))) - ((@ (gi) connect) update-button clicked - (lambda _ - (settings:client (current-edition)) - (widget:set-sensitive undo-button #f) - (widget:set-sensitive update-button #f))) - (set-client (settings:client)) - (add-hook! settings:client-changed-hook - (lambda (c) - (unless (widget:get-sensitive? undo-button) - ;; If we were doing an edition, ignore - (set-client c))))))) - -(add-hook! application-activated-hook build-client-widget) + (jwk:key->jwk (key-pair client))))) + (define (disable) + (widget:set-sensitive client-id-entry #f) + (widget:set-sensitive redirect-uri-entry #f) + (widget:set-sensitive key-pair-entry #f) + (widget:set-sensitive generate-key-pair-button #f) + (widget:set-sensitive undo-button #f) + (widget:set-sensitive update-button #f)) + (undo) + (connect generate-key-pair-button clicked + (lambda _ + (entry:set-text key-pair-entry + (stubs:scm->json-string + (jwk:key->jwk (jwk:generate-key #:n-size 2048)))))) + (connect undo-button clicked (lambda _ (undo))) + (connect update-button clicked + (lambda _ + (disable) + (let ((new-client (make <client> + #:client-id (entry:get-text client-id-entry) + #:redirect-uri (entry:get-text redirect-uri-entry) + #:key-pair + (jwk:jwk->key + (stubs:json-string->scm + (entry:get-text key-pair-entry)))))) + (settings:application-state + (set-client (settings:application-state) new-client))))) + (values builder whole-widget)))) diff --git a/src/scm/webid-oidc/client/gui/clock.scm b/src/scm/webid-oidc/client/gui/clock.scm index efb7ce8..87d6b48 100644 --- a/src/scm/webid-oidc/client/gui/clock.scm +++ b/src/scm/webid-oidc/client/gui/clock.scm @@ -20,7 +20,10 @@ #:use-module (gi util) #:use-module (ice-9 atomic) #:use-module (webid-oidc client gui application-hooks) + #:use-module (webid-oidc client application) + #:use-module ((webid-oidc client gui settings) #:prefix settings:) #:declarative? #t + #:duplicates (merge-generics) #:export (wait)) (use-typelibs ("GLib" "2.0")) @@ -37,6 +40,8 @@ (if (eq? old (atomic-box-compare-and-swap! pending-ops old '())) (begin (for-each (lambda (f) (f)) (reverse old)) + (settings:application-state + (join (settings:application-state))) #t) (run)))) diff --git a/src/scm/webid-oidc/client/gui/settings.scm b/src/scm/webid-oidc/client/gui/settings.scm index 8f97b2e..60e0b3f 100644 --- a/src/scm/webid-oidc/client/gui/settings.scm +++ b/src/scm/webid-oidc/client/gui/settings.scm @@ -33,6 +33,7 @@ #:use-module (webid-oidc client client) #:use-module (webid-oidc client accounts) #:use-module (webid-oidc client gui application-hooks) + #:use-module (webid-oidc client application) #:use-module (webid-oidc jwk) #:use-module (webid-oidc oidc-id-token) #:use-module (web uri) @@ -43,12 +44,7 @@ #:duplicates (merge-generics) #:export ( - client - main-account - other-accounts - - client-changed-hook - accounts-changed-hook + application-state )) (push-duplicate-handler! 'merge-generics) @@ -58,6 +54,9 @@ (define goops:make (@ (oop goops) make)) +(define app:client + (@ (webid-oidc client application) client)) + (define root-settings (settings:new "eu.planete_kraus.Disfluid")) @@ -110,11 +109,6 @@ (uri->string (redirect-uri client))) (settings:apply client-settings)))) -(define client - (match-lambda* - (() (get-client)) - ((value) (set-client! value)))) - (unless (equal? (get-client) (get-client)) ;; The key is generated each time, fix it (set-client! (get-client))) @@ -125,13 +119,13 @@ (str str))) (define (read-account settings) - (let ((subject (empty-is-false (settings:get-string main-account-settings "subject"))) - (issuer (empty-is-false (settings:get-string main-account-settings "issuer"))) - (key-pair (empty-is-false (settings:get-string main-account-settings "key-pair"))) - (id-token-header (empty-is-false (settings:get-string main-account-settings "id-token-header"))) - (id-token (empty-is-false (settings:get-string main-account-settings "id-token"))) - (access-token (empty-is-false (settings:get-string main-account-settings "access-token"))) - (refresh-token (empty-is-false (settings:get-string main-account-settings "refresh-token")))) + (let ((subject (empty-is-false (settings:get-string settings "subject"))) + (issuer (empty-is-false (settings:get-string settings "issuer"))) + (key-pair (empty-is-false (settings:get-string settings "key-pair"))) + (id-token-header (empty-is-false (settings:get-string settings "id-token-header"))) + (id-token (empty-is-false (settings:get-string settings "id-token"))) + (access-token (empty-is-false (settings:get-string settings "access-token"))) + (refresh-token (empty-is-false (settings:get-string settings "refresh-token")))) (and subject issuer key-pair (let ((subject (string->uri subject)) (issuer (string->uri issuer)) @@ -145,9 +139,10 @@ #:issuer issuer #:key-pair key-pair #:id-token - (goops:make <id-token> - #:jwt-header id-token-header - #:jwt-payload id-token) + (and id-token-header id-token + (goops:make <id-token> + #:jwt-header id-token-header + #:jwt-payload id-token)) #:access-token access-token #:refresh-token refresh-token))))) @@ -166,18 +161,24 @@ (settings:set-string? settings "subject" (uri->string (subject account))) (settings:set-string? settings "issuer" (uri->string (issuer account))) (settings:set-string? settings "key-pair" - (stubs:scm->json-string (key->jwk (key-pair account)))) - (when (id-token account) - (receive (id-token-header id-token) - (token->jwt (id-token account)) + (stubs:scm->json-string (key->jwk (key-pair account)))) + (call-with-values + (lambda () + (let ((id (id-token account))) + (if id + (token->jwt id) + (values #f #f)))) + (lambda (id-token-header id-token) (settings:set-string? settings "id-token-header" - (stubs:scm->json-string id-token-header)) + (if id-token-header + (stubs:scm->json-string id-token-header) + "")) (settings:set-string? settings "id-token" - (stubs:scm->json-string id-token)))) - (when (access-token account) - (settings:set-string? settings "access-token" (access-token account))) - (when (refresh-token account) - (settings:set-string? settings "refresh-token" (refresh-token account))))) + (if id-token + (stubs:scm->json-string id-token) + "")))) + (settings:set-string? settings "access-token" (or (access-token account) "")) + (settings:set-string? settings "refresh-token" (or (refresh-token account) "")))) (define (get-main-account) (read-account main-account-settings)) @@ -185,11 +186,6 @@ (define (set-main-account! account) (save-account main-account-settings account)) -(define main-account - (match-lambda* - (() (get-main-account)) - ((value) (set-main-account! value)))) - (define (get-other-accounts) (filter (lambda (x) x) (map read-account other-accounts-settings))) @@ -200,35 +196,44 @@ (settings other-accounts-settings)) (match `(,accounts . ,settings) ((() . ()) #t) - ((() . (hd tl ...)) - (do-save (list #f) tl)) + ((() . settings) + (do-save (list #f) settings)) ((_ . ()) (fail (G_ "can only store 10 accounts"))) (((account accounts ...) . (setting settings ...)) (save-account setting account) - (do-save accounts tl)))))) - -(define other-accounts - (match-lambda* - (() (get-other-accounts)) - ((value) (set-other-accounts! value)))) + (do-save accounts settings)))))) -(define client-changed-hook - (make-hook 1)) +(define last-application-state #f) -(define accounts-changed-hook - (make-hook 2)) +(define hook-enabled? + (make-parameter #t)) (connect client-settings change-event (lambda _ - (run-hook client-changed-hook (client)) - #f)) + (let ((the-client (get-client))) + (when (and last-application-state + (not (equal? the-client (client last-application-state)))) + (set! last-application-state + (set-client last-application-state client)) + (when (hook-enabled?) + (run-hook application-state-changed-hook last-application-state))) + #f))) (define (run-accounts-changed-hook . _) - (run-hook accounts-changed-hook - (main-account) - (other-accounts)) - #f) + (let ((main (get-main-account)) + (other (get-other-accounts))) + (when (and last-application-state + (or (not (equal? main (main-account last-application-state))) + (not (equal? other (other-accounts last-application-state))))) + (set! last-application-state + (set-accounts last-application-state + (if main + `(,main ,@other) + other))) + (when (hook-enabled?) + (run-hook application-state-changed-hook last-application-state))) + #f)) (connect main-account-settings change-event run-accounts-changed-hook) (for-each @@ -238,8 +243,22 @@ (add-hook! application-activated-hook (lambda (app) - (run-hook client-changed-hook (client)) - (run-hook accounts-changed-hook - (main-account) - (other-accounts))) + (set! last-application-state + (goops:make <application-state> + #:main-account (get-main-account) + #:other-accounts (get-other-accounts) + #:client (get-client))) + (run-hook application-state-changed-hook last-application-state)) #t) + +(define application-state + (match-lambda* + (() last-application-state) + ((new-state) + (unless (equal? new-state last-application-state) + (parameterize ((hook-enabled? #f)) + (set-client! (app:client new-state)) + (set-main-account! (main-account new-state)) + (set-other-accounts! (other-accounts new-state))) + (set! last-application-state new-state) + (run-hook application-state-changed-hook last-application-state))))) |