diff options
Diffstat (limited to 'src/scm/webid-oidc/simulation.scm')
| -rw-r--r-- | src/scm/webid-oidc/simulation.scm | 143 |
1 files changed, 50 insertions, 93 deletions
diff --git a/src/scm/webid-oidc/simulation.scm b/src/scm/webid-oidc/simulation.scm index 0accdc4..38c22ae 100644 --- a/src/scm/webid-oidc/simulation.scm +++ b/src/scm/webid-oidc/simulation.scm @@ -16,8 +16,7 @@ (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 server endpoint) #:use-module (webid-oidc web-i18n) #:use-module (webid-oidc errors) #:use-module ((webid-oidc parameters) #:prefix p:) @@ -29,36 +28,37 @@ #:use-module (ice-9 receive) #:use-module (ice-9 optargs) #:use-module (ice-9 match) + #:use-module (ice-9 control) + #:use-module (srfi srfi-26) + #:use-module (sxml simple) + #:use-module (oop goops) #:export ( <simulation> - make-simulation - simulation? - simulation-scroll-log! + endpoint + log + + scroll-log! request get post grant-authorization - add-server! - add-client! ) #:declarative? #t) -(define-record-type <simulation> - (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-class <simulation> () + (endpoint #:init-keyword #:endpoint #:getter endpoint) + (log-rev #:getter log-rev #:init-value '())) -(define (make-simulation) - (make-full-simulation '() '())) +(define-method (log (simulation <simulation>)) + (reverse (log-rev simulation))) -(define (simulation-scroll-log! simulation) - (let ((log (reverse (simulation-log-rev simulation)))) - (simulation-log-rev-set! simulation '()) - log)) +(define-method (scroll-log! (simulation <simulation>)) + (let ((the-log (log simulation))) + (slot-set! simulation 'log-rev '()) + the-log)) (define* (request simulation uri #:key @@ -66,12 +66,7 @@ (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 + (let ((rq (build-request uri #:method method #:version version @@ -79,23 +74,34 @@ #: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))))) + (let/ec return + (with-exception-handler + (lambda (error) + (when (web-exception? error) + (return + (build-response #:code (web-exception-code error) + #:reason-phrase (web-exception-reason-phrase error) + #:headers `((content-type application/xhtml-xml))) + (call-with-output-string + (cute sxml->xml + `(*TOP* + (*PI* xml "version=\"1.0\" encoding=\"utf-8\"") + (html (@ (xmlns "http://www.w3.org/1999/xhtml") + (xml:lang ,(W_ "xml-lang|en"))) + (head + (title ,(W_ "An error happened…"))) + (body + ,(call-with-input-string + (format #f (W_ "<p>Sorry, an error happened.</p>")) + xml->sxml) + ,(user-message-sxml error)))) + <>)))) + ;; Other kind of exception + (raise-exception error)) + (lambda () + (receive (response response-body response-meta) + (handle (endpoint simulation) rq rq-body) + (values response response-body))))) (unless (response-date response) ;; We need to set a date. (set! response @@ -105,10 +111,9 @@ #: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))) + (slot-set! simulation 'log-rev + `((,rq ,rq-body ,response ,response-body) + ,@(slot-ref simulation 'log-rev))) (values response response-body)))) (define* (get simulation uri . args) @@ -134,51 +139,3 @@ (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)))) |