From 381a7d0399434aa277aa86a30e742ee215f2576a Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Tue, 5 Oct 2021 11:25:18 +0200 Subject: gui: use the application API --- src/scm/webid-oidc/client/gui/account-widget.scm | 64 +++++----- .../client/gui/accounts-widget-logic.scm | 15 +-- src/scm/webid-oidc/client/gui/accounts-widget.scm | 119 +++++++----------- .../webid-oidc/client/gui/application-hooks.scm | 4 + src/scm/webid-oidc/client/gui/application.scm | 80 +++++++++--- .../webid-oidc/client/gui/authorization-prompt.scm | 60 ++++----- .../client/gui/authorizations-widget.scm | 105 +++------------- src/scm/webid-oidc/client/gui/client-widget.scm | 113 ++++++----------- src/scm/webid-oidc/client/gui/clock.scm | 5 + src/scm/webid-oidc/client/gui/settings.scm | 135 ++++++++++++--------- 10 files changed, 313 insertions(+), 387 deletions(-) (limited to 'src/scm/webid-oidc/client/gui') 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 ) (can-use? )) + (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 - #: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 )) + (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 )) + (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 )) + (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 - #: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 + #: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 )) (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 )) + (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 )) + (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-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-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 - #:jwt-header id-token-header - #:jwt-payload id-token) + (and id-token-header id-token + (goops:make + #: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 + #: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))))) -- cgit v1.2.3