From bae1843f1a1d644fb3bd4f8c40b1dbb900aa3325 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Sun, 1 Aug 2021 14:51:28 +0200
Subject: Use guile parameters

With parameters, the API does not need to care about the directory
where to load files and how to get the time.
---
 src/scm/webid-oidc/reverse-proxy.scm | 89 ++++++++++++++++++------------------
 1 file changed, 44 insertions(+), 45 deletions(-)

(limited to 'src/scm/webid-oidc/reverse-proxy.scm')

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)))))))))))))
-- 
cgit v1.2.3