(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)))))))))