diff options
Diffstat (limited to 'src/scm/webid-oidc/program.scm')
-rw-r--r-- | src/scm/webid-oidc/program.scm | 140 |
1 files changed, 100 insertions, 40 deletions
diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm index 2ab1cbe..a9c1a0f 100644 --- a/src/scm/webid-oidc/program.scm +++ b/src/scm/webid-oidc/program.scm @@ -1,3 +1,19 @@ +;; webid-oidc, 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 <https://www.gnu.org/licenses/>. + (define-module (webid-oidc program) #:use-module (webid-oidc errors) #:use-module (webid-oidc reverse-proxy) @@ -13,6 +29,7 @@ #:use-module (ice-9 i18n) #:use-module (ice-9 getopt-long) #:use-module (ice-9 suspendable-ports) + #:use-module (ice-9 control) #:use-module (srfi srfi-19) #:use-module (rnrs bytevectors) #:use-module (web uri) @@ -45,31 +62,44 @@ (define cache-http-get (with-cache #:http-get http-get-with-log)) -(define (handler-with-log handler) +(define (handler-with-log complete-corresponding-source handler) (lambda (request request-body) - (with-exception-handler - (lambda (error) - (format (current-error-port) - (G_ "~a: Internal server error: ~a\n") - (date->string (time-utc->date (current-time))) - (error->str error)) - (values - (build-response #:code 500 - #:reason-phrase "Internal Server Error") - "Sorry, there was an error.")) - (lambda () - (with-exception-handler - (lambda (error) - (format (current-error-port) - (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n") - ((record-accessor &unknown-client-locale 'web-locale) error) - ((record-accessor &unknown-client-locale 'c-locale) error) - (error->str error))) - (lambda () - (handler request request-body)) - #:unwind? #t - #:unwind-for-type &unknown-client-locale)) - #:unwind? #t))) + (call/ec + (lambda (return) + (with-exception-handler + (lambda (error) + (format (current-error-port) + (G_ "~a: Internal server error: ~a\n") + (date->string (time-utc->date (current-time))) + (error->str error)) + (return + (build-response #:code 500 + #:reason-phrase "Internal Server Error" + #:headers `((source . ,complete-corresponding-source))) + "Sorry, there was an error.")) + (lambda () + (with-exception-handler + (lambda (error) + (format (current-error-port) + (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n") + ((record-accessor &unknown-client-locale 'web-locale) error) + ((record-accessor &unknown-client-locale 'c-locale) error) + (error->str error))) + (lambda () + (receive (response response-body) + (handler request request-body) + (return + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers (cons `(source . ,complete-corresponding-source) + (response-headers response)) + #:port (response-port response) + #:validate-headers? #t) + response-body))) + #:unwind? #t + #:unwind-for-type &unknown-client-locale))))))) (define-public (main) (setvbuf (current-output-port) 'none) @@ -79,6 +109,8 @@ (textdomain cfg:package) (let ((version-sym (string->symbol (G_ "command-line|version"))) + (complete-corresponding-source-sym + (string->symbol (G_ "command-line|complete-corresponding-source"))) (help-sym (string->symbol (G_ "command-line|help"))) (port-sym @@ -115,7 +147,8 @@ (string->symbol (G_ "command-line|error-file")))) (let ((options (let ((spec - `((,version-sym (single-char #\v) (value #f)) + `((,complete-corresponding-source-sym (single-char #\S) (value #t)) + (,version-sym (single-char #\v) (value #f)) (,help-sym (single-char #\h) (value #f)) (,log-file-sym (single-char #\l) (value #t)) (,error-file-sym (single-char #\e) (value #t)) @@ -140,6 +173,12 @@ Run the webid-oidc COMMAND. +This program is covered by the GNU Affero GPL, version 3 or +later. This license requires you to provide a way for any user over +the network to download the complete corresponding source code (with +your modifications) at no cost. The server adds a \"Source:\" header +to all responses. + Available commands: ~a: run an authenticating reverse proxy. @@ -152,6 +191,9 @@ Available commands: facility. General options: + -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. -h, --~a: display a short help message and exit. -v, --~a: @@ -234,6 +276,7 @@ user. https://private.data.provider.com should only accept requests from this reverse proxy. ~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' \\ @@ -249,6 +292,7 @@ invoked with the following options: 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' \\ @@ -263,6 +307,7 @@ Running the public pages for an application webid-oidc-demo.planete-kraus.eu is configured this way: ~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' \\ @@ -279,6 +324,7 @@ If you find a bug, then please send a report to ~a. (G_ "command-line|command|client-service") (G_ "command-line|command|server") ;; General options + complete-corresponding-source-sym ;; help help-sym ;; version @@ -333,17 +379,20 @@ If you find a bug, then please send a report to ~a. ;; command (G_ "command-line|command|reverse-proxy") ;; options + complete-corresponding-source-sym port-sym server-name-sym backend-uri-sym header-sym log-file-sym error-file-sym ;; Running an identity provider (car (command-line)) (G_ "command-line|command|identity-provider") + complete-corresponding-source-sym server-name-sym key-file-sym subject-sym password-sym jwks-uri-sym authorization-endpoint-uri-sym token-endpoint-uri-sym port-sym ;; Running the public pages for an application (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 ;; Bug report @@ -353,6 +402,13 @@ If you find a bug, then please send a report to ~a. cfg:package cfg:version)) (else (let ((rest (option-ref options '() '())) + (complete-corresponding-source + (let ((str (option-ref options complete-corresponding-source-sym #f))) + (unless str + (format (current-error-port) + (G_ "You are legally required to link to the complete corresponding source code.\n")) + (exit 1)) + str)) (port (let ((port (string->number (option-ref options port-sym "8080")))) (unless port @@ -443,11 +499,13 @@ If you find a bug, then please send a report to ~a. backend-uri-sym) (exit 1)) (run-server - (make-reverse-proxy - #:server-uri server-name - #:http-get cache-http-get - #:endpoint backend-uri - #:auth-header header) + (handler-with-log + complete-corresponding-source + (make-reverse-proxy + #:server-uri server-name + #:http-get cache-http-get + #:endpoint backend-uri + #:auth-header header)) 'http (list #:port port)))) ((equal? command (G_ "command-line|command|identity-provider")) @@ -488,7 +546,7 @@ If you find a bug, then please send a report to ~a. #:current-time current-time #:http-get cache-http-get))) (run-server - (handler-with-log handler) + (handler-with-log complete-corresponding-source handler) 'http (list #:port port))))) ((equal? command (G_ "command-line|command|client-service")) @@ -514,7 +572,7 @@ If you find a bug, then please send a report to ~a. #:client-name client-name #:client-uri client-uri))) (run-server - (handler-with-log handler) + (handler-with-log complete-corresponding-source handler) 'http (list #:port port))))) ((equal? command (G_ "command-line|command|server")) @@ -575,14 +633,16 @@ If you find a bug, then please send a report to ~a. #:http-get cache-http-get))) (create-root server-name subject) (run-server - (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)))) + (handler-with-log + 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 |