;; disfluid, implementation of the Solid specification
;; Copyright (C) 2021 Vivien Kraus
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see .
(define-module (webid-oidc client application)
#: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 futures)
#:use-module (ice-9 threads)
#:use-module (ice-9 atomic)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#: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:)
#:use-module ((webid-oidc jwk) #:prefix jwk:)
#:use-module ((webid-oidc dpop-proof) #:prefix dpop:)
#:use-module ((webid-oidc client) #:prefix client:)
#:use-module ((webid-oidc client accounts) #:prefix account:)
#:use-module ((webid-oidc cache) #:prefix cache:)
#:use-module (webid-oidc web-i18n)
#:use-module (web uri)
#:use-module (web response)
#:use-module (rnrs bytevectors)
#:use-module (oop goops)
#:declarative? #t
#:export
(
description result-box thread
result join
authorization-uri reason continuation
main-account other-accounts client error-messages authorization-prompts running-jobs page
uri
code reason-phrase
etag links content-type content
desired-links desired-content-type desired-content
add-account
choose-account
remove-account
set-accounts
set-client
fold-authorization-prompts
set-page-uri
edit-page
remove-link
add-link
change-content-type
change-content
discard-updates
commit-updates
delete-page
)
#:declarative? #t)
(define client:)
(define account:)
(define-class ()
(description #:init-keyword #:description #:getter description)
(result-box #:init-thunk (lambda () (make-atomic-box #f)) #:getter result-box))
(define-method (equal? (x ) (y ))
(and (equal? (description x) (description y))
(eq? (result-box x) (result-box y))))
(define-method (result (job ))
(atomic-box-ref (result-box job)))
(define-class ()
(authorization-uri #:init-keyword #:authorization-uri #:getter authorization-uri)
(reason #:init-keyword #:reason #:getter reason)
(continuation #:init-keyword #:continuation #:getter continuation))
(define-method (equal? (x ) (y ))
(and (equal? (authorization-uri x) (authorization-uri y))
(equal? (reason x) (reason y))
(eq? (continuation x) (continuation y))))
(define-class ()
(main-account
#:init-keyword #:main-account
#:getter main-account
#:init-value #f)
(other-accounts
#:init-keyword #:other-accounts
#:getter other-accounts
#:init-value '())
(client
#:init-keyword #:client
#:getter client
#:init-thunk (lambda ()
(make
#:client-id
"https://webid-oidc-demo.planete-kraus.eu/example-application#id"
#:redirect-uri
"https://webid-oidc-demo.planete-kraus.eu/authorized")))
(error-messages
#:init-keyword #:error-messages
#:getter error-messages
#:init-value '())
(authorization-prompts
#:init-keyword #:authorization-prompts
#:getter authorization-prompts
#:init-value '())
(running-jobs
#:init-keywords #:running-jobs
#:getter running-jobs
#:init-value '())
(page
#:init-keyword #:page
#:getter page
#:init-thunk
(lambda ()
(make ))))
(define-method (equal? (x ) (y ))
(and (equal? (main-account x) (main-account y))
(equal? (other-accounts x) (other-accounts y))
(equal? (client x) (client y))
(equal? (error-messages x) (error-messages y))
(equal? (authorization-prompts x) (authorization-prompts y))
(equal? (running-jobs x) (running-jobs y))
(equal? (page x) (page y))))
(define-method (display (state ) port)
(format port "#< main-account=~a other-accounts=~a client=~a error-messages=~a authorization-prompts=~a running-jobs=~a>"
(call-with-output-string
(lambda (port)
(display (main-account state) port)))
(call-with-output-string
(lambda (port)
(display (map (lambda (acct)
(uri->string (account:subject acct)))
(other-accounts state))
port)))
(call-with-output-string
(lambda (port)
(display (client state) port)))
(error-messages state)
(map (lambda (prompt)
(uri->string (authorization-uri prompt)))
(authorization-prompts state))
(map description (running-jobs state))))
(define-method (join (state ))
(let ((ret (shallow-clone state)))
(receive (finished unfinished)
(partition result (reverse (running-jobs state)))
(slot-set! ret 'running-jobs (reverse unfinished))
(let apply-finished-jobs ((state ret)
(jobs (map result finished)))
(match jobs
(() state)
((#f tl ...)
(apply-finished-jobs state tl))
((hd tl ...)
(apply-finished-jobs (hd state) tl)))))))
(define-method (add-job (state ) (description ) f)
(let ((job (make #:description description)))
(call-with-new-thread
(lambda ()
(let ((tag (make-prompt-tag)))
(atomic-box-set!
(result-box job)
;; The following code returns an updater. The updater takes
;; a previous state and returns a new state.
;;
;; There are 2 possible branches:
;;
;; 1. If everything works, the updater is what’s returned by
;; (f);
;;
;; 2. If (f) calls the authorization process, the updater is
;; a function that adds an authorization prompts to further
;; continue the call in a new job. In that case, continuing
;; yields an updater too, because it is delimited by this
;; prompt.
(call-with-prompt tag
(lambda ()
(parameterize
((client:client (client state))
(account:authorization-process
(lambda* (uri #:key (reason #f))
(abort-to-prompt
tag
(lambda (continuation)
;; This is a state updating function. It just
;; registers the continuation as a new
;; authorization prompt.
(lambda (previous-state)
;; This code runs in the main thread.
(define (continue state code)
(add-job state description
(lambda ()
(continuation code))))
(let ((ret (shallow-clone previous-state)))
(slot-set! ret 'authorization-prompts
`(,(make
#:authorization-uri uri
#:reason reason
#:continuation continue)
,@(authorization-prompts previous-state)))
ret)))))))
(with-exception-handler
(lambda (exn)
(let ((msg (if (exception-with-message? exn)
(exception-message exn)
(format #f "~s" exn))))
(abort-to-prompt
tag
(lambda (_)
;; We won’t continue, but we will show the error message
(lambda (previous-state)
(let ((ret (shallow-clone previous-state)))
(slot-set! ret 'error-messages
`(,msg ,@(error-messages previous-state)))
ret))))))
(lambda ()
(f)))))
(lambda (continuation get-updater)
(get-updater continuation)))))))
(let ((ret (shallow-clone state)))
(slot-set! ret 'running-jobs `(,job ,@(running-jobs ret)))
ret)))
(define-method (add-account (state ) issuer)
(add-job
state
(format #f (G_ "Add an account on ~a")
(uri->string issuer))
(lambda ()
(let ((new-account (make #:issuer issuer)))
;; The updater either sets the main account, or adds it to the
;; other accounts. If there is already an account with the same
;; subject and issuer, print an error message instead.
(lambda (previous-state)
(let ((current-main-account (main-account previous-state)))
(if current-main-account
(if (and (equal? (account:subject current-main-account) (account:subject new-account))
(equal? (account:issuer current-main-account) (account:issuer new-account)))
;; First kind of duplicate
(let ((ret (shallow-clone previous-state)))
(slot-set! ret 'error-messages
`(,(format #f (G_ "You already have an account for ~a issued by ~a and it is currently selected.")
(uri->string (account:subject new-account))
(uri->string (account:issuer new-account)))))
ret)
;; The main account slot is already taken, add it to the other accounts
(let check ((other (other-accounts previous-state)))
(match other
(()
;; The account does not already exist
(let ((ret (shallow-clone previous-state)))
(slot-set! ret 'other-accounts
`(,new-account ,@(other-accounts previous-state)))
ret))
((existing other ...)
(if (and (equal? (account:subject existing) (account:subject new-account))
(equal? (account:issuer existing) (account:issuer new-account)))
;; Second kind of duplicate
(let ((ret (shallow-clone previous-state)))
(slot-set! ret 'error-messages
`(,(format #f (G_ "You already have an account for ~a issued by ~a.")
(uri->string (account:subject new-account))
(uri->string (account:issuer new-account)))))
ret)
(check other))))))
;; No main account yet
(let ((ret (shallow-clone previous-state)))
(slot-set! ret 'main-account new-account)
ret))))))))
(define-method (choose-account (state ) (account ))
(let ((ret (shallow-clone state)))
(slot-set! ret 'main-account account)
(slot-set! ret 'other-accounts
(filter (lambda (other)
(not (equal? other account)))
`(,(main-account state) ,@(other-accounts state))))
ret))
(define-method (remove-account (state ) (account ))
(let ((ret (shallow-clone state)))
(let ((main (main-account ret))
(other (other-accounts ret)))
(let* ((all `(,main ,@other))
(kept (filter (lambda (a) (not (equal? a account))) all)))
(match kept
(()
(slot-set! ret 'main-account #f)
(slot-set! ret 'other-accounts '()))
((main other ...)
(slot-set! ret 'main-account main)
(slot-set! ret 'other-accounts other)))))
ret))
(define-method (set-accounts (state ) (accounts ))
(let ((ret (shallow-clone state)))
(match accounts
(()
(slot-set! ret 'main-account #f)
(slot-set! ret 'other-accounts '()))
((main other ...)
(slot-set! ret 'main-account main)
(slot-set! ret 'other-accounts other)))
ret))
(define-method (set-accounts (state ) (main ) (other ))
(set-accounts state `(,main ,@other)))
(define-method (set-client (state ) (client ))
(let ((ret (shallow-clone state)))
(slot-set! ret 'client client)
ret))
(define-method (fold-authorization-prompts (state ) f seed)
(let iter ((prompts (reverse (authorization-prompts state)))
(seed seed)
(state
(let ((ret (shallow-clone state)))
(slot-set! ret 'authorization-prompts '())
ret)))
(match prompts
(()
(values seed state))
((prompt prompts ...)
(receive (seed code) (f seed (authorization-uri prompt))
(let ((state
;; If I have a code, transform state by calling the
;; continuation function (i.e., add a job that will
;; finish the task). If I don’t, I need to keep this
;; prompt around.
(if code
((continuation prompt) state code)
(let ((with-unresolved-prompt (shallow-clone state)))
(slot-set! ret 'authorization-prompts
`(,prompt ,@(authorization-prompts state)))
with-unresolved-prompt))))
(iter prompts seed state)))))))
(define-class ())
(define-method (equal? (x ) (y ))
(and (equal? (identifier x) (identifier y))))
(define-class ())
(define-class ()
(uri #:init-keyword #:uri #:getter uri))
(define-method (initialize (page ) initargs)
(next-method)
(let-keywords
initargs #t
((uri #f))
(let do-initialize ((uri uri))
(match uri
((or (? string? (= string->uri (? uri? uri)))
(? uri? uri)
(? string?
(= (cute string-append "https://" <>)
(= string->uri (? uri? uri)))))
(slot-set! page 'uri uri))
(else
(scm-error 'wrong-type-arg "make "
(G_ "the page URI (#:uri) should be a string encoding an URI or an URI")
'()
(list uri)))))))
(define-method (equal? (x ) (y ))
(and (equal? (uri x) (uri y))))
(define-class ())
(define-class ()
(code #:init-keyword #:code #:getter code)
(reason-phrase #:init-keyword #:reason-phrase #:getter reason-phrase))
(define-method (initialize (page ) initargs)
(next-method)
(let-keywords
initargs #t
((code #f)
(reason-phrase #f))
(let do-initialize ((code code)
(reason-phrase reason-phrase))
(match `(,code ,reason-phrase)
(((? integer? code) (? string? reason-phrase))
(slot-set! page 'code code)
(slot-set! page 'reason-phrase reason-phrase))
(else
(scm-error 'wrong-type-arg "make "
(G_ "the error code (#:code) should be an integer and the reason phrase (#:reason-phrase) should be a string")
'()
(list code reason-phrase)))))))
(define-method (equal? (x ) (y ))
(and (equal? (uri x) (uri y))
(equal? (code x) (code y))
(equal? (reason-phrase x) (reason-phrase y))))
(define-class ()
(etag #:init-keyword #:etag #:getter etag)
(links #:init-keyword #:links #:getter links)
(content-type #:init-keyword #:content-type #:getter content-type)
(content #:init-keyword #:content #:getter content))
(define (all-links? elements)
(match elements
(() #t)
(((? (cute is-a? <> )) elements ...)
(all-links? elements))
(else #f)))
(define-method (initialize (page ) initargs)
(next-method)
(let-keywords
initargs #t
((etag #f)
(links #f)
(content-type #f)
(content #f))
(let do-initialize ((etag etag)
(links links)
(content-type content-type)
(content content))
(match `(,etag ,links ,content-type ,content)
(((or (? not etag)
(? string? etag))
(? all-links? links)
(or (? symbol? content-type)
((? symbol? content-type) _ ...))
(or (? string? content)
(? bytevector? content)
(? not content)))
(slot-set! page 'etag etag)
(slot-set! page 'links links)
(slot-set! page 'content-type content-type)
(slot-set! page 'content content))
(else
(scm-error 'wrong-type-arg "make "
(G_ "the etag (#:etag) should be a string or #f, the links (#:links) should be a list of links, the content-type (#:content-type) should be a symbol or a list whose first item is a symbol, and the content (#:content) should be a string or a bytevector, or #f for responses without a content")
'()
(list etag links content-type content)))))))
(define-method (equal? (x ) (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 ()
(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 (initialize (page ) initargs)
(next-method)
(let-keywords
initargs #t
((desired-links #f)
(desired-content-type #f)
(desired-content #f))
(let do-initialize ((desired-links desired-links)
(desired-content-type desired-content-type)
(desired-content desired-content))
(match `(,desired-links ,desired-content-type ,desired-content)
(((? list? desired-links)
(? symbol? desired-content-type)
(or (? string? desired-content)
(? bytevector? desired-content)))
(slot-set! page 'desired-links desired-links)
(slot-set! page 'desired-content-type desired-content-type)
(slot-set! page 'desired-content desired-content))
(else
(scm-error 'wrong-type-arg "make "
(G_ "the desired links (#:desired-links) should be an alist from URI to alists, the desired content-type (#:desired-content-type) should be a symbol, and the desired content (#:desired-content) should be a string or a bytevector")
'()
(list desired-links desired-content-type desired-content)))))))
(define-method (equal? (x ) (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))
(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)
(define-method (edit-page (page ))
(make
#: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 ))
page)
(define-method (edit-page (state ))
(let ((ret (shallow-clone state)))
(slot-set! ret 'page (edit-page (page ret)))
ret))
(define-method (remove-link (page ) target key value)
(let ((ret (edit-page page)))
(when (is-a? ret )
(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-method (remove-link (state ) target key value)
(let ((ret (shallow-clone state)))
(slot-set! ret 'page (remove-link (page ret) target key value))
ret))
(define-method (add-link (page ) target key value)
(let ((ret (edit-page page)))
(when (is-a? ret )
(slot-set! ret 'desired-links
`((,target (,key . ,value))
,@(desired-links page))))
ret))
(define-method (add-link (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 (set-page-uri (state ) page-uri)
(let ((ret (shallow-clone state))
(new-page (make
#:uri page-uri)))
(slot-set! ret 'page new-page)
(add-job
ret
(format #f (G_ "Loading ~a...") (uri->string (uri new-page)))
(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
#:uri (uri new-page)
#: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
#:uri (uri new-page)
#:code (response-code response)
#:reason-phrase (response-reason-phrase response)))))
ret)))))))))
(define-method (change-content-type (state ) content-type)
(let ((ret (shallow-clone state)))
(slot-set!
ret 'page
(let ((p (edit-page (page ret))))
(slot-set! p 'desired-content-type content-type)
p))
ret))
(define-method (change-content (state ) content)
(let ((ret (shallow-clone state)))
(slot-set!
ret 'page
(let ((p (edit-page (page ret))))
(slot-set! p 'desired-content content)
p))
ret))
(define-method (discard-updates (page ))
page)
(define-method (discard-updates (page ))
(make
#:uri (uri page)
#:etag (etag page)
#:links (links page)
#:content-type (content-type page)
#:content (content page)))
(define-method (discard-updates (state ))
(let ((ret (shallow-clone state)))
(slot-set! ret 'page (discard-updates (page state)))
ret))
(define-method (commit-updates (state ))
(let ((loading (shallow-clone state)))
(slot-set! loading 'page
(make
#:uri (uri (page state))))
(if (is-a? (page state) )
(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
#: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
#:uri (uri (page state))
#:code (response-code response)
#:reason-phrase (response-reason-phrase response)))))
ret)))))))
state)))
(define-method (delete-page (state ))
(if (is-a? (page state) )
(add-job
state
(format #f (G_ "Deleting ~a (expected ETag ~a)")
(uri (page state))
(and (is-a? (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 'DELETE
#:headers `(,@(let ((etag (and (is-a? (page state) )
(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 )))
ret)))))))
state))