1 files changed, 86 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
new file mode 100644
index 0000000..cef6a0c
--- /dev/null
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -0,0 +1,86 @@
+(define-module (webid-oidc resource-server)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc oidc-configuration)
+  #:use-module (webid-oidc provider-confirmation)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc dpop-proof)
+  #:use-module ((webid-oidc config) #:prefix cfg:)
+  #:use-module (webid-oidc jti)
+  #:use-module (webid-oidc access-token)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (web server)
+  #:use-module (web client)
+  #: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 (sxml simple)
+  #:use-module (srfi srfi-19))
+
+(define (G_ text)
+  (let ((out (gettext text)))
+    (if (string=? out text)
+        ;; No translation, disambiguate
+        (car (reverse (string-split text #\|)))
+        out)))
+
+(define*-public (make-authenticator jti-list
+                                    #:key
+                                    (server-uri #f)
+                                    (current-time current-time)
+                                    (http-get http-get))
+  (unless (and server-uri (uri? server-uri))
+    (error "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri)."))
+  (lambda (request request-body)
+    (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* ((access-token
+                         (access-token-decode
+                          (symbol->string (cadr authz))
+                          #: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)))
+                   (let ((subject (access-token-webid access-token))
+                         (issuer (access-token-iss access-token)))
+                     (confirm-provider subject issuer #:http-get http-get)
+                     subject)))
+               #:unwind? #t))))))