diff options
Diffstat (limited to 'src/scm/webid-oidc/client/gui/authorizations-widget.scm')
| -rw-r--r-- | src/scm/webid-oidc/client/gui/authorizations-widget.scm | 105 |
1 files changed, 14 insertions, 91 deletions
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))) |