diff options
Diffstat (limited to 'src/scm/webid-oidc/client/gui/settings.scm')
| -rw-r--r-- | src/scm/webid-oidc/client/gui/settings.scm | 135 |
1 files changed, 77 insertions, 58 deletions
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))))) |