;; 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-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
(
main-account other-accounts client error-messages authorization-prompts
current-state pending-operations
check-pending-operations
add-account
choose-account
set-client
process-authorization-prompts
->sexp
)
#:declarative? #t)
(define client:)
(define account:)
(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 on the
;; authorization code
(authorization-prompts
#:init-keyword #:authorization-prompts
#:getter authorization-prompts
#: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>"
(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))))
(define-class ()
(current-state
#:init-keyword #:current-state
#:getter current-state
#:init-thunk (lambda () (make )))
;; This is an atomic box to a list of state -> state functions that
;; should be executed as soon as possible, in reverse order.
(pending-operations
#:init-keyword #:pending-operations
#:getter pending-operations
#:init-thunk (lambda () (make-atomic-box '()))))
(define-method (->sexp (state ))
`(begin
(use-modules (oop goops) (webid-oidc client application))
(make
#:current-state ,(->sexp (current-state state)))))
(define-method (write (state ) port)
(pretty-print (->sexp state) port))
(define-method (display (state ) port)
(format port "#< current-state=~a n-pending-operations=~a>"
(call-with-output-string
(lambda (port)
(display (current-state state) port)))
(length (atomic-box-ref (pending-operations state)))))
(define-method (check-pending-operations (state ))
(let steal-pending-operations ()
(let* ((box (pending-operations state))
(stolen-pending-operations
(atomic-box-ref (pending-operations state)))
(confirmed-pending-operations
(atomic-box-compare-and-swap! box stolen-pending-operations '())))
(if (eq? stolen-pending-operations confirmed-pending-operations)
(let apply-all ((state (current-state state))
(ops (reverse stolen-pending-operations)))
(match ops
(()
(make
#:current-state state
#:pending-operations box))
((hd tl ...)
(apply-all (hd state) tl))))
;; Concurrent update, retry
(steal-pending-operations)))))
(define-method (push-pending-operation (state ) f)
(let ((other-pending-operations
(atomic-box-ref (pending-operations state))))
(let ((confirmed (atomic-box-compare-and-swap!
(pending-operations state)
other-pending-operations
`(,f ,@other-pending-operations))))
(unless (eq? confirmed other-pending-operations)
;; Retry
(push-pending-operation state f)))))
(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 (run-async (state ) f)
(call-with-new-thread
(lambda ()
(let ((tag (make-prompt-tag)))
(define (handle-authorization-prompts f)
(call-with-prompt tag
(lambda ()
(parameterize
((client:client (client (current-state 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.
(define (continuation-with-dynamic-state authorization-code)
(handle-authorization-prompts
(lambda ()
(continuation authorization-code))))
(lambda (previous-state)
;; This code is ran in the main thread.
(let ((ret (shallow-clone previous-state)))
(slot-set! ret 'authorization-prompts
`((,uri . ,continuation-with-dynamic-state)
,@(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))))))
f)))
(lambda (continuation get-updater)
(push-pending-operation state (get-updater continuation)))))
(handle-authorization-prompts
(lambda ()
(let ((updater (f)))
(push-pending-operation state updater))))))))
(define-method (add-account (state ) issuer)
(run-async
state
(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)))
(let ((new-state
(let ((current (shallow-clone (current-state state))))
(slot-set! current 'main-account account)
(slot-set! current 'other-accounts
(filter (lambda (other)
(not (equal? other account)))))
current)))
(slot-set! ret 'current-state new-state))
ret))
(define-method (set-client (state ) (client ))
(let ((ret (shallow-clone state)))
(let ((new-state
(let ((current (shallow-clone (current-state state))))
(slot-set! current 'client client)
current)))
(slot-set! ret 'current-state new-state))
ret))
(define-method (process-authorization-prompts (state ) f seed)
(let iter ((prompts (authorization-prompts state))
(unsolved '())
(seed seed))
(match prompts
(()
(let ((ret (shallow-clone state)))
(slot-set! ret 'authorization-prompts
(reverse unsolved))
(values seed ret)))
(((uri . continue) prompts ...)
(receive (seed code) (f seed uri)
(when code
(continue code))
(iter prompts
(if code
unsolved
`((,uri . ,continue) ,@unsolved))
seed))))))
(define-method (process-authorization-prompts (state ) f seed)
(let ((ret (shallow-clone state)))
(receive (seed new-state)
(process-authorization-prompts (current-state state) f seed)
(slot-set! ret 'current-state new-state)
(values seed ret))))