diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-08 17:58:37 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-08-09 12:08:12 +0200 |
commit | 0b5d0622e11c1f919ce660893067d3121e2583a0 (patch) | |
tree | e389631eb33b094481924a06ba77e2bcfd4d47ba /src | |
parent | b43be9d4b05af12a22a97210b35885a3727e4a86 (diff) |
Add a simulation type to test complex systems.
Diffstat (limited to 'src')
-rw-r--r-- | src/scm/webid-oidc/Makefile.am | 6 | ||||
-rw-r--r-- | src/scm/webid-oidc/simulation.scm | 186 |
2 files changed, 190 insertions, 2 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 3e92bd3..4db767f 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -47,7 +47,8 @@ dist_webidoidcmod_DATA += \ %reldir%/http-link.scm \ %reldir%/offloading.scm \ %reldir%/catalog.scm \ - %reldir%/parameters.scm + %reldir%/parameters.scm \ + %reldir%/simulation.scm webidoidcgo_DATA += \ %reldir%/errors.go \ @@ -82,7 +83,8 @@ webidoidcgo_DATA += \ %reldir%/http-link.go \ %reldir%/offloading.go \ %reldir%/catalog.go \ - %reldir%/parameters.go + %reldir%/parameters.go \ + %reldir%/simulation.go EXTRA_DIST += %reldir%/ChangeLog diff --git a/src/scm/webid-oidc/simulation.scm b/src/scm/webid-oidc/simulation.scm new file mode 100644 index 0000000..45fb1f3 --- /dev/null +++ b/src/scm/webid-oidc/simulation.scm @@ -0,0 +1,186 @@ +;; 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 <https://www.gnu.org/licenses/>. + +(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 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 + ( + <simulation> + make-simulation + simulation? + simulation-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 (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)))) + (error "Invalid credentials.\n")) + (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") + #:http-get + (lambda* (uri . args) + (apply request simulation uri #:method 'GET args)))) + (server + (make-resource-server + #:server-uri server-uri + #:owner owner + #:http-get + (lambda* (uri . args) + (apply request simulation uri #:method 'GET args))))) + (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)))) |