diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-06 18:06:12 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-12 22:27:38 +0200 |
commit | 3ba93ce1fccbc54d4695d55011ce856018c1b2cd (patch) | |
tree | b3668d95661643c55a2d6bf663ab58b5e3889a18 /src/scm/webid-oidc/client/application.scm | |
parent | f53954f07104237497e9c121bffe0a3814116691 (diff) |
gui: add a primitive browser widget
Diffstat (limited to 'src/scm/webid-oidc/client/application.scm')
-rw-r--r-- | src/scm/webid-oidc/client/application.scm | 313 |
1 files changed, 261 insertions, 52 deletions
diff --git a/src/scm/webid-oidc/client/application.scm b/src/scm/webid-oidc/client/application.scm index 5185cfb..58d1dad 100644 --- a/src/scm/webid-oidc/client/application.scm +++ b/src/scm/webid-oidc/client/application.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (webid-oidc errors) + #:use-module (webid-oidc http-link) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc oidc-id-token) #:prefix id:) @@ -52,7 +53,15 @@ authorization-uri reason continuation <application-state> - main-account other-accounts client error-messages authorization-prompts running-jobs pages + main-account other-accounts client error-messages authorization-prompts running-jobs page + + <page> + <new-page> + <page-with-uri> uri + <loading-page> + <error-page> code reason-phrase + <loaded-page> etag links content-type content + <updated-page> desired-links desired-content-type desired-content add-account choose-account @@ -60,9 +69,15 @@ set-accounts set-client fold-authorization-prompts - add-page set-page-uri - close-page + edit-page + remove-link + add-link + change-content-type + change-content + discard-updates + commit-updates + delete-page ) #:declarative? #t) @@ -120,10 +135,12 @@ #:init-keywords #:running-jobs #:getter running-jobs #:init-value '()) - (pages - #:init-keyword #:pages - #:getter pages - #:init-value '())) + (page + #:init-keyword #:page + #:getter page + #:init-thunk + (lambda () + (make <new-page>)))) (define-method (equal? (x <application-state>) (y <application-state>)) (and (equal? (main-account x) (main-account y)) @@ -132,7 +149,7 @@ (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)))) + (equal? (page x) (page y)))) (define-method (display (state <application-state>) port) (format port "#<<application-state> main-account=~a other-accounts=~a client=~a error-messages=~a authorization-prompts=~a running-jobs=~a>" @@ -351,8 +368,7 @@ with-unresolved-prompt)))) (iter prompts seed state))))))) -(define-class <page> () - (identifier #:init-keyword #:identifier #:getter identifier)) +(define-class <page> ()) (define-method (equal? (x <page>) (y <page>)) (and (equal? (identifier x) (identifier y)))) @@ -372,64 +388,257 @@ (reason-phrase #:init-keyword #:reason-phrase #:getter reason-phrase)) (define-method (equal? (x <error-page>) (y <error-page>)) - (and (equal? (code x) (code y)) + (and (equal? (uri x) (uri y)) + (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)) + (links #:init-keyword #:links #:getter links) + (content-type #:init-keyword #:content-type #:getter content-type) + (content #:init-keyword #:content #:getter content)) (define-method (equal? (x <loaded-page>) (y <loaded-page>)) - (and (equal? (etag x) (etag y)) - (equal? (links x) (links y)))) + (and (equal? (uri x) (uri y)) + (equal? (etag x) (etag y)) + (equal? (links x) (links y)) + (equal? (content-type x) (content-type y)) + (equal? (content x) (content y)))) -(define-class <rdf-page> (<loaded-page>) - (triples #:init-keyword #:triples #:getter triples)) +(define-class <updated-page> (<loaded-page>) + (desired-links #:init-keyword #:desired-links #:getter desired-links) + (desired-content-type #:init-keyword #:desired-content-type #:getter desired-content-type) + (desired-content #:init-keyword #:desired-content #:getter desired-content)) + +(define-method (equal? (x <updated-page>) (y <updated-page>)) + (and (equal? (uri x) (uri y)) + (equal? (etag x) (etag y)) + (equal? (links x) (links y)) + (equal? (content-type x) (content-type y)) + (equal? (content x) (content y)) + (equal? (desired-links x) (desired-links y)) + (equal? (desired-content-type x) (desired-content-type y)) + (equal? (desired-content x) (desired-content y)))) + +(define-method (edit-page (page <page>)) + page) + +(define-method (edit-page (page <loaded-page>)) + (make <updated-page> + #:uri (uri page) + #:etag (etag page) + #:links (links page) + #:content-type (content-type page) + #:content (content page) + #:desired-links (links page) + #:desired-content-type (content-type page) + #:desired-content (content page))) + +(define-method (edit-page (page <updated-page>)) + page) + +(define-method (edit-page (state <application-state>)) + (let ((ret (shallow-clone state))) + (slot-set! ret 'page (edit-page (page ret))) + ret)) -(define-method (equal? (x <rdf-page>) (y <rdf-page>)) - (and (equal? (triples x) (triples y)))) +(define-method (remove-link (page <page>) target key value) + (let ((ret (edit-page page))) + (when (is-a? ret <updated-page>) + (let ((filtered + (map (match-lambda + (((? (cute equal? <> target)) attributes ...) + `(,target + ,(filter + (match-lambda + ((the-key . the-value) + (and (equal? the-key key) + (equal? the-value value)))) + attributes))) + (other other)) + (links ret)))) + (slot-set! ret 'desired-links + (filter (match-lambda + (((? uri?) ()) + #f) + (else #t)) + filtered)))) + ret)) -(define-class <non-rdf-page> (<loaded-page>) - (content-type #:init-keyword #:content-type #:getter content-type) - (content #:init-keyword #:content #:getter content)) +(define-method (remove-link (state <application-state>) target key value) + (let ((ret (shallow-clone state))) + (slot-set! ret 'page (remove-link (page ret) target key value)) + ret)) -(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-link (page <page>) target key value) + (let ((ret (edit-page page))) + (when (is-a? ret <updated-page>) + (slot-set! ret 'desired-links + `((,target (,key . ,value)) + ,@(desired-links page)))) + ret)) + +(define-method (add-link (state <application-state>) target key value) + (let ((ret (shallow-clone state))) + (slot-set! ret 'page (add-link (page ret) (string->uri target) key value)) + ret)) -(define-method (add-page (state <application-state>) (identifier <string>)) +(define-method (set-page-uri (state <application-state>) uri) + (let ((ret (shallow-clone state)) + (new-page (make <loading-page> + #:uri uri))) + (slot-set! ret 'page new-page) + (add-job + ret + (format #f (G_ "Loading ~a...") (uri->string uri)) + (lambda () + (declare-link-header!) + (let ((account (main-account state)) + (client (client state))) + (parameterize ((client:client client)) + (receive (updated-account response response-body) + (client:request account (uri new-page)) + (lambda (previous-state) + (let ((ret (shallow-clone previous-state))) + ;; If the main client hasn’t changed, update it + (when (equal? (main-account previous-state) account) + (slot-set! ret 'main-account updated-account)) + ;; If the page hasn’t changed, update it + (when (equal? (page previous-state) + new-page) + (slot-set! ret 'page + (if (eqv? (response-code response) 200) + (make <loaded-page> + #:uri uri + #:etag + (match (response-etag response) + ((value . #f) value) + (else #f)) + #:links + (response-links response) + #:content-type + (response-content-type response) + #:content + (or (false-if-exception (bytevector->string response-body)) + response-body)) + (make <error-page> + #:uri uri + #:code (response-code response) + #:reason-phrase (response-reason-phrase response))))) + ret))))))))) + +(define-method (change-content-type (state <application-state>) content-type) (let ((ret (shallow-clone state))) - (slot-set! ret 'pages - `(,(make <new-page> #:identifier identifier) - ,@(pages state))) + (slot-set! + ret 'page + (let ((p (edit-page (page ret)))) + (slot-set! p 'desired-content-type content-type) + p)) ret)) -(define-method (set-page-uri (state <application-state>) (id <string>) uri) +(define-method (change-content (state <application-state>) content) (let ((ret (shallow-clone state))) - (slot-set! ret 'pages - (let replace-page ((pages (pages state)) - (untouched-pages '())) - (match pages - (() - (reverse untouched-pages)) - ((hd tl ...) - (let ((replaced - (if (equal? (identifier hd) id) - (make <loading-page> - #:identifier id - #:uri uri) - hd))) - (replace-page - tl - `(,replaced - ,@(untouched-pages)))))))) - ;; TODO: add a job to load the page… + (slot-set! + ret 'page + (let ((p (edit-page (page ret)))) + (slot-set! p 'desired-content content) + p)) ret)) -(define-method (close-page (state <application-state>) (id <string>)) +(define-method (discard-updates (page <page>)) + page) + +(define-method (discard-updates (page <updated-page>)) + (make <loaded-page> + #:uri (uri page) + #:etag (etag page) + #:links (links page) + #:content-type (content-type page) + #:content (content page))) + +(define-method (discard-updates (state <application-state>)) (let ((ret (shallow-clone state))) - (slot-set! ret 'pages - (filter (lambda (page) - (not (equal? (identifier page) id))) - (pages state))) + (slot-set! ret 'page (discard-updates (page state))) ret)) + +(define-method (commit-updates (state <application-state>)) + (let ((loading (shallow-clone state))) + (slot-set! loading 'page + (make <loading-page> + #:uri (uri (page state)))) + (if (is-a? (page state) <updated-page>) + (add-job + loading + (format #f (G_ "Updating ~a (expected ETag ~a)") + (uri->string (uri (page state))) + (etag (page state))) + (lambda () + (let ((account (main-account state)) + (client (client state))) + (parameterize ((client:client client)) + (receive (updated-account response response-body) + (client:request account (uri (page state)) + #:method 'PUT + #:headers `(,@(let ((etag (etag (page state)))) + (if etag + `((if-match . ((,etag . #f)))) + '())) + ,@(map + (lambda (link) + `(link . ,link)) + (desired-links (page state))) + (content-type . (,(desired-content-type (page state))))) + #:body (desired-content (page state))) + (lambda (previous-state) + (let ((ret (shallow-clone previous-state))) + (when (equal? (main-account previous-state) account) + (slot-set! ret 'main-account updated-account)) + (when (equal? (page previous-state) + (page loading)) + (slot-set! ret 'page + (if (eqv? (response-code response) 200) + (make <loaded-page> + #:uri (uri (page state)) + #:etag (match (response-etag response) + ((etag . #f) etag) + (else #f)) + #:links (desired-links (page state)) + #:content-type (desired-content-type (page state)) + #:content (desired-content (page state))) + (make <error-page> + #:uri (uri (page state)) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response))))) + ret))))))) + state))) + +(define-method (delete-page (state <application-state>)) + (if (is-a? (page state) <page-with-uri>) + (add-job + state + (format #f (G_ "Deleting ~a (expected ETag ~a)") + (uri (page state)) + (and (is-a? (page state) <loaded-page>) + (etag (page state)))) + (lambda () + (let ((account (main-account state)) + (client (client state))) + (parameterize ((client:client client)) + (receive (updated-account response response-body) + (client:request account (uri (page state)) + #:method 'DELETE + #:headers `(,@(let ((etag (and (is-a? (page state) <loaded-page>) + (etag (page state))))) + (if etag + `((if-match . (,(etag (page state)) . #f))) + '())))) + (lambda (previous-state) + (let ((ret (shallow-clone previous-state))) + (when (equal? (main-account previous-state) account) + (slot-set! ret 'main-account updated-account)) + (when (equal? (page previous-state) + (page state)) + (slot-set! ret 'page + (make <new-page>))) + ret))))))) + state)) |