;; 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 oidc-configuration) #:prefix cfg:)
#: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 (web client)
#:use-module (rnrs bytevectors)
#:use-module (oop goops)
#:declarative? #t
#:export
(
description result-box thread
result join
main-account other-accounts client error-messages authorization-prompts running-jobs pages
add-account
choose-account
set-client
fold-authorization-prompts
add-page
set-page-uri
close-page
->sexp
)
#: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 (result (job ))
(atomic-box-ref (result-box job)))
(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 '())
;; This is a list of pairs: URI * procedure to call with the
;; authorization code. The procedure takes 2 arguments: the code and
;; a state, and it returns the updated state.
(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 (->sexp (state ))
`(begin
(use-modules (oop goops) (webid-oidc client application))
(make
,@(let ((main-account (main-account state)))
(if main-account
`(#:main-account ,(account:->sexp main-account))
'()))
#:other-accounts (list ,@(map account:->sexp (other-accounts state)))
,@(let ((client (client state)))
(if client
`(#:client ,(client:->sexp client))
'()))
#:error-messages (list ,@(error-messages state)))))
(define-method (write (state ) port)
(pretty-print (->sexp state) port))
(define-method (display (state ) port)
(format port "#< main-account=~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 (client state) port)))
(error-messages state)
(map (match-lambda (((= uri->string uri) . _) uri))
(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)
((hd tl ...)
(apply-finished-jobs (hd state) tl)))))))
(define http-request-with-cache
(let ((default-http-get-with-cache (cache:with-cache)))
(lambda* (uri . all-args)
(let try-get-with-cache ((args all-args)
(args-for-get '()))
(match args
(()
(apply default-http-get-with-cache uri (reverse args-for-get)))
((#:headers arg other-args ...)
(try-get-with-cache other-args `(,arg #:headers ,@args-for-get)))
((#:method 'GET other-args ...)
(try-get-with-cache other-args args-for-get))
(else
(apply http-request uri all-args)))))))
(define-method (add-job (state ) (description ) f)
(let ((job (make #:description description)))
(call-with-new-thread
(lambda ()
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
(lambda ()
(parameterize
((client:client (client state))
(account:authorization-process
(lambda* (uri #:key issuer)
(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
`((,uri . ,continue)
,@(authorization-prompts previous-state)))
ret))))))
(account:anonymous-http-request http-request-with-cache))
(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 ()
(let ((updater (f)))
(atomic-box-set! (result-box job) updater))))))
(lambda (continuation get-updater)
(atomic-box-set! (result-box job) (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? (subject current-main-account) (subject new-account))
(equal? (issuer current-main-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 (subject new-account))
(uri->string (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? (subject existing) (subject new-account))
(equal? (issuer existing) (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 (subject new-account))
(uri->string (issuer new-account)))))
ret)
(check other))))))
;; No main account yet
(let ((ret (shallow-clone previous-state)))
(slot-set! ret 'main-account new-account)
ret)))))))
state)
(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)))))
ret))
(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))
(((uri . continue) prompts ...)
(receive (seed code) (f seed uri)
(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
(continue state code)
(let ((with-unresolved-prompt (shallow-clone state)))
(slot-set! ret 'authorization-prompts
`((,uri . ,continue) ,@(authorization-prompts state)))
with-unresolved-prompt))))
(iter prompts seed state)))))))
(define-class ()
(identifier #:init-keyword #:identifier #:getter identifier))
(define-class ())
(define-class ()
(uri #:init-keyword #:uri #:getter uri))
(define-class ())
(define-class ()
(code #:init-keyword #:code #:getter code)
(reason-phrase #:init-keyword #:reason-phrase #:getter reason-phrase))
(define-class ()
(etag #:init-keyword #:etag #:getter etag)
(links #:init-keyword #:links #:getter links))
(define-class ()
(triples #:init-keyword #:triples #:getter triples))
(define-class ()
(content-type #:init-keyword #:content-type #:getter content-type)
(content #:init-keyword #:content #:getter content))
(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))