From 1dc4802d231bf4083d387a6db0765730075cc752 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Sun, 17 Oct 2021 14:52:14 +0200 Subject: Use the endpoint API --- src/scm/webid-oidc/Makefile.am | 10 - src/scm/webid-oidc/authorization-endpoint.scm | 85 ---- src/scm/webid-oidc/client.scm | 41 -- src/scm/webid-oidc/hello-world.scm | 1 - src/scm/webid-oidc/identity-provider.scm | 135 ----- src/scm/webid-oidc/program.scm | 694 +++++--------------------- src/scm/webid-oidc/resource-server.scm | 139 ------ src/scm/webid-oidc/reverse-proxy.scm | 90 ---- src/scm/webid-oidc/simulation.scm | 143 ++---- src/scm/webid-oidc/testing.scm | 1 - src/scm/webid-oidc/token-endpoint.scm | 94 ---- 11 files changed, 183 insertions(+), 1250 deletions(-) delete mode 100644 src/scm/webid-oidc/authorization-endpoint.scm delete mode 100644 src/scm/webid-oidc/identity-provider.scm delete mode 100644 src/scm/webid-oidc/resource-server.scm delete mode 100644 src/scm/webid-oidc/reverse-proxy.scm delete mode 100644 src/scm/webid-oidc/token-endpoint.scm (limited to 'src/scm') diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 1d5066b..fe6b458 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -31,14 +31,9 @@ dist_webidoidcmod_DATA += \ %reldir%/authorization-code.scm \ %reldir%/refresh-token.scm \ %reldir%/oidc-id-token.scm \ - %reldir%/authorization-endpoint.scm \ - %reldir%/token-endpoint.scm \ - %reldir%/identity-provider.scm \ %reldir%/provider-confirmation.scm \ - %reldir%/resource-server.scm \ %reldir%/hello-world.scm \ %reldir%/program.scm \ - %reldir%/reverse-proxy.scm \ %reldir%/client.scm \ %reldir%/example-app.scm \ %reldir%/rdf-index.scm \ @@ -67,14 +62,9 @@ webidoidcgo_DATA += \ %reldir%/authorization-code.go \ %reldir%/refresh-token.go \ %reldir%/oidc-id-token.go \ - %reldir%/authorization-endpoint.go \ - %reldir%/token-endpoint.go \ - %reldir%/identity-provider.go \ %reldir%/provider-confirmation.go \ - %reldir%/resource-server.go \ %reldir%/hello-world.go \ %reldir%/program.go \ - %reldir%/reverse-proxy.go \ %reldir%/client.go \ %reldir%/example-app.go \ %reldir%/rdf-index.go \ diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm deleted file mode 100644 index 74417aa..0000000 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ /dev/null @@ -1,85 +0,0 @@ -;; disfluid, implementation of the Solid specification -;; Copyright (C) 2020, 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 authorization-endpoint) - #:use-module (webid-oidc errors) - #:use-module (webid-oidc server endpoint) - #:use-module (webid-oidc server endpoint identity-provider) - #:use-module (webid-oidc jwk) - #:use-module (webid-oidc authorization-code) - #:use-module (webid-oidc client-manifest) - #:use-module (webid-oidc web-i18n) - #:use-module ((webid-oidc parameters) #:prefix p:) - #:use-module (web uri) - #:use-module (web request) - #:use-module (web response) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:use-module (ice-9 receive) - #:use-module (ice-9 optargs) - #:use-module (ice-9 match) - #:use-module (sxml simple) - #:use-module (oop goops) - #:declarative? #t - #:duplicates (merge-generics) - #:export - ( - - make-authorization-endpoint - - )) - -(define (make-authorization-endpoint subject encrypted-password jwk-file) - (define endpoint - (make - #:subject subject - #:encrypted-password encrypted-password - #:key-file jwk-file)) - (lambda (request request-body) - (when (bytevector? request-body) - (set! request-body (utf8->string request-body))) - (parameterize ((web-locale request)) - (with-exception-handler - (lambda (exn) - (unless (web-exception? exn) - (raise-exception exn)) - (values - (build-response - #:code (web-exception-code exn) - #:reason-phrase (web-exception-reason-phrase exn) - #: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"))) - (body - ,(call-with-input-string - (format #f (W_ "

The authorization request failed

")) - xml->sxml) - ,(if (user-message? exn) - (user-message-sxml exn) - (call-with-input-string - (format #f (W_ "

No more information.

