;; 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 simulation)
#:use-module ((webid-oidc client) #:prefix client:)
#:use-module (webid-oidc identity-provider)
#:use-module (webid-oidc resource-server)
#:use-module (webid-oidc web-i18n)
#:use-module (webid-oidc errors)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module ((webid-oidc server create) #:prefix server:)
#:use-module (web uri)
#:use-module (web request)
#:use-module (web response)
#:use-module (srfi srfi-9)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
#:use-module (ice-9 match)
#:export
(
make-simulation
simulation?
simulation-scroll-log!
request
get
post
grant-authorization
add-server!
add-client!
)
#:declarative? #t)
(define-record-type
(make-full-simulation handlers-rev log-rev)
simulation?
(handlers-rev simulation-handlers-rev simulation-handlers-rev-set!)
(log-rev simulation-log-rev simulation-log-rev-set!))
(define (make-simulation)
(make-full-simulation '() '()))
(define (simulation-scroll-log! simulation)
(let ((log (reverse (simulation-log-rev simulation))))
(simulation-log-rev-set! simulation '())
log))
(define* (request simulation uri
#:key
(method 'GET)
(body #f)
(version '(1 . 1))
(headers '()))
(let ((server-uri
(build-uri (uri-scheme uri)
#:userinfo (uri-userinfo uri)
#:host (uri-host uri)
#:port (uri-port uri)))
(rq
(build-request uri
#:method method
#:version version
#:headers headers
#:port (open-output-string)))
(rq-body body))
(receive (response response-body)
(let find-handler ((handlers
(reverse
(simulation-handlers-rev simulation))))
(match handlers
(()
(values
(build-response #:code 404
#:reason-phrase "Not Found")
"Resource not found."))
(((server . handler) tl ...)
(if (equal? server server-uri)
(receive (response response-body . _)
(handler rq rq-body)
(if (eqv? (response-code response) 404)
(find-handler tl)
(values response response-body)))
(find-handler tl)))))
(unless (response-date response)
;; We need to set a date.
(set! response
(build-response #:version (response-version response)
#:code (response-code response)
#:reason-phrase (response-reason-phrase response)
#:headers `((date . ,((p:current-date)))
,@(response-headers response))
#:port (response-port response))))
(simulation-log-rev-set!
simulation
`((,rq ,rq-body ,response ,response-body)
,@(simulation-log-rev simulation)))
(values response response-body))))
(define* (get simulation uri . args)
(apply request simulation uri #:method 'GET args))
(define* (post simulation uri . args)
(apply request simulation uri #:method 'POST args))
(define (grant-authorization simulation authorization-uri)
(receive (response response-body)
(request simulation authorization-uri
#:method 'POST
#:body "password=password"
#:headers '((content-type application/x-www-form-urlencoded)))
(unless (and (eqv? (response-code response) 302)
(response-location response)
(uri-query (response-location response))
(string-prefix? "code=" (uri-query (response-location response))))
(fail (format #f (G_ "invalid credentials: response ~s ~s")
(response-code response)
(response-reason-phrase response))))
(let* ((uri (response-location response))
(query (uri-query uri))
(code (substring query (string-length "code="))))
code)))
(define (add-server! simulation server-uri owner)
(define (with-path uri path)
(build-uri (uri-scheme uri)
#:userinfo (uri-userinfo uri)
#:host (uri-host uri)
#:port (uri-port uri)
#:path path))
(let ((identity-provider
(make-identity-provider
server-uri
(string-append (p:data-home)
"/"
(uri-encode (uri->string server-uri))
"/key.jwk")
owner
(crypt "password" "xxx")
(with-path server-uri "/keys")
(with-path server-uri "/authorize")
(with-path server-uri "/token")))
(server
(make-resource-server
#:server-uri server-uri
#:owner owner)))
(define (handle request body)
(let ((path (uri-path (request-uri request))))
(if (member path
'("/.well-known/openid-configuration"
"/keys"
"/authorize"
"/token"))
(identity-provider request body)
(server request body))))
;; Ensure that the profile exists
(server:create-root server-uri owner)
(simulation-handlers-rev-set!
simulation
`((,server-uri . ,handle)
,@(simulation-handlers-rev simulation)))))
(define (add-client! simulation server-uri client-id redirect-uri name uri)
(simulation-handlers-rev-set!
simulation
`((,server-uri
. ,(client:serve-application client-id redirect-uri
#:client-name name
#:client-uri uri))
,@(simulation-handlers-rev simulation))))