diff options
| -rw-r--r-- | po/disfluid.pot | 22 | ||||
| -rw-r--r-- | po/fr.po | 22 | ||||
| -rw-r--r-- | src/scm/webid-oidc/Makefile.am | 6 | ||||
| -rw-r--r-- | src/scm/webid-oidc/simulation.scm | 186 |
4 files changed, 212 insertions, 24 deletions
diff --git a/po/disfluid.pot b/po/disfluid.pot index 41a72c0..75e0165 100644 --- a/po/disfluid.pot +++ b/po/disfluid.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: disfluid SNAPSHOT\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-08-01 15:25+0000\n" +"POT-Creation-Date: 2021-08-08 23:16+0200\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" "Language-Team: LANGUAGE <LL@li.org>\n" @@ -968,32 +968,32 @@ msgstr "" msgid "Warning: ~a\n" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:48 src/scm/webid-oidc/example-app.scm:116 +#: src/scm/webid-oidc/hello-world.scm:47 src/scm/webid-oidc/example-app.scm:116 #: src/scm/webid-oidc/program.scm:233 msgid "command-line|version" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:50 src/scm/webid-oidc/program.scm:237 +#: src/scm/webid-oidc/hello-world.scm:49 src/scm/webid-oidc/program.scm:237 msgid "command-line|complete-corresponding-source" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:52 src/scm/webid-oidc/program.scm:239 +#: src/scm/webid-oidc/hello-world.scm:51 src/scm/webid-oidc/program.scm:239 msgid "command-line|help" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:54 +#: src/scm/webid-oidc/hello-world.scm:53 msgid "command-line|port" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:56 src/scm/webid-oidc/program.scm:271 +#: src/scm/webid-oidc/hello-world.scm:55 src/scm/webid-oidc/program.scm:271 msgid "command-line|log-file" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:58 src/scm/webid-oidc/program.scm:273 +#: src/scm/webid-oidc/hello-world.scm:57 src/scm/webid-oidc/program.scm:273 msgid "command-line|error-file" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:70 +#: src/scm/webid-oidc/hello-world.scm:69 #, scheme-format msgid "" "~a [OPTIONS]...\n" @@ -1022,18 +1022,18 @@ msgid "" " redirect the program errors to FILE.err.\n" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:103 +#: src/scm/webid-oidc/hello-world.scm:102 #: src/scm/webid-oidc/example-app.scm:159 #, scheme-format msgid "~a version ~a\n" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:112 src/scm/webid-oidc/program.scm:632 +#: src/scm/webid-oidc/hello-world.scm:111 src/scm/webid-oidc/program.scm:632 msgid "" "You are legally required to link to the complete corresponding source code.\n" msgstr "" -#: src/scm/webid-oidc/hello-world.scm:123 +#: src/scm/webid-oidc/hello-world.scm:121 msgid "The port should be a number between 0 and 65535.\n" msgstr "" @@ -2,7 +2,7 @@ msgid "" msgstr "" "Project-Id-Version: webid-oidc 0.0.0\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2021-08-01 15:25+0000\n" +"POT-Creation-Date: 2021-08-08 23:16+0200\n" "PO-Revision-Date: 2021-07-30 21:16+0200\n" "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n" "Language-Team: French <vivien@planete-kraus.eu>\n" @@ -1011,32 +1011,32 @@ msgstr "~a : échec d’authentificationn : ~a\n" msgid "Warning: ~a\n" msgstr "Avertissement : ~a\n" -#: src/scm/webid-oidc/hello-world.scm:48 src/scm/webid-oidc/example-app.scm:116 +#: src/scm/webid-oidc/hello-world.scm:47 src/scm/webid-oidc/example-app.scm:116 #: src/scm/webid-oidc/program.scm:233 msgid "command-line|version" msgstr "version" -#: src/scm/webid-oidc/hello-world.scm:50 src/scm/webid-oidc/program.scm:237 +#: src/scm/webid-oidc/hello-world.scm:49 src/scm/webid-oidc/program.scm:237 msgid "command-line|complete-corresponding-source" msgstr "code-source-correspondant-complet" -#: src/scm/webid-oidc/hello-world.scm:52 src/scm/webid-oidc/program.scm:239 +#: src/scm/webid-oidc/hello-world.scm:51 src/scm/webid-oidc/program.scm:239 msgid "command-line|help" msgstr "aide" -#: src/scm/webid-oidc/hello-world.scm:54 +#: src/scm/webid-oidc/hello-world.scm:53 msgid "command-line|port" msgstr "port" -#: src/scm/webid-oidc/hello-world.scm:56 src/scm/webid-oidc/program.scm:271 +#: src/scm/webid-oidc/hello-world.scm:55 src/scm/webid-oidc/program.scm:271 msgid "command-line|log-file" msgstr "fichier-journal" -#: src/scm/webid-oidc/hello-world.scm:58 src/scm/webid-oidc/program.scm:273 +#: src/scm/webid-oidc/hello-world.scm:57 src/scm/webid-oidc/program.scm:273 msgid "command-line|error-file" msgstr "fichier-erreur" -#: src/scm/webid-oidc/hello-world.scm:70 +#: src/scm/webid-oidc/hello-world.scm:69 #, scheme-format msgid "" "~a [OPTIONS]...\n" @@ -1090,20 +1090,20 @@ msgstr "" " -e FICHIER.err, --~a=FICHIER.err :\n" " redirige la sortie d’erreur du programme vers ce fichier.\n" -#: src/scm/webid-oidc/hello-world.scm:103 +#: src/scm/webid-oidc/hello-world.scm:102 #: src/scm/webid-oidc/example-app.scm:159 #, scheme-format msgid "~a version ~a\n" msgstr "~a version ~a\n" -#: src/scm/webid-oidc/hello-world.scm:112 src/scm/webid-oidc/program.scm:632 +#: src/scm/webid-oidc/hello-world.scm:111 src/scm/webid-oidc/program.scm:632 msgid "" "You are legally required to link to the complete corresponding source code.\n" msgstr "" "Vous êtes légalement tenu de fournir un lien vers le code source " "correspondant.\n" -#: src/scm/webid-oidc/hello-world.scm:123 +#: src/scm/webid-oidc/hello-world.scm:121 msgid "The port should be a number between 0 and 65535.\n" msgstr "Le port doit être un nombre entre 0 et 65535.\n" 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)))) |