Add a simulation type to test complex systems.

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))))