diff options
Diffstat (limited to 'src/scm/webid-oidc/program.scm')
| -rw-r--r-- | src/scm/webid-oidc/program.scm | 694 |
1 files changed, 133 insertions, 561 deletions
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_ "<p>Sorry, an error happened.</p>")) + 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)) |