Get an openid configuration on the web

4 files changed, 136 insertions, 2 deletions

diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am
index 91dff23..ebf6811 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -4,11 +4,13 @@ dist_webidoidcmod_DATA += \
   %reldir%/testing.scm \
   %reldir%/jwk.scm \
   %reldir%/jws.scm \
-  %reldir%/cache.scm
+  %reldir%/cache.scm \
+  %reldir%/oidc-configuration.scm
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
   %reldir%/testing.go \
   %reldir%/jwk.go \
   %reldir%/jws.go \
-  %reldir%/cache.go
+  %reldir%/cache.go \
+  %reldir%/oidc-configuration.go
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index 1476e86..beeaaea 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -217,6 +217,16 @@
   (raise-exception
    ((record-constructor &unexpected-response) response cause)))
 
+(define-public &not-an-oidc-configuration
+  (make-exception-type
+   '&not-an-oidc-configuration
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-an-oidc-configuration value cause)
+  (raise-exception
+   ((record-constructor &not-an-oidc-configuration) value cause)))
+
 (define*-public (error->str err #:key (max-depth #f))
   (if (record? err)
       (let* ((type (record-type-descriptor err))
@@ -309,6 +319,9 @@
                      (lambda (port)
                        (write-response (get 'response) port)))
                    (recurse (get 'cause))))
+          ((&not-an-oidc-configuration)
+           (format #f (G_ "the value ~s is not an OIDC configuration (because ~a)")
+                   (get 'value) (recurse (get 'cause))))
           ((&compound-exception)
            (let ((components (get 'components)))
              (if (null? components)
diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
index db7a41f..fd94b9e 100644
--- a/src/scm/webid-oidc/jwk.scm
+++ b/src/scm/webid-oidc/jwk.scm
@@ -133,6 +133,8 @@
            (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")
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))))))))