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.

1 files changed, 201 insertions, 209 deletions

diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index a6c111e..14d8b81 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -21,12 +21,13 @@
   #:use-module (webid-oidc jwk)
   #:use-module (webid-oidc dpop-proof)
   #:use-module (webid-oidc serve)
-  #:use-module (webid-oidc server create)
-  #:use-module (webid-oidc server read)
-  #:use-module (webid-oidc server update)
-  #:use-module (webid-oidc server delete)
+  #:use-module ((webid-oidc server create) #:prefix ldp:)
+  #:use-module ((webid-oidc server read) #:prefix ldp:)
+  #:use-module ((webid-oidc server update) #:prefix ldp:)
+  #:use-module ((webid-oidc server delete) #:prefix ldp:)
   #:use-module (webid-oidc server precondition)
   #:use-module (webid-oidc http-link)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
   #:use-module (webid-oidc jti)
   #:use-module (webid-oidc access-token)
@@ -51,8 +52,7 @@
         (car (reverse (string-split text #\|)))
         out)))
 
-(define*-public (make-authenticator jti-list
-                                    #:key
+(define*-public (make-authenticator #:key
                                     (server-uri #f)
                                     (current-time current-time)
                                     (http-get http-get))
@@ -62,52 +62,45 @@
     (let ((headers (request-headers request))
           (uri (request-uri request))
           (method (request-method request))
-          (current-time
-           (let ((t current-time))
-             (when (thunk? t)
-               (set! t (t)))
-             (when (integer? t)
-               (set! t (make-time time-utc 0 t)))
-             (when (time? t)
-               (set! t (time-utc->date t)))
-             t)))
-      (let ((authz (assoc-ref headers 'authorization))
-            (dpop (assoc-ref headers 'dpop))
-            (full-uri (build-uri (uri-scheme server-uri)
-                                 #:userinfo (uri-userinfo server-uri)
-                                 #:host (uri-host server-uri)
-                                 #:port (uri-port server-uri)
-                                 #:path (string-append
-                                         "/"
-                                         (encode-and-join-uri-path
-                                          (append
-                                           (split-and-decode-uri-path (uri-path server-uri))
-                                           (split-and-decode-uri-path
-                                            (uri-path uri))))))))
-        (and authz dpop
-             (eq? (car authz) 'dpop)
-             (with-exception-handler
-                 (lambda (error)
-                   (format (current-error-port)
-                           (G_ "~a: authentication failure: ~a\n")
-                           (date->string current-time)
-                           (error->str error))
-                   #f)
-               (lambda ()
-                 (let* ((lit-access-token (symbol->string (cadr authz)))
-                        (access-token
-                         (access-token-decode lit-access-token
-                                              #:http-get http-get))
-                        (cnf/jkt (access-token-cnf/jkt access-token))
-                        (dpop-proof
-                         (dpop-proof-decode
-                          current-time jti-list method full-uri
-                          dpop cnf/jkt #:access-token lit-access-token)))
-                   (let ((subject (access-token-webid access-token))
-                         (issuer (access-token-iss access-token)))
-                     (confirm-provider subject issuer #:http-get http-get)
-                     subject)))
-               #:unwind? #t))))))
+          (current-time ((p:current-date))))
+      (parameterize ((p:current-date current-time)) ;; fix the date
+        (let ((authz (assoc-ref headers 'authorization))
+              (dpop (assoc-ref headers 'dpop))
+              (full-uri (build-uri (uri-scheme server-uri)
+                                   #:userinfo (uri-userinfo server-uri)
+                                   #:host (uri-host server-uri)
+                                   #:port (uri-port server-uri)
+                                   #:path (string-append
+                                           "/"
+                                           (encode-and-join-uri-path
+                                            (append
+                                             (split-and-decode-uri-path (uri-path server-uri))
+                                             (split-and-decode-uri-path
+                                              (uri-path uri))))))))
+          (and authz dpop
+               (eq? (car authz) 'dpop)
+               (with-exception-handler
+                   (lambda (error)
+                     (format (current-error-port)
+                             (G_ "~a: authentication failure: ~a\n")
+                             (date->string current-time)
+                             (error->str error))
+                     #f)
+                 (lambda ()
+                   (let* ((lit-access-token (symbol->string (cadr authz)))
+                          (access-token
+                           (access-token-decode lit-access-token
+                                                #:http-get http-get))
+                          (cnf/jkt (access-token-cnf/jkt access-token))
+                          (dpop-proof
+                           (dpop-proof-decode
+                            method full-uri
+                            dpop cnf/jkt #:access-token lit-access-token)))
+                     (let ((subject (access-token-webid access-token))
+                           (issuer (access-token-iss access-token)))
+                       (confirm-provider subject issuer #:http-get http-get)
+                       subject)))
+                 #:unwind? #t)))))))
 
 (define (handle-errors f g)
   (call/ec
@@ -175,171 +168,170 @@
                  (server-uri #f)
                  (owner #f)
                  (authenticator #f)
-                 (current-time current-time)
                  (http-get http-get))
   (unless owner
     (error "The owner is not defined."))
   (declare-link-header!)
   (unless authenticator
     (set! authenticator
-          (make-authenticator (make-jti-list)
-                              #:server-uri server-uri
-                              #:current-time current-time
-                              #:http-get http-get)))
+          (make-authenticator
+           #:server-uri server-uri
+           #:http-get http-get)))
   (lambda (request request-body)
-    (let ((user (authenticator request request-body)))
-      (handle-errors
-       (lambda (return)
-         (let ((method (request-method request)))
-           (case method
-             ((GET HEAD OPTIONS)
-              (receive (headers content)
-                  (read server-uri owner user
-                        (uri-path (request-uri request))
-                        #:http-get http-get)
-                (let ((true-content-type
-                       (car (assq-ref headers 'content-type)))
-                      (other-headers
-                       (filter
-                        (lambda (h)
-                          (not (eq? (car h) 'content-type)))
-                        headers)))
-                  (receive (negociated-content-type
-                            negociated-content)
-                      (convert (request-accept request #f)
-                               server-uri
-                               (uri-path (request-uri request))
-                               true-content-type
-                               content)
-                    (serve-get
-                     return
-                     (uri-path (request-uri request))
-                     (request-if-match request)
-                     (request-if-none-match request)
-                     negociated-content-type
-                     negociated-content
-                     (car (assq-ref headers 'etag))
-                     (cons `(content-type ,negociated-content-type)
-                           other-headers)
-                     user)))))
-             ((PUT)
-              (receive (content-type content)
-                  (nonrdf-or-turtle server-uri request request-body)
-                (return
-                 (build-response
-                  #:headers
-                  `((etag . (,(update server-uri owner user
-                                      (uri-path (request-uri request))
-                                      (request-if-match request)
-                                      (request-if-none-match request)
-                                      content-type
-                                      content
-                                      #:http-get http-get)
-                             . #f))))
-                 ""
-                 user)))
-             ((POST)
-              (receive (content-type content)
-                  (nonrdf-or-turtle server-uri request request-body)
-                (let ((types
-                       (map car
-                            (filter
-                             (lambda (link)
-                               (equal? (assq-ref link 'rel) "type"))
-                             (request-links request)))))
+    (parameterize ((p:current-date ((p:current-date)))) ;; Fix the date
+      (let ((user (authenticator request request-body)))
+        (handle-errors
+         (lambda (return)
+           (let ((method (request-method request)))
+             (case method
+               ((GET HEAD OPTIONS)
+                (receive (headers content)
+                    (ldp:read server-uri owner user
+                              (uri-path (request-uri request))
+                              #:http-get http-get)
+                  (let ((true-content-type
+                         (car (assq-ref headers 'content-type)))
+                        (other-headers
+                         (filter
+                          (lambda (h)
+                            (not (eq? (car h) 'content-type)))
+                          headers)))
+                    (receive (negociated-content-type
+                              negociated-content)
+                        (convert (request-accept request #f)
+                                 server-uri
+                                 (uri-path (request-uri request))
+                                 true-content-type
+                                 content)
+                      (serve-get
+                       return
+                       (uri-path (request-uri request))
+                       (request-if-match request)
+                       (request-if-none-match request)
+                       negociated-content-type
+                       negociated-content
+                       (car (assq-ref headers 'etag))
+                       (cons `(content-type ,negociated-content-type)
+                             other-headers)
+                       user)))))
+               ((PUT)
+                (receive (content-type content)
+                    (nonrdf-or-turtle server-uri request request-body)
                   (return
                    (build-response
-                    #:code 201 #:reason-phrase "Created"
                     #:headers
-                    `((location . ,(create server-uri owner user
-                                           (uri-path (request-uri request))
-                                           types
-                                           (assq-ref (request-headers request) 'slug)
-                                           content-type
-                                           content
-                                           #:http-get http-get))))
+                    `((etag . (,(ldp:update server-uri owner user
+                                            (uri-path (request-uri request))
+                                            (request-if-match request)
+                                            (request-if-none-match request)
+                                            content-type
+                                            content
+                                            #:http-get http-get)
+                               . #f))))
                    ""
-                   user))))
-             ((DELETE)
-              (delete server-uri owner user
-                      (uri-path (request-uri request))
-                      (request-if-match request)
-                      (request-if-none-match request)
-                      #:http-get http-get)
-              (return
-               (build-response)
-               ""
-               user)))))
-       (lambda (return error)
-         (if (cannot-fetch-group? error)
-             (format (current-error-port) (G_ "Warning: ~a\n")
-                     (error->str error))
-             (cond
-              ((uri-slash-semantics-error? error)
-               (return
-                (build-response
-                 #:code 301
-                 #:reason-phrase "Found"
-                 #:headers
-                 `((location
-                    . ,(build-uri
-                        (uri-scheme server-uri)
-                        #:userinfo (uri-userinfo server-uri)
-                        #:host (uri-host server-uri)
-                        #:port (uri-port server-uri)
-                        #:path (uri-slash-semantics-error-expected-path error)))))
-                #f
-                user))
-              ((or (path-not-found? error)
-                   (auxiliary-resource-absent? error)
-                   (forbidden? error))
-               (if user
-                   ;; That’s a forbidden
-                   (return
-                    (build-response #:code 403 #:reason-phrase "Forbidden")
-                    #f
-                    user)
-                   (return
-                    (build-response #:code 401 #:reason-phrase "Unauthorized"
-                                    #:headers `((www-authenticate . ((DPoP)))))
-                    #f
-                    user)))
-              ((or (cannot-delete-root? error))
-               (return
-                (build-response
-                 #:code 405
-                 #:reason-phrase "Method Not Allowed")
-                #f
-                user))
-              ((or (container-not-empty? error)
-                   (incorrect-containment-triples? error)
-                   (path-is-auxiliary? error))
-               (return
-                (build-response
-                 #:code 409
-                 #:reason-phrase "Conflict")
-                #f
-                user))
-              ((unsupported-media-type? error)
-               (return
-                (build-response
-                 #:code 415
-                 #:reason-phrase "Unsupported Media Type")
-                #f
-                user))
-              ((precondition-failed? error)
-               (return
-                (build-response
-                 #:code 412
-                 #:reason-phrase "Precondition Failed")
-                #f
-                user))
-              ((not-acceptable? error)
-               (return
-                (build-response
-                 #:code 406
-                 #:reason-phrase "Not Acceptable")
-                #f
-                user))
-              (else
-               (raise-exception error)))))))))
+                   user)))
+               ((POST)
+                (receive (content-type content)
+                    (nonrdf-or-turtle server-uri request request-body)
+                  (let ((types
+                         (map car
+                              (filter
+                               (lambda (link)
+                                 (equal? (assq-ref link 'rel) "type"))
+                               (request-links request)))))
+                    (return
+                     (build-response
+                      #:code 201 #:reason-phrase "Created"
+                      #:headers
+                      `((location . ,(ldp:create server-uri owner user
+                                                 (uri-path (request-uri request))
+                                                 types
+                                                 (assq-ref (request-headers request) 'slug)
+                                                 content-type
+                                                 content
+                                                 #:http-get http-get))))
+                     ""
+                     user))))
+               ((DELETE)
+                (ldp:delete server-uri owner user
+                            (uri-path (request-uri request))
+                            (request-if-match request)
+                            (request-if-none-match request)
+                            #:http-get http-get)
+                (return
+                 (build-response)
+                 ""
+                 user)))))
+         (lambda (return error)
+           (if (cannot-fetch-group? error)
+               (format (current-error-port) (G_ "Warning: ~a\n")
+                       (error->str error))
+               (cond
+                ((uri-slash-semantics-error? error)
+                 (return
+                  (build-response
+                   #:code 301
+                   #:reason-phrase "Found"
+                   #:headers
+                   `((location
+                      . ,(build-uri
+                          (uri-scheme server-uri)
+                          #:userinfo (uri-userinfo server-uri)
+                          #:host (uri-host server-uri)
+                          #:port (uri-port server-uri)
+                          #:path (uri-slash-semantics-error-expected-path error)))))
+                  #f
+                  user))
+                ((or (path-not-found? error)
+                     (auxiliary-resource-absent? error)
+                     (forbidden? error))
+                 (if user
+                     ;; That’s a forbidden
+                     (return
+                      (build-response #:code 403 #:reason-phrase "Forbidden")
+                      #f
+                      user)
+                     (return
+                      (build-response #:code 401 #:reason-phrase "Unauthorized"
+                                      #:headers `((www-authenticate . ((DPoP)))))
+                      #f
+                      user)))
+                ((or (cannot-delete-root? error))
+                 (return
+                  (build-response
+                   #:code 405
+                   #:reason-phrase "Method Not Allowed")
+                  #f
+                  user))
+                ((or (container-not-empty? error)
+                     (incorrect-containment-triples? error)
+                     (path-is-auxiliary? error))
+                 (return
+                  (build-response
+                   #:code 409
+                   #:reason-phrase "Conflict")
+                  #f
+                  user))
+                ((unsupported-media-type? error)
+                 (return
+                  (build-response
+                   #:code 415
+                   #:reason-phrase "Unsupported Media Type")
+                  #f
+                  user))
+                ((precondition-failed? error)
+                 (return
+                  (build-response
+                   #:code 412
+                   #:reason-phrase "Precondition Failed")
+                  #f
+                  user))
+                ((not-acceptable? error)
+                 (return
+                  (build-response
+                   #:code 406
+                   #:reason-phrase "Not Acceptable")
+                  #f
+                  user))
+                (else
+                 (raise-exception error))))))))))