diff options
Diffstat (limited to 'src/scm/webid-oidc/reverse-proxy.scm')
| -rw-r--r-- | src/scm/webid-oidc/reverse-proxy.scm | 257 |
1 files changed, 257 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/reverse-proxy.scm b/src/scm/webid-oidc/reverse-proxy.scm new file mode 100644 index 0000000..87588b9 --- /dev/null +++ b/src/scm/webid-oidc/reverse-proxy.scm @@ -0,0 +1,257 @@ +(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 jti) + #:use-module ((webid-oidc config) #:prefix cfg:) + #: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 request) + #:use-module (web response) + #:use-module (web client) + #:use-module (webid-oidc cache) + #:use-module (web server)) + +(define (G_ text) + (let ((out (gettext text))) + (if (string=? out text) + ;; No translation, disambiguate + (car (reverse (string-split text #\|))) + out))) + +(define*-public (make-reverse-proxy + #:key + (jti-list #f) + (server-uri #f) + (current-time current-time) + (http-get http-get) + (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 + (or jti-list (make-jti-list)) + #:server-uri server-uri + #:current-time current-time + #:http-get http-get)) + (unless (and endpoint (uri? endpoint)) + (error "#:endpoint argument is not present or not an URI.")) + (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))))))) + (let ((raw-headers (request-headers request))) + (let ((modified-headers + (append + (if agent + (list (cons auth-header (uri->string agent))) + '()) + (filter + (lambda (h) + (not (eq? (car h) auth-header))) + raw-headers)))) + (let ((modified-request + (build-request + (request-uri request) + #:method (request-method request) + #:headers modified-headers))) + (let ((port (open-socket-for-uri endpoint))) + (let ((request-with-port + (write-request modified-request port))) + (when request-body + (unless (bytevector? request-body) + (set! request-body (string->utf8 request-body))) + (write-request-body request-with-port request-body)) + (force-output (request-port request-with-port)) + (let ((response (read-response port))) + (let ((response-body + (or (response-must-not-include-body? response) + (read-response-body response)))) + (let ((adapted-response + (build-response + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers + (append + (if (eqv? (response-code response) 401) + (list (cons 'www-authenticate '((DPoP)))) + '()) + (response-headers response))))) + (close-port port) + (values adapted-response response-body)))))))))))) + +(define-public (main) + (define* (http-get-with-log uri #:key (headers '())) + (define date (date->string (time-utc->date (current-time)))) + (define uri-string (if (uri? uri) (uri->string uri) uri)) + (format (current-error-port) "~a: GET ~a ~s...\n" + date uri-string headers) + (receive (response response-body) (http-get uri #:headers headers) + (format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n" + date uri-string headers response + (if (bytevector? response-body) + (bytevector-length response-body) + (string-length response-body))) + (values response response-body))) + (define cache-http-get + (with-cache #:http-get http-get-with-log)) + (setvbuf (current-output-port) 'none) + (setvbuf (current-error-port) 'none) + (setlocale LC_ALL "") + (bindtextdomain cfg:package cfg:localedir) + (textdomain cfg:package) + (let ((version-sym + (string->symbol (G_ "command-line|version"))) + (help-sym + (string->symbol (G_ "command-line|help"))) + (port-sym + (string->symbol (G_ "command-line|port"))) + (inbound-uri-sym + (string->symbol (G_ "command-line|inbound-uri"))) + (outbound-uri-sym + (string->symbol (G_ "command-line|outbound-uri"))) + (header-sym + (string->symbol (G_ "command-line|header"))) + (log-file-sym + (string->symbol (G_ "comand-line|log-file"))) + (error-file-sym + (string->symbol (G_ "comand-line|error-file")))) + (let ((options + (let ((option-spec + `((,version-sym (single-char #\v) (value #f)) + (,help-sym (single-char #\h) (value #f)) + (,port-sym (single-char #\p) (value #t)) + (,inbound-uri-sym (single-char #\i) (value #t)) + (,outbound-uri-sym (single-char #\o) (value #t)) + (,header-sym (single-char #\H) (value #t)) + (,log-file-sym (single-char #\l) (value #t)) + (,error-file-sym (single-char #\e) (value #t))))) + (getopt-long (command-line) option-spec)))) + (cond + ((option-ref options help-sym #f) + (format #t (G_ "Usage: ~a [OPTIONS]... + +Run a reverse proxy, taking requests with webid-oidc authentication +and passing them to the outbound URI with an additional header +containing the webid of the agent. + +Options: + -h, --~a: + display this help message and exit. + -v, --~a: + display the version information (~a) and exit. + -p PORT, --~a=8080: + set the port to bind. + -i URI, --~a=URI: + set the public URI of the reverse proxy. + -o URI, --~a=URI: + pass the requests to the server running at URI. + -H HEADER, --~a=HEADER: + pass request with optional HEADER set to the webid, XXX-Agent by default. + -l FILE.log, --~a=FILE.log: + dump the standard output to that file. + -e FILE.err, --~a=FILE.err: + dump the standard error to that file. + +Environment variables: + + LANG: set the locale of the sysadmin-facing interface. It is +currently ~a. + +Example: + +Suppose that you operate data.provider.com. Since everything is behind +a big global reverse proxy, the authenticated proxy listens on +http://localhost:8080. You have the data server running at +https://private.data.provider.com, set up so that only you can query +it. The private server needs the XXX-Agent header to contain the +authenticated webid of the user, if the user is authenticated. That’s +why you don’t want anyone to query it. You would run: + + export LANG=C + webid-oidc-reverse-proxy \\ + --port 8080 \\ + --inbound-uri https://data.provider.com \\ + --outbound-uri https://private.data.provider.com \\ + --header XXX-Agent \\ + --log-file /var/log/proxy.log \\ + --error-file /var/log/proxy.err + +If you find a bug, send a report to ~a. +") + (car (command-line)) + help-sym version-sym + cfg:version + port-sym inbound-uri-sym outbound-uri-sym header-sym + log-file-sym error-file-sym + (or (getenv "LANG") "") + cfg:package-bugreport)) + ((option-ref options version-sym #f) + (format #t (G_ "~a version ~a\n") + cfg:package cfg:version)) + (else + (let ((port-string + (option-ref options port-sym "8080")) + (inbound-uri-string + (option-ref options inbound-uri-sym #f)) + (outbound-uri-string + (option-ref options outbound-uri-sym #f)) + (header-string + (option-ref options header-sym "XXX-Agent")) + (log-file-string + (option-ref options log-file-sym #f)) + (error-file-string + (option-ref options error-file-sym #f))) + (when log-file-string + (set-current-output-port (stubs:open-output-file* log-file-string)) + (setvbuf (current-output-port) 'none)) + (when error-file-string + (set-current-error-port (stubs:open-output-file* error-file-string)) + (setvbuf (current-error-port) 'none)) + (unless (and port-string + (string? port-string) + (string->number port-string) + (integer? (string->number port-string)) + (>= (string->number port-string) 0) + (<= (string->number port-string) 65535)) + (format (current-error-port) + (G_ "The port should be a number between 0 and 65535.\n")) + (exit 1)) + (unless (and inbound-uri-string + (string->uri inbound-uri-string)) + (format (current-error-port) + (G_ "The public name of the server must be present (with scheme) as --inbound-uri.\n")) + (exit 1)) + (unless (and outbound-uri-string + (string->uri outbound-uri-string)) + (format (current-error-port) + (G_ "The address of the proxy must be present (with scheme) as --outbound-uri.\n")) + (exit 1)) + (install-suspendable-ports!) + (run-server (make-reverse-proxy + #:server-uri (string->uri inbound-uri-string) + #:http-get cache-http-get + #:endpoint (string->uri outbound-uri-string) + #:auth-header (string->symbol header-string)) + 'http + (list #:port (string->number port-string))))))))) |