1 files changed, 117 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm
new file mode 100644
index 0000000..99a4e17
--- /dev/null
+++ b/src/scm/webid-oidc/oidc-configuration.scm
@@ -0,0 +1,117 @@
+(define-module (webid-oidc oidc-configuration)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-19)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs))
+
+(define-public (the-oidc-configuration x)
+  (with-exception-handler
+      (lambda (cause)
+        (raise-not-an-oidc-configuration x cause))
+    (lambda ()
+      (let ((jwks-uri (assq-ref x 'jwks_uri))
+            (token-endpoint (assq-ref x 'token_endpoint))
+            (authorization-endpoint (assq-ref x 'authorization_endpoint)))
+        (unless jwks-uri
+          (raise-missing-alist-key x 'jwks_uri))
+        (unless token-endpoint
+          (raise-missing-alist-key x 'token_endpoint))
+        (unless authorization-endpoint
+          (raise-missing-alist-key x 'authorization_endpoint))
+        (for-each
+         (lambda (field)
+           (unless (string->uri field)
+             (scm-error 'wrong-type-arg
+                        "the-oidc-configuration"
+                        "expected an uri-like string"
+                        '()
+                        (list field))))
+         (list jwks-uri token-endpoint authorization-endpoint))
+        x))))
+
+(define-public (oidc-configuration? obj)
+  (false-if-exception
+   (and (the-oidc-configuration obj) obj)))
+
+(define-public (make-oidc-configuration jwks-uri
+                                        authorization-endpoint
+                                        token-endpoint)
+  (when (string? jwks-uri)
+    (set! jwks-uri (string->uri jwks-uri)))
+  (when (string? authorization-endpoint)
+    (set! authorization-endpoint (string->uri authorization-endpoint)))
+  (when (string? token-endpoint)
+    (set! token-endpoint (string->uri token-endpoint)))
+  (the-oidc-configuration
+   `((jwks_uri . ,(uri->string jwks-uri))
+     (token_endpoint . ,(uri->string token-endpoint))
+     (authorization_endpoint . ,(uri->string authorization-endpoint)))))
+
+(define (uri-field what)
+  (lambda (x)
+    (let ((str (assq-ref (the-oidc-configuration x) what)))
+      (string->uri str))))
+
+(define-public oidc-configuration-jwks-uri
+  (uri-field 'jwks_uri))
+
+(define-public oidc-configuration-authorization-endpoint
+  (uri-field 'authorization_endpoint))
+
+(define-public oidc-configuration-token-endpoint
+  (uri-field 'token_endpoint))
+
+(define-public (oidc-configuration-jwks cfg . args)
+  (apply get-jwks (oidc-configuration-jwks-uri cfg) args))
+
+(define-public (serve-oidc-configuration expiration-date cfg)
+  (let ((with-solid-oidc-supported
+         (acons 'solid_oidc_supported "https://solidproject.org/TR/solid-oidc"
+                (the-oidc-configuration cfg))))
+    (values (build-response #:headers `((content-type . (application/json))
+                                        (expires . ,expiration-date)))
+            (stubs:scm->json-string with-solid-oidc-supported))))
+
+(define*-public (get-oidc-configuration host
+                                        #:key
+                                        (userinfo #f)
+                                        (port #f)
+                                        (http-get http-get))
+  (when (and (string? host)
+             (false-if-exception
+              (string->uri host)))
+    ;; host is something like "https://example.com"
+    (set! host (string->uri host)))
+  (when (uri? host)
+    (set! host (uri-host host)))
+  (let ((uri (build-uri 'https
+                        #:userinfo userinfo
+                        #:host host
+                        #:port port
+                        #:path "/.well-known/openid-configuration")))
+    (receive (response response-body) (http-get uri)
+      (with-exception-handler
+          (lambda (cause)
+            (raise-unexpected-response response cause))
+        (lambda ()
+          (unless (eqv? (response-code response) 200)
+            (raise-request-failed-unexpectedly
+             (response-code response)
+             (response-reason-phrase response)))
+          (let ((content-type (response-content-type response)))
+            (unless content-type
+              (raise-unexpected-header-value 'content-type content-type))
+            (unless (and (eq? (car content-type) 'application/json)
+                         (or (equal? (assoc-ref (cdr content-type) 'charset)
+                                     "utf-8")
+                             (not (assoc-ref (cdr content-type) 'charset))))
+              (raise-unexpected-header-value 'content-type content-type))
+            (unless (string? response-body)
+              (set! response-body (utf8->string response-body)))
+            (the-oidc-configuration (stubs:json-string->scm response-body))))))))