summaryrefslogtreecommitdiff
path: root/src/scm/webid-oidc/client/application.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/scm/webid-oidc/client/application.scm')
-rw-r--r--src/scm/webid-oidc/client/application.scm313
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))
generated by cgit v1.2.3 (git 2.44.0) at 2024-06-01 22:20:50 +0000