diff options
Diffstat (limited to 'src/scm/webid-oidc/reverse-proxy.scm')
| -rw-r--r-- | src/scm/webid-oidc/reverse-proxy.scm | 89 |
1 files changed, 44 insertions, 45 deletions
diff --git a/src/scm/webid-oidc/reverse-proxy.scm b/src/scm/webid-oidc/reverse-proxy.scm index f9caba6..a1b05e3 100644 --- a/src/scm/webid-oidc/reverse-proxy.scm +++ b/src/scm/webid-oidc/reverse-proxy.scm @@ -18,8 +18,8 @@ #: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 ((webid-oidc parameters) #:prefix p:) #:use-module (ice-9 optargs) #:use-module (ice-9 receive) #:use-module (ice-9 i18n) @@ -36,9 +36,7 @@ (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)) @@ -50,9 +48,7 @@ (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.")) @@ -68,43 +64,46 @@ 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)))))))))))) + (apply throw key args)))))) + (request-time ((p:current-date)))) + (parameterize ((p:current-date request-time)) + ;; The time is now set for the duration of the request + (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))))))))))))) |