;; 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 (webid-oidc errors)
#: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 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 pages
add-account
choose-account
remove-account
set-accounts
set-client
fold-authorization-prompts
add-page
set-page-uri
close-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 '())
(pages
#:init-keyword #:pages
#:getter pages
#:init-value '()))
(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? (pages x) (pages 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 ()
(identifier #:init-keyword #:identifier #:getter identifier))
(define-method (equal? (x ) (y ))
(and (equal? (identifier x) (identifier y))))
(define-class ())
(define-class ()
(uri #:init-keyword #:uri #:getter 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 (equal? (x ) (y ))
(and (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))
(define-method (equal? (x ) (y ))
(and (equal? (etag x) (etag y))
(equal? (links x) (links y))))
(define-class ()
(triples #:init-keyword #:triples #:getter triples))
(define-method (equal? (x ) (y ))
(and (equal? (triples x) (triples y))))
(define-class ()
(content-type #:init-keyword #:content-type #:getter content-type)
(content #:init-keyword #:content #:getter content))
(define-method (equal? (x ) (y ))
(and (equal? (content-type x) (content-type y))
(equal? (content x) (content y))))
(define-method (add-page (state ) (identifier ))
(let ((ret (shallow-clone state)))
(slot-set! ret 'pages
`(,(make #:identifier identifier)
,@(pages state)))
ret))
(define-method (set-page-uri (state ) (id ) uri)
(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
#:identifier id
#:uri uri)
hd)))
(replace-page
tl
`(,replaced
,@(untouched-pages))))))))
;; TODO: add a job to load the page…
ret))
(define-method (close-page (state ) (id ))
(let ((ret (shallow-clone state)))
(slot-set! ret 'pages
(filter (lambda (page)
(not (equal? (identifier page) id)))
(pages state)))
ret))