")) - xml->sxml))))) - <>)))) - (lambda () - (receive (response response-body response-meta) - (handle endpoint request request-body) - (values response response-body))) - #:unwind? #t)))) diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index ee0b72c..1948d86 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -62,10 +62,6 @@ #:export ( request - - serve-application - - ) #:declarative? #t) @@ -169,40 +165,3 @@ (scan-arguments args (or headers new-headers) non-header-args method)) ((kw value args ...) (scan-arguments args headers `(,value ,kw ,@non-header-args) method))))) - -(define* (serve-application id redirect-uri . args) - (let ((endpoint (apply make - #:client-id id - #:redirect-uris (list redirect-uri) - args))) - (lambda (request request-body) - (with-exception-handler - (lambda (exn) - (unless (web-exception? exn) - (raise-exception exn)) - (values - (build-response - #:code (web-exception-code exn) - #:reason-phrase (web-exception-reason-phrase exn) - #: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"))) - (body - ,(call-with-input-string - (format #f (W_ "

The request failed

")) - xml->sxml) - ,(if (user-message? exn) - (user-message-sxml exn) - (call-with-input-string - (format #f (W_ "

No more information.

")) - xml->sxml))))) - <>)))) - (lambda () - (receive (response response-body response-meta) - (handle endpoint request request-body) - (values response response-body))) - #:unwind? #t)))) diff --git a/src/scm/webid-oidc/hello-world.scm b/src/scm/webid-oidc/hello-world.scm index 4d97657..68d7644 100644 --- a/src/scm/webid-oidc/hello-world.scm +++ b/src/scm/webid-oidc/hello-world.scm @@ -17,7 +17,6 @@ (define-module (webid-oidc hello-world) #:use-module (webid-oidc server endpoint) #:use-module (webid-oidc server endpoint hello) - #:use-module (webid-oidc resource-server) #:use-module (webid-oidc server log) #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc config) #:prefix cfg:) diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm deleted file mode 100644 index 5970574..0000000 --- a/src/scm/webid-oidc/identity-provider.scm +++ /dev/null @@ -1,135 +0,0 @@ -;; disfluid, implementation of the Solid specification -;; Copyright (C) 2020, 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 identity-provider) - #:use-module (webid-oidc errors) - #:use-module (webid-oidc authorization-endpoint) - #:use-module (webid-oidc token-endpoint) - #:use-module (webid-oidc server endpoint) - #:use-module (webid-oidc server endpoint identity-provider) - #:use-module (webid-oidc oidc-configuration) - #:use-module (webid-oidc jwk) - #:use-module ((webid-oidc config) #:prefix cfg:) - #:use-module ((webid-oidc stubs) #:prefix stubs:) - #:use-module ((webid-oidc parameters) #:prefix p:) - #:use-module (webid-oidc jti) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (web server) - #:use-module (webid-oidc cache) - #:use-module (ice-9 optargs) - #:use-module (ice-9 receive) - #:use-module (webid-oidc web-i18n) - #:use-module (ice-9 getopt-long) - #:use-module (ice-9 suspendable-ports) - #:use-module (ice-9 match) - #:use-module (ice-9 exceptions) - #:use-module (sxml simple) - #:use-module (sxml match) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:use-module (rnrs bytevectors) - #:use-module (oop goops) - #:duplicates (merge-generics) - #:declarative? #t - #:export - ( - - make-identity-provider - - )) - -(define-class ()) - -(define-method (handle (endpoint ) request request-body) - (raise-exception - (make-exception - (make-web-exception 404 (W_ "reason-phrase|Not Found")) - (make-user-message - (call-with-input-string - (format #f (W_ "

Your request cannot be handled by the identity provider.

")) - xml->sxml))))) - -(define* (make-identity-provider - issuer - key-file - subject - encrypted-password - jwks-uri - authorization-endpoint-uri - token-endpoint-uri) - (let ((discovery - (make - #:path "/.well-known/openid-configuration" - #:configuration - (make - #:jwks-uri jwks-uri - #:authorization-endpoint authorization-endpoint-uri - #:token-endpoint token-endpoint-uri))) - (authz - (make - #:subject subject - #:encrypted-password encrypted-password - #:key-file key-file - #:path (uri-path authorization-endpoint-uri))) - (token - (make - #:path (uri-path token-endpoint-uri) - #:issuer issuer - #:key-file key-file)) - (jwks - (make - #:path (uri-path jwks-uri) - #:key-file key-file))) - (let ((idp (make - #:oidc-discovery discovery - #:authorization-endpoint authz - #:token-endpoint token - #:jwks-endpoint jwks - #:default (make )))) - (lambda (request request-body) - (parameterize ((web-locale request)) - (with-exception-handler - (lambda (exn) - (unless (web-exception? exn) - (raise-exception exn)) - (values - (build-response - #:code (web-exception-code exn) - #:reason-phrase (web-exception-reason-phrase exn) - #: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"))) - (body - ,(call-with-input-string - (format #f (W_ "

The identity provider request failed

")) - xml->sxml) - ,(if (user-message? exn) - (user-message-sxml exn) - (call-with-input-string - (format #f (W_ "

No more information.

")) - xml->sxml))))) - <>)))) - (lambda () - (receive (response response-body response-meta) - (handle idp request request-body) - (values response response-body))) - #:unwind? #t)))))) diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index 6a70cdc..319dd43 100644 --- a/src/scm/webid-oidc/program.scm +++ b/src/scm/webid-oidc/program.scm @@ -17,11 +17,9 @@ (define-module (webid-oidc program) #:use-module (webid-oidc errors) #:use-module (webid-oidc server log) - #:use-module (webid-oidc reverse-proxy) - #:use-module (webid-oidc identity-provider) #:use-module (webid-oidc client) - #:use-module (webid-oidc resource-server) #:use-module (webid-oidc server create) + #:use-module (webid-oidc server endpoint) #:use-module (webid-oidc jti) #:use-module (webid-oidc offloading) #:use-module (webid-oidc catalog) @@ -39,12 +37,15 @@ #:use-module (ice-9 textual-ports) #:use-module (ice-9 exceptions) #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (web uri) #:use-module (web request) #:use-module (web response) #:use-module (webid-oidc cache) - #:use-module (web server)) + #:use-module (web server) + #:use-module (sxml simple) + #:declarative? #f) (define logging-mutex (make-mutex)) @@ -82,20 +83,20 @@ (f)))) (define (setup-http-request f) - (let ((base-http-request (p:anonymous-http-request))) - (parameterize ((p:anonymous-http-request - (lambda* (uri . args) - (with-mutex logging-mutex - (format (current-output-port) - (G_ "~a: connecting to ~s\n") - (date->string (time-utc->date (current-time))) - (uri-host uri))) - (apply base-http-request uri args)))) - (use-cache - (lambda () - (use-catalog + (use-logging-request + (lambda () + (let ((base-http-request (p:anonymous-http-request))) + (parameterize ((p:anonymous-http-request + (lambda* (uri . args) + (with-mutex logging-mutex + (format (current-output-port) + (G_ "~a: connecting to ~s\n") + (date->string (time-utc->date (current-time))) + (uri-host uri))) + (apply base-http-request uri args)))) + (use-cache (lambda () - (use-logging-request + (use-catalog (lambda () (f)))))))))) @@ -107,8 +108,8 @@ (address (sockaddr:addr peer))) (inet-ntop family address))))) -(define (handler-with-log log-file error-file complete-corresponding-source handler) - (lambda (request request-body) +(define (handler-with-log endpoint log-file error-file complete-corresponding-source) + (lambda (request request-body . _) (when log-file (prepare-log-file log-file)) (when error-file @@ -126,80 +127,78 @@ ;; Fix the date (p:current-date ((p:current-date))) (web-locale request)) - (call/ec - (lambda (return) - (with-exception-handler - (lambda (error) - (unless (exception-with-message? error) - (let ((final-message - (format #f (G_ "really bad internal server error")))) - (raise-exception - (make-exception - (make-exception-with-message final-message) - error)))) - (with-mutex logging-mutex - (format (current-error-port) - (G_ "~a: ~a: Internal server error: ~a\n") - (date->string ((p:current-date))) - (request-ip-address request) - (exception-message error))) - (return - (build-response #:code 500 - #:reason-phrase (W_ "Internal Server Error") - #:headers `((source . ,complete-corresponding-source) - (date . ,((p:current-date))))) - (W_ "Sorry, there was an error."))) - (lambda () - (receive (response response-body user cause) - (call-with-values - (lambda () - (handler request request-body)) - (case-lambda - ((response response-body) - (values response response-body #f #f)) - ((response response-body user) - (values response response-body user #f)) - ((response response-body user cause) - (values response response-body user cause)))) - (let ((logging-port - (let ((response-code (response-code response))) - (if (>= response-code 400) - ;; That’s an error - (current-error-port) - (current-output-port))))) - (with-mutex logging-mutex - (format logging-port - (G_ "~a: ~s ~a ~s ~a\n") - (if user - (format #f (G_ "~a: ~a (~a)") - (date->string (time-utc->date (current-time))) - (uri->string user) - (request-ip-address request)) - (format #f (G_ "~a: ~a") - (date->string (time-utc->date (current-time))) - (request-ip-address request))) - (request-method request) - (uri-path (request-uri request)) - (response-code response) - (if (and cause (exception-with-message? cause)) - (string-append - (response-reason-phrase response) - " " - (format #f (G_ "(there was an error: ~a)") - (exception-message cause))) - (response-reason-phrase response))))) - (return - (build-response - #:version (response-version response) - #:code (response-code response) - #:reason-phrase (response-reason-phrase response) - #:headers `((source . ,complete-corresponding-source) - (date . ,((p:current-date))) - ,@(response-headers response)) - #:port (response-port response) - #:validate-headers? #t) - response-body))) - #:unwind? #t)))))) + (receive (response response-body user cause) + (call/ec + (lambda (return) + (with-exception-handler + (lambda (error) + (if (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_ "

Sorry, an error happened.

")) + xml->sxml) + ,(user-message-sxml error)))) + <>)) + (and (caused-by-user? error) + (caused-by-user-webid error)) + error) + ;; Other kind of exception + (raise-exception error))) + (lambda () + (receive (response response-body response-meta) + (handle endpoint request request-body) + (values response response-body (assq-ref response-meta 'user) #f))) + #:unwind? #t))) + (let ((logging-port + (let ((response-code (response-code response))) + (if (>= response-code 400) + ;; That’s an error + (current-error-port) + (current-output-port))))) + (with-mutex logging-mutex + (format logging-port + (G_ "~a: ~s ~a ~s ~a\n") + (if user + (format #f (G_ "~a: ~a (~a)") + (date->string (time-utc->date (current-time))) + (uri->string user) + (request-ip-address request)) + (format #f (G_ "~a: ~a") + (date->string (time-utc->date (current-time))) + (request-ip-address request))) + (request-method request) + (uri-path (request-uri request)) + (response-code response) + (if (and cause (exception-with-message? cause)) + (string-append + (response-reason-phrase response) + " " + (format #f (G_ "(there was an error: ~a)") + (exception-message cause))) + (response-reason-phrase response))))) + (values + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers `((source . ,complete-corresponding-source) + (date . ,((p:current-date))) + ,@(response-headers response)) + #:port (response-port response) + #:validate-headers? #t) + response-body))))) (define (serve-one-client* handler implementation server state) ;; Same as serve-one-client, except it is served in a promise. @@ -218,7 +217,7 @@ (define* (run-server* handler - #:optional + #:key (implementation 'http) (open-params '()) . state) @@ -246,34 +245,8 @@ (string->symbol (G_ "command-line|help"))) (port-sym (string->symbol (G_ "command-line|server|port"))) - (server-name-sym - (string->symbol (G_ "command-line|server|server-name"))) - (backend-uri-sym - (string->symbol (G_ "command-line|server|reverse-proxy|backend-uri"))) - (header-sym - (string->symbol (G_ "command-line|server|reverse-proxy|header"))) - (key-file-sym - (string->symbol (G_ "command-line|server|issuer|key-file"))) - (subject-sym - (string->symbol (G_ "command-line|server|issuer|subject"))) - (encrypted-password-sym - (string->symbol (G_ "command-line|server|issuer|encrypted-password"))) - (encrypted-password-from-file-sym - (string->symbol (G_ "command-line|server|issuer|encrypted-password-from-file"))) - (jwks-uri-sym - (string->symbol (G_ "command-line|server|issuer|jwks-uri"))) - (authorization-endpoint-uri-sym - (string->symbol (G_ "command-line|server|issuer|authorization-endpoint-uri"))) - (token-endpoint-uri-sym - (string->symbol (G_ "command-line|server|issuer|token-endpoint-uri"))) - (client-id-sym - (string->symbol (G_ "command-line|server|client-id"))) - (redirect-uri-sym - (string->symbol (G_ "command-line|server|redirect-uri"))) - (client-name-sym - (string->symbol (G_ "command-line|server|client-name"))) - (client-uri-sym - (string->symbol (G_ "command-line|server|client-uri"))) + (configuration-sym + (string->symbol (G_ "command-line|server|configuration"))) (log-file-sym (string->symbol (G_ "command-line|log-file"))) (error-file-sym @@ -289,30 +262,17 @@ (,help-sym (single-char #\h) (value #f)) (,log-file-sym (single-char #\l) (value #t)) (,error-file-sym (single-char #\e) (value #t)) - (,key-file-sym (single-char #\k) (value #t)) - (,subject-sym (single-char #\s) (value #t)) - (,encrypted-password-sym (single-char #\w) (value #t)) - (,encrypted-password-from-file-sym (single-char #\W) (value #t)) - (,jwks-uri-sym (single-char #\j) (value #t)) - (,authorization-endpoint-uri-sym (single-char #\a) (value #t)) - (,token-endpoint-uri-sym (single-char #\t) (value #t)) - (,client-id-sym (single-char #\c) (value #t)) - (,redirect-uri-sym (single-char #\r) (value #t)) - (,client-name-sym (single-char #\C) (value #t)) - (,client-uri-sym (single-char #\u) (value #t)) - (,port-sym (single-char #\p) (value #t)) - (,server-name-sym (single-char #\n) (value #t)) - (,header-sym (single-char #\H) (value #t)) - (,backend-uri-sym (single-char #\b) (value #t))))) + (,configuration-sym (single-char #\c) (value #t)) + (,port-sym (single-char #\p) (value #t))))) (getopt-long (command-line) spec)))) (cond ((option-ref options help-sym #f) - (format #t (G_ "Usage: ~a COMMAND [OPTIONS]... + (format #t (G_ "Usage: ~a [OPTIONS]... ") (car (command-line))) (format #t (G_ " -Run the disfluid COMMAND.")) +Run disfluid.")) (format #t "\n") (format #t (G_ " This program is covered by the GNU Affero GPL, version 3 or @@ -321,37 +281,10 @@ the network to download the complete corresponding source code (with your modifications) at no cost. The server adds a \"Source:\" header to all responses.")) (format #t "\n") - (format #t (G_ " -Available commands:")) - (format #t (G_ " - ~a: - run an authenticating reverse proxy.") - (G_ "command-line|command|reverse-proxy")) - (format #t (G_ " - ~a: - run an identity provider.") - (G_ "command-line|command|identity-provider")) - (format #t (G_ " - ~a: - serve the pages for a public application.") - (G_ "command-line|command|client-service")) - (format #t (G_ " - ~a: - run a full server, with identity provider and resource storage - facility.") - (G_ "command-line|command|server")) - (format #t "\n") - (format #t (G_ " -If no command is specified, run the browser.")) (format #t "\n") (format #t (G_ " General options:")) (format #t (G_ " - -S MEANS, --~a=MEANS: - specify a way to download the complete corresponding source - code. For instance, this would be an URI pointing to a tarball.") - complete-corresponding-source-sym) - (format #t (G_ " -h, --~a: display a short help message and exit.") help-sym) @@ -375,83 +308,21 @@ General options:")) error-file-sym) (format #t "\n") (format #t (G_ " -General server-side options:")) +Running a server:")) + (format #t (G_ " + -S MEANS, --~a=MEANS: + specify a way to download the complete corresponding source + code. For instance, this would be an URI pointing to a + tarball. This option is required if a server is implemented.") + complete-corresponding-source-sym) (format #t (G_ " -p PORT, --~a=PORT: set the server port to bind, 8080 by default.") port-sym) (format #t (G_ " - -n URI, --~a=URI: - set the public server URI (scheme, userinfo, host, and port).") - server-name-sym) - (format #t "\n") - (format #t (G_ " -Options for the resource server:")) - (format #t (G_ " - -H HEADER, --~a=HEADER: - the HEADER field contains the webid of the authenticated user, - XXX-Agent by default. For the full server, disable Solid-OIDC - authentication.") - header-sym) - (format #t (G_ " - -b URI, --~a=URI: - set the backend URI for the reverse proxy, only for the - reverse-proxy command.") - backend-uri-sym) - (format #t "\n") - (format #t (G_ " -Options for the identity provider:")) - (format #t (G_ " - -k FILE, --~a=FILE.jwk: - set the file name of the key file. If it does not exist, a new - key is generated. The server does not offer an HTTPS service.") - key-file-sym) - (format #t (G_ " - -s WEBID, --~a=WEBID: - set the identity of the subject.") - subject-sym) - (format #t (G_ " - -w ENCRYPTED_PASSWORD, --~a=ENCRYPTED_PASSWORD: - set the encrypted password to recognize the user.") - encrypted-password-sym) - (format #t (G_ " - -W ENCRYPTED_PASSWORD_FILE, --~a=ENCRYPTED_PASSWORD_FILE: - load the user’s encrypted password from ENCRYPTED_PASSWORD_FILE.") - encrypted-password-from-file-sym) - (format #t (G_ " - -j URI, --~a=URI: - set the URI to query the key of the server.") - jwks-uri-sym) - (format #t (G_ " - -a URI, --~a=URI: - set the authorization endpoint of the issuer.") - authorization-endpoint-uri-sym) - (format #t (G_ " - -t URI, --~a=URI: - set the token endpoint of the issuer.") - token-endpoint-uri-sym) - (format #t "\n") - (format #t (G_ " -Options for the client service:")) - (format #t (G_ " - -c URI, --~a=URI: - set the web identifier of the client application, which is - dereferenced to a semantic resource.") - client-id-sym) - (format #t (G_ " - -r URI, --~a=URI: - set the redirection URI to get the authorization code back. The - page is presented with the code to paste in the application.") - redirect-uri-sym) - (format #t (G_ " - -C NAME, --~a=NAME: - set the user-visible application name (may be misleading...).") - client-name-sym) - (format #t (G_ " - -u URI, --~a=URI: - set an URI where someone would find more information about the - application (again, may be misleading).") - client-uri-sym) + -c FILE, --~a=FILE: + set up a server with configuration from FILE.") + configuration-sym) (format #t "\n") (format #t (G_ " Environment variables:")) @@ -499,110 +370,6 @@ Environment variables:")) It is currently set to ~s.") (getenv "HOME"))) (format #t "\n") - (format #t (G_ " -Running a reverse proxy")) - (format #t (G_ " -Suppose that you operate data.provider.com. You want to run an -authenticating reverse proxy, that will receive incoming requests -through http://localhost:8080, and forward them to -https://private.data.provider.com. The backend will look for the -XXX-Agent header, and if it is found, then its value will be -considered the webid of the authenticated -user. https://private.data.provider.com should only accept requests -from this reverse proxy.")) - (format #t "\n") - (format #t (G_ " - ~a ~a \\ - --~a 'https://data.provider.com/server-source-code.tar.gz' \\ - --~a 8080 \\ - --~a 'https://data.provider.com' \\ - --~a 'https://private.data.provider.com' \\ - --~a 'XXX-Agent' \\ - --~a '/var/log/proxy.log' \\ - --~a '/var/log/proxy.err'") - (car (command-line)) - (G_ "command-line|command|reverse-proxy") - complete-corresponding-source-sym - port-sym server-name-sym backend-uri-sym header-sym - log-file-sym error-file-sym) - (format #t "\n") - (format #t (G_ " -Running an identity provider")) - (format #t (G_ " -The identity provider running at webid-oidc-demo.planete-kraus.eu is -invoked with the following options:")) - (format #t "\n") - (format #t (G_ " - export XDG_DATA_HOME=/var/lib - export XDG_CACHE_HOME=/var/cache - ~a ~a \\ - --~a 'https://webid-oidc.planete-kraus.eu/complete-corresponding-source.tar.gz' \\ - --~a 'https://webid-oidc-demo.planete-kraus.eu' \\ - --~a '/var/lib/webid-oidc/issuer/key.jwk' \\ - --~a 'https://webid-oidc-demo.planete-kraus.eu/profile/card#me' \\ - --~a '/etc/disfluid/webid-oidc-demo.planete-kraus.eu/password' \\ - --~a 'https://webid-oidc-demo.planete-kraus.eu/keys' \\ - --~a 'https://webid-oidc-demo.planete-kraus.eu/authorize' \\ - --~a 'https://webid-oidc-demo.planete-kraus.eu/token' \\ - --~a $PORT") - (car (command-line)) - (G_ "command-line|command|identity-provider") - complete-corresponding-source-sym - server-name-sym key-file-sym subject-sym encrypted-password-from-file-sym - jwks-uri-sym authorization-endpoint-uri-sym - token-endpoint-uri-sym port-sym) - (format #t "\n") - (format #t (G_ " -Running the public pages for an application")) - (format #t (G_ " -The example client application pages for -webid-oidc-demo.planete-kraus.eu are served this way:")) - (format #t "\n") - (format #t (G_ " - ~a ~a \\ - --~a 'https://webid-oidc.planete-kraus.eu/complete-corresponding-source.tar.gz' \\ - --~a 'https://webid-oidc-demo.planete-kraus.eu/example-application#id' \\ - --~a 'https://webid-oidc-demo.planete-kraus.eu/authorized' \\ - --~a 'Example Solid Application' \\ - --~a 'https://webid-oidc.planete-kraus.eu/Running-a-client.html#Running-a-client' \\ - --~a $PORT") - (car (command-line)) - (G_ "command-line|command|client-service") - complete-corresponding-source-sym - client-id-sym redirect-uri-sym client-name-sym client-uri-sym - port-sym) - (format #t "\n") - (format #t (G_ " -Running a full server")) - (format #t "\n") - (format #t (G_ " -To run the server with identity provider and -resource server for one particular user, you need to combine the -options for the parts.")) - (format #t (G_ " - export XDG_DATA_HOME=/var/lib - export XDG_CACHE_HOME=/var/cache - ~a ~a \\ - --~a 'https://webid-oidc.planete-kraus.eu/complete-corresponding-source.tar.gz' \\ - --~a 'https://data.planete-kraus.eu' \\ - --~a '/var/lib/disfluid/server/key.jwk' \\ - --~a 'https://data.planete-kraus.eu/vivien#me' \\ - --~a '/etc/disfluid/data.planete-kraus.eu/password' \\ - --~a 'https://data.planete-kraus.eu/keys' \\ - --~a 'https://data.planete-kraus.eu/authorize' \\ - --~a 'https://data.planete-kraus.eu/token' \\ - --~a '...port...'") - (car (command-line)) - (G_ "command-line|command|server") - complete-corresponding-source-sym - server-name-sym - key-file-sym - subject-sym - encrypted-password-from-file-sym - jwks-uri-sym - authorization-endpoint-uri-sym - token-endpoint-uri-sym - port-sym) (format #t "\n") (format #t (G_ " If you find a bug, then please send a report to ~a.") @@ -634,14 +401,12 @@ Rreleased ~a\n") cfg:version (date->string cfg:release-date "~1"))) (else - (let ((rest (option-ref options '() '())) - (complete-corresponding-source - (let ((str (option-ref options complete-corresponding-source-sym #f))) - (unless (or (null? (option-ref options '() '())) str) - (format (current-error-port) - (G_ "You are legally required to link to the complete corresponding source code.\n")) - (exit 1)) - str)) + (let ((complete-corresponding-source + (option-ref options complete-corresponding-source-sym #f)) + (log-file-name + (option-ref options log-file-sym #f)) + (error-file-name + (option-ref options error-file-sym #f)) (port (let ((port (string->number (option-ref options port-sym "8080")))) (unless port @@ -667,220 +432,27 @@ Rreleased ~a\n") port-sym port) (exit 1)) port)) - (server-name - (let ((str (option-ref options server-name-sym #f))) - (and str - (string->uri str)))) - (backend-uri - (let ((str (option-ref options backend-uri-sym #f))) - (and str - (string->uri str)))) - (header - (let ((str (option-ref options header-sym #f))) - (and str - (string->symbol str)))) - (key-file (option-ref options key-file-sym #f)) - (subject - (let ((str (option-ref options subject-sym #f))) - (and str (string->uri str)))) - (encrypted-password - (let ((direct (option-ref options encrypted-password-sym #f)) - (from-file - (let ((filename (option-ref options encrypted-password-from-file-sym #f))) - (and filename - (call-with-input-file filename get-line))))) - (when (and direct from-file (not (equal? direct from-file))) - (format (current-error-port) - (G_ "You specified two different passwords: one directly, and one from a file. Please set only one password.\n")) - (exit 1)) - (or direct from-file))) - (jwks-uri - (let ((str (option-ref options jwks-uri-sym #f))) - (and str (string->uri str)))) - (authorization-endpoint-uri - (let ((str (option-ref options authorization-endpoint-uri-sym #f))) - (and str (string->uri str)))) - (token-endpoint-uri - (let ((str (option-ref options token-endpoint-uri-sym #f))) - (and str (string->uri str)))) - (client-id - (let ((str (option-ref options client-id-sym #f))) - (and str (string->uri str)))) - (redirect-uri - (let ((str (option-ref options redirect-uri-sym #f))) - (and str (string->uri str)))) - (client-name - (option-ref options client-name-sym #f)) - (client-uri - (option-ref options client-uri-sym #f))) - (when (null? rest) - (eval - '(main) - (resolve-module '(webid-oidc client gui))) - (exit 0)) - (let ((command (car rest)) - (non-options (cdr rest))) - (cond - ((equal? command (G_ "command-line|command|reverse-proxy")) - (begin - (unless server-name - (format (current-error-port) (G_ "You must pass --~a to set the server name.\n") - server-name-sym) - (exit 1)) - (unless backend-uri - (format (current-error-port) (G_ "You must pass --~a to set the backend URI.\n") - backend-uri-sym) - (exit 1)) - (run-server* - (handler-with-log - (option-ref options log-file-sym #f) - (option-ref options error-file-sym #f) - complete-corresponding-source - (make-reverse-proxy - #:server-uri server-name - #:endpoint backend-uri - #:auth-header header)) - 'http - (list #:port port)))) - ((equal? command (G_ "command-line|command|identity-provider")) + (configuration + (let ((file-name (option-ref options configuration-sym #f))) + (and file-name + (load file-name))))) + (if configuration (begin - (unless server-name - (format (current-error-port) (G_ "You must pass --~a to set the server name.\n") - server-name-sym) - (exit 1)) - (unless key-file - (format (current-error-port) (G_ "You must pass --~a to set the file where to store the identity provider key.\n") - key-file-sym) - (exit 1)) - (unless subject - (format (current-error-port) (G_ "You must pass --~a to set the subject of the identity provider.\n") - subject-sym) - (exit 1)) - (unless encrypted-password - (format (current-error-port) (G_ "You must pass --~a or --~a to set the subject’s encrypted password.\n") - encrypted-password-sym encrypted-password-from-file-sym) - (exit 1)) - (unless jwks-uri - (format (current-error-port) (G_ "You must pass --~a to set the JWKS URI.\n") - jwks-uri-sym) - (exit 1)) - (unless authorization-endpoint-uri - (format (current-error-port) (G_ "You must pass --~a to set the authorization endpoint URI.\n") - authorization-endpoint-uri-sym) - (exit 1)) - (unless token-endpoint-uri - (format (current-error-port) (G_ "You must pass --~a to set the token endpoint URI.\n") - token-endpoint-uri-sym) - (exit 1)) - (let ((handler - (make-identity-provider - server-name key-file subject encrypted-password jwks-uri - authorization-endpoint-uri token-endpoint-uri))) - (run-server* - (handler-with-log - (option-ref options log-file-sym #f) - (option-ref options error-file-sym #f) - complete-corresponding-source handler) - 'http - (list #:port port))))) - ((equal? command (G_ "command-line|command|client-service")) - (begin - (unless client-id - (format (current-error-port) (G_ "You must pass --~a to set the application web ID.\n") - client-id-sym) - (exit 1)) - (unless redirect-uri - (format (current-error-port) (G_ "You must pass --~a to set the redirection URI.\n") - redirect-uri-sym) - (exit 1)) - (unless client-name - (format (current-error-port) (G_ "You must pass --~a to set the informative client name.\n") - client-name-sym) - (exit 1)) - (unless client-uri - (format (current-error-port) (G_ "You must pass --~a to set the informative client URI.\n") - client-uri-sym) + (unless complete-corresponding-source + (format (current-error-port) + (G_ "--~a is required when running a server.\n") + complete-corresponding-source-sym) (exit 1)) - (let ((handler - (serve-application client-id redirect-uri - #:client-name client-name - #:client-uri client-uri))) - (run-server* - (handler-with-log - (option-ref options log-file-sym #f) - (option-ref options error-file-sym #f) - complete-corresponding-source handler) - 'http - (list #:port port))))) - ((equal? command (G_ "command-line|command|server")) - (unless server-name - (format (current-error-port) (G_ "You must pass --~a to set the server name.\n") - server-name-sym) - (exit 1)) - (unless key-file - (format (current-error-port) (G_ "You must pass --~a to set the file where to store the identity provider key.\n") - key-file-sym) - (exit 1)) - (unless subject - (format (current-error-port) (G_ "You must pass --~a to set the subject of the identity provider.\n") - subject-sym) - (exit 1)) - (unless encrypted-password - (format (current-error-port) (G_ "You must pass --~a to set the subject’s encrypted password.\n") - encrypted-password-sym) - (exit 1)) - (unless jwks-uri - (format (current-error-port) (G_ "You must pass --~a to set the JWKS URI.\n") - jwks-uri-sym) - (exit 1)) - (unless authorization-endpoint-uri - (format (current-error-port) (G_ "You must pass --~a to set the authorization endpoint URI.\n") - authorization-endpoint-uri-sym) - (exit 1)) - (unless token-endpoint-uri - (format (current-error-port) (G_ "You must pass --~a to set the token endpoint URI.\n") - token-endpoint-uri-sym) - (exit 1)) - (let ((resource-handler - (make-resource-server - #:server-uri server-name - #:owner subject - #:authenticator - (if header - (begin - (set! header - (string->symbol - (string-downcase - (symbol->string header)))) - (lambda (request request-body) - (let ((value (assq-ref (request-headers request) header))) - (and value (string->uri value))))) - (make-authenticator - #:server-uri server-name)))) - (identity-provider-handler - (make-identity-provider - server-name key-file subject encrypted-password jwks-uri - authorization-endpoint-uri token-endpoint-uri))) - (create-root server-name subject) (run-server* - (handler-with-log - (option-ref options log-file-sym #f) - (option-ref options error-file-sym #f) - complete-corresponding-source - (lambda (request request-body) - (let ((path (uri-path (request-uri request)))) - (if (or (equal? path "/.well-known/openid-configuration") - (equal? path (uri-path jwks-uri)) - (equal? path (uri-path authorization-endpoint-uri)) - (equal? path (uri-path token-endpoint-uri))) - (identity-provider-handler request request-body) - (resource-handler request request-body))))) - 'http - (list #:port port)))) - (else - (format (current-error-port) (G_ "Unknown command ~s\n") - command) - (exit 1)))))))))) + (handler-with-log configuration + log-file-name + error-file-name + complete-corresponding-source) + #:implementation 'http + #:open-params (list #:port port))) + (eval + '(main) + (resolve-module '(webid-oidc client gui)))))))))) (define-public (main) (setup-http-request inner-main)) diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm deleted file mode 100644 index 95fa78a..0000000 --- a/src/scm/webid-oidc/resource-server.scm +++ /dev/null @@ -1,139 +0,0 @@ -;; disfluid, implementation of the Solid specification -;; Copyright (C) 2020, 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 resource-server) - #:use-module (webid-oidc errors) - #:use-module (webid-oidc provider-confirmation) - #:use-module (webid-oidc jwk) - #:use-module (webid-oidc dpop-proof) - #:use-module (webid-oidc serve) - #:use-module (webid-oidc server endpoint) - #:use-module (webid-oidc server endpoint authentication) - #:use-module (webid-oidc server endpoint resource-server) - #:use-module ((webid-oidc server create) #:prefix ldp:) - #:use-module ((webid-oidc server read) #:prefix ldp:) - #:use-module ((webid-oidc server update) #:prefix ldp:) - #:use-module ((webid-oidc server delete) #:prefix ldp:) - #:use-module ((webid-oidc server resource wac) #:prefix wac:) - #:use-module ((webid-oidc server resource path) #:prefix ldp:) - #:use-module ((webid-oidc server resource content) #:prefix ldp:) - #:use-module (webid-oidc server precondition) - #:use-module (webid-oidc server endpoint) - #:use-module (webid-oidc server endpoint authentication) - #:use-module (webid-oidc http-link) - #:use-module ((webid-oidc parameters) #:prefix p:) - #:use-module ((webid-oidc config) #:prefix cfg:) - #:use-module (webid-oidc jti) - #:use-module (webid-oidc access-token) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (web server) - #:use-module (ice-9 optargs) - #:use-module (ice-9 receive) - #:use-module (webid-oidc web-i18n) - #:use-module (ice-9 getopt-long) - #:use-module (ice-9 suspendable-ports) - #:use-module (ice-9 control) - #:use-module (ice-9 match) - #:use-module (ice-9 exceptions) - #:use-module (sxml simple) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:use-module (oop goops) - #:duplicates (merge-generics) - #:declarative? #t - #:export - ( - make-authenticator - make-resource-server - )) - -(define-class ()) - -(define return - (make-parameter #f)) - -(define-method (handle (endpoint ) request request-body) - ((return) (assq-ref (request-meta request) 'user))) - -(define* (make-authenticator #:key (server-uri #f)) - (unless (and server-uri (uri? server-uri)) - (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))) - (let* ((backend (make )) - (endpoint (make - #:backend backend - #:server-uri server-uri))) - (lambda (request request-body) - (parameterize ((web-locale request)) - (with-exception-handler - (lambda (error) - #f) - (lambda () - (let/ec ret - (parameterize ((return ret)) - (handle endpoint request request-body)))) - #:unwind? #t))))) - -(define* (make-resource-server - #:key - (server-uri #f) - (owner #f) - (authenticator #f)) - (unless owner - (fail (G_ "The owner is not defined."))) - (declare-link-header!) - (define resource-server - (make - #:server-name server-uri - #:owner owner)) - (define authenticator - (make - #:backend resource-server - #:server-uri server-uri)) - (lambda (request request-body) - (let/ec return - (parameterize ((web-locale request)) - (with-exception-handler - (lambda (exn) - (unless (web-exception? exn) - (raise-exception exn)) - (return - (build-response - #:code (web-exception-code exn) - #:reason-phrase (web-exception-reason-phrase exn) - #: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"))) - (body - ,(call-with-input-string - (format #f (W_ "

The resource server request failed

")) - xml->sxml) - ,(if (user-message? exn) - (user-message-sxml exn) - (call-with-input-string - (format #f (W_ "

No more information.

")) - xml->sxml))))) - <>)))) - (lambda () - (receive (response response-body response-meta) - (handle authenticator request request-body) - (return response response-body))) - #:unwind? #t))))) diff --git a/src/scm/webid-oidc/reverse-proxy.scm b/src/scm/webid-oidc/reverse-proxy.scm deleted file mode 100644 index 4221fa5..0000000 --- a/src/scm/webid-oidc/reverse-proxy.scm +++ /dev/null @@ -1,90 +0,0 @@ -;; disfluid, implementation of the Solid specification -;; Copyright (C) 2020, 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 reverse-proxy) - #:use-module (webid-oidc errors) - #:use-module ((webid-oidc stubs) #:prefix stubs:) - #:use-module (webid-oidc resource-server) - #:use-module ((webid-oidc config) #:prefix cfg:) - #:use-module ((webid-oidc parameters) #:prefix p:) - #:use-module (ice-9 optargs) - #:use-module (ice-9 receive) - #:use-module (ice-9 i18n) - #:use-module (ice-9 getopt-long) - #:use-module (ice-9 suspendable-ports) - #:use-module (srfi srfi-19) - #:use-module (rnrs bytevectors) - #:use-module (web uri) - #:use-module (web client) ;; required to pass the request along - #:use-module (web request) - #:use-module (web response) - #:use-module (webid-oidc cache) - #:use-module (webid-oidc web-i18n) - #:use-module (web server) - #:use-module (webid-oidc server endpoint) - #:use-module (webid-oidc server endpoint reverse-proxy) - #:declarative? #t - #:export - ( - make-reverse-proxy - )) - -(define* (make-reverse-proxy - #:key - (server-uri #f) - (endpoint #f) - (auth-header 'XXX-Agent)) - (set! auth-header - ;; We need to remove the lowercase version of auth-header from - ;; all incoming requests! - (string->symbol - (string-downcase - (symbol->string auth-header)))) - (define authenticate - (make-authenticator - #:server-uri server-uri)) - (unless (and endpoint (uri? endpoint)) - (fail (G_ "#:endpoint argument is not present or not an URI."))) - (define backend - (make - #:backend-uri endpoint - #:authentication-header auth-header)) - (lambda (request request-body) - (let ((agent - (catch #t - (lambda () - (authenticate request request-body)) - (lambda (key . args) - (case key - ((invalid-access-token - invalid-proof - unconfirmed-issuer) - #f) - (else - (apply throw key args)))))) - (request-time ((p:current-date)))) - (parameterize ((p:current-date request-time) - (web-locale request)) - (set! request - (build-request (request-uri request) - #:method (request-method request) - #:version (request-version request) - #:headers (request-headers request) - #:port (request-port request) - #:meta `((user . ,agent) ,@(request-meta request)))) - (receive (response response-body response-meta) - (handle backend request request-body) - (values response response-body)))))) 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 ( - make-simulation - simulation? - simulation-scroll-log! + endpoint + log + + 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-class () + (endpoint #:init-keyword #:endpoint #:getter endpoint) + (log-rev #:getter log-rev #:init-value '())) -(define (make-simulation) - (make-full-simulation '() '())) +(define-method (log (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 )) + (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_ "

Sorry, an error happened.

")) + 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)))) diff --git a/src/scm/webid-oidc/testing.scm b/src/scm/webid-oidc/testing.scm index c26ab5e..f594b6d 100644 --- a/src/scm/webid-oidc/testing.scm +++ b/src/scm/webid-oidc/testing.scm @@ -20,7 +20,6 @@ #:use-module (srfi srfi-9) #:use-module (ice-9 optargs) #:use-module (webid-oidc parameters) - #:use-module (webid-oidc resource-server) #:use-module (webid-oidc refresh-token) #:use-module (webid-oidc client)) diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm deleted file mode 100644 index f96e768..0000000 --- a/src/scm/webid-oidc/token-endpoint.scm +++ /dev/null @@ -1,94 +0,0 @@ -;; disfluid, implementation of the Solid specification -;; Copyright (C) 2020, 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 token-endpoint) - #:use-module (webid-oidc server endpoint identity-provider) - #:use-module (webid-oidc errors) - #:use-module (webid-oidc server endpoint) - #:use-module (webid-oidc authorization-code) - #:use-module (webid-oidc dpop-proof) - #:use-module (webid-oidc jws) - #:use-module (webid-oidc jwk) - #:use-module (webid-oidc oidc-id-token) - #:use-module (webid-oidc access-token) - #:use-module (webid-oidc web-i18n) - #:use-module ((webid-oidc parameters) #:prefix p:) - #:use-module ((webid-oidc stubs) #:prefix stubs:) - #:use-module ((webid-oidc refresh-token) #:prefix refresh:) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (ice-9 optargs) - #:use-module (ice-9 receive) - #:use-module (ice-9 control) - #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:use-module (rnrs bytevectors) - #:use-module (sxml simple) - #:use-module (sxml match) - #:use-module (oop goops) - #:duplicates (merge-generics) - #:declarative? #t - #:export - ( - make-token-endpoint - )) - -(define (try-handle-web-failure thunk) - (call/ec - (lambda (return) - (with-exception-handler - (lambda (error) - (unless (web-exception? error) - (raise-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"))) - (body - ,(call-with-input-string - (format #f (W_ "

The token request failed

")) - xml->sxml) - ,(if (user-message? error) - (user-message-sxml error) - (call-with-input-string - (format #f (W_ "

No more information.

")) - xml->sxml))))) - <>)))) - thunk)))) - -(define (make-token-endpoint token-endpoint-uri iss issuer-key-file) - (define endpoint - (make - #:issuer iss - #:key-file issuer-key-file)) - (lambda (request request-body) - (when (bytevector? request-body) - (set! request-body (utf8->string request-body))) - (try-handle-web-failure - (lambda () - (parameterize ((web-locale request)) - (receive (response response-body response-meta) - (handle endpoint request request-body) - (values response response-body))))))) -- cgit v1.2.3