OIDC configuration: use GOOPS and document it

1 files changed, 150 insertions, 151 deletions

diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm
index 2233d95..0a776d1 100644
--- a/src/scm/webid-oidc/oidc-configuration.scm
+++ b/src/scm/webid-oidc/oidc-configuration.scm
@@ -19,6 +19,7 @@
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (web response)
@@ -28,6 +29,7 @@
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 exceptions)
   #:use-module (ice-9 match)
+  #:use-module (oop goops)
   #:declarative? #t
   #:export
   (
@@ -35,14 +37,14 @@
    make-invalid-oidc-configuratioon
    invalid-oidc-configuration?
 
-   the-oidc-configuration
-   oidc-configuration?
-   oidc-configuration-jwks-uri
-   oidc-configuration-authorization-endpoint
-   oidc-configuration-token-endpoint
-   oidc-configuration-jwks
-   serve-oidc-configuration
-   get-oidc-configuration
+   <oidc-configuration>
+   jwks-uri
+   authorization-endpoint
+   token-endpoint
+   jwks
+   serve
+
+   ->json-data
    ))
 
 (define-exception-type
@@ -51,152 +53,149 @@
   make-invalid-oidc-configuration
   invalid-oidc-configuration?)
 
-(define (the-oidc-configuration x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "the OIDC configuration is invalid: ~a")
-                           (exception-message error))
-                   (format #f (G_ "the OIDC configuration is invalid")))))
-          (raise-exception
-           (make-exception
-            (make-invalid-oidc-configuration)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (let examine ((data x)
-                    (jwks-uri #f)
-                    (token-endpoint #f)
-                    (authorization-endpoint #f)
-                    (solid-oidc-supported #f)
-                    (other-fields '()))
-        (match data
-          (()
-           (unless (and jwks-uri token-endpoint authorization-endpoint solid-oidc-supported)
-             (fail (format #f (G_ "the OIDC configuration does not have: ~s")
-                           `(,@(if jwks-uri '() '("jwks_uri"))
-                             ,@(if token-endpoint '() '("token_endpoint"))
-                             ,@(if authorization-endpoint '() '("authorization_endpoint"))
-                             ,@(if solid-oidc-supported '() '("solid_oidc_supported"))))))
-           `((jwks_uri . ,(uri->string jwks-uri))
-             (token_endpoint . ,(uri->string token-endpoint))
-             (authorization_endpoint . ,(uri->string authorization-endpoint))
-             (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc")
-             ,@(reverse other-fields)))
-          ((('jwks_uri . (? string->uri (? string? given-jwks-uri))) data ...)
-           (examine data (or jwks-uri (string->uri given-jwks-uri))
-                    token-endpoint authorization-endpoint
-                    solid-oidc-supported other-fields))
-          ((('jwks_uri . invalid) data ...)
-           (fail (format #f (G_ "invalid JWKS URI: ~s")
-                         invalid)))
-          ((('token_endpoint . (? string->uri (? string? given-token-endpoint))) data ...)
-           (examine data jwks-uri
-                    (or token-endpoint (string->uri given-token-endpoint))
-                    authorization-endpoint solid-oidc-supported other-fields))
-          ((('token_endpoint . invalid) data ...)
-           (fail (format #f (G_ "invalid token endpoint: ~s")
-                         invalid)))
-          ((('authorization_endpoint
-             . (? string->uri (? string? given-authorization-endpoint)))
-            data ...)
-           (examine data jwks-uri token-endpoint
-                    (or authorization-endpoint (string->uri given-authorization-endpoint))
-                    solid-oidc-supported other-fields))
-          ((('authorization_endpoint . invalid) data ...)
-           (fail (format #f (G_ "invalid authorization endpoint: ~s")
-                         invalid)))
-          ((('solid_oidc_supported . "https://solidproject.org/TR/solid-oidc")
-            data ...)
-           (examine data jwks-uri token-endpoint authorization-endpoint
-                    (or solid-oidc-supported #t)
-                    other-fields))
-          ((('solid_oidc_supported . incorrect) data ...)
-           (fail (format #f (G_ "\"solid_oidc_supported\" should be set to ~s, not ~s")
-                         "https://solidproject.org/TR/solid-oidc"
-                         incorrect)))
-          ((((? symbol? key) . value) data ...)
-           (examine data jwks-uri token-endpoint authorization-endpoint
-                    solid-oidc-supported
-                    `((,key . ,value) ,@other-fields)))
-          (else
-           (fail (format #f (G_ "invalid JSON object")))))))))
-
-(define (oidc-configuration? obj)
-  (false-if-exception
-   (the-oidc-configuration obj)))
-
-(define (uri-field what)
-  (lambda (x)
-    (let ((str (assq-ref (the-oidc-configuration x) what)))
-      (string->uri str))))
-
-(define oidc-configuration-jwks-uri
-  (uri-field 'jwks_uri))
-
-(define oidc-configuration-authorization-endpoint
-  (uri-field 'authorization_endpoint))
+(define-class <oidc-configuration> ()
+  (jwks-uri #:init-keyword #:jwks-uri #:accessor jwks-uri)
+  (authorization-endpoint #:init-keyword #:authorization-endpoint #:accessor authorization-endpoint)
+  (token-endpoint #:init-keyword #:token-endpoint #:accessor token-endpoint))
 
-(define oidc-configuration-token-endpoint
-  (uri-field 'token_endpoint))
+(define-method (initialize (cfg <oidc-configuration>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((jwks-uri #f)
+    (authorization-endpoint #f)
+    (token-endpoint #f)
+    (solid-oidc-supported "https://solidproject.org/TR/solid-oidc")
+    (json-data #f)
+    (server #f)
+    (http-request (p:anonymous-http-request)))
+   (let do-initialize ((jwks-uri jwks-uri)
+                       (authorization-endpoint authorization-endpoint)
+                       (token-endpoint token-endpoint)
+                       (solid-oidc-supported solid-oidc-supported)
+                       (json-data json-data)
+                       (server server))
+     (cond
+      ((string? jwks-uri)
+       (do-initialize (string->uri jwks-uri)
+                      authorization-endpoint
+                      token-endpoint
+                      solid-oidc-supported
+                      json-data
+                      server))
+      ((string? authorization-endpoint)
+       (do-initialize jwks-uri
+                      (string->uri authorization-endpoint)
+                      token-endpoint
+                      solid-oidc-supported
+                      json-data
+                      server))
+      ((string? token-endpoint)
+       (do-initialize jwks-uri
+                      authorization-endpoint
+                      (string->uri token-endpoint)
+                      solid-oidc-supported
+                      json-data
+                      server))
+      ((string? server)
+       ;; Either it is an URI, or it is a host name
+       (do-initialize jwks-uri
+                      authorization-endpoint
+                      token-endpoint
+                      solid-oidc-supported
+                      json-data
+                      (or (false-if-exception (string->uri server))
+                          (false-if-exception
+                           (build-uri 'https #:host server)))))
+      (json-data
+       (do-initialize (assq-ref json-data 'jwks_uri)
+                      (assq-ref json-data 'authorization_endpoint)
+                      (assq-ref json-data 'token_endpoint)
+                      (assq-ref json-data 'solid_oidc_supported)
+                      #f #f))
+      ((and jwks-uri authorization-endpoint token-endpoint solid-oidc-supported)
+       (begin
+         (unless (uri? jwks-uri)
+           (scm-error 'wrong-type-arg "make"
+                      (G_ "#:jwks-uri should be an URI")
+                      '()
+                      (list jwks-uri)))
+         (unless (uri? token-endpoint)
+           (scm-error 'wrong-type-arg "make"
+                      (G_ "#:token-endpoint should be an URI")
+                      '()
+                      (list token-endpoint)))
+         (unless (uri? authorization-endpoint)
+           (scm-error 'wrong-type-arg "make"
+                      (G_ "#:authorization-endpoint should be an URI")
+                      '()
+                      (list authorization-endpoint)))
+         (unless (equal? solid-oidc-supported "https://solidproject.org/TR/solid-oidc")
+           (scm-error 'wrong-type-arg "make"
+                      (G_ "#:solid-oidc-supported should be exactly 'https://solidproject.org/TR/solid-oidc'")
+                      '()
+                      (list solid-oidc-supported)))
+         (slot-set! cfg 'jwks-uri jwks-uri)
+         (slot-set! cfg 'token-endpoint token-endpoint)
+         (slot-set! cfg 'authorization-endpoint authorization-endpoint)))
+      (server
+       (unless (uri? server)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:server should be an URI")
+                    '()
+                    (list server)))
+       (let ((discovery-uri
+              (build-uri (uri-scheme server)
+                         #:userinfo (uri-userinfo server)
+                         #:host (uri-host server)
+                         #:port (uri-port server)
+                         #:path "/.well-known/openid-configuration")))
+         (receive (response response-body) (http-request discovery-uri)
+           (with-exception-handler
+               (lambda (error)
+                 (raise-exception
+                  (make-exception
+                   (make-invalid-oidc-configuration)
+                   (make-exception-with-message 
+                    (if (exception-with-message? error)
+                        (format #f (G_ "cannot fetch the OIDC configuration: ~a")
+                                (exception-message error))
+                        (format #f (G_ "cannot fetch the OIDC configuration"))))
+                   error)))
+             (lambda ()
+               (unless (eqv? (response-code response) 200)
+                 (fail (format #f (G_ "the server responded with ~s ~s")
+                               (response-code response)
+                               (response-reason-phrase response))))
+               (let ((content-type (response-content-type response)))
+                 (unless content-type
+                   (fail (format #f (G_ "there is no 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))))
+                   (fail (format #f (G_ "unexpected content-type: ~s")
+                                 content-type)))
+                 (unless (string? response-body)
+                   (set! response-body (utf8->string response-body)))
+                 (do-initialize #f #f #f #f (stubs:json-string->scm response-body) #f)))))))
+      (else
+       (raise-exception
+        (make-exception
+         (make-invalid-oidc-configuratin)
+         (make-exception-with-message
+          (G_ "when making an OIDC configuration, either its required #:jwks-uri, #:authorization-endpoint and #:token-endpoint fields or #:server (and optionally #:http-request) or #:json-data should be passed")))))))))
 
-(define* (oidc-configuration-jwks cfg #:key (http-get http-get))
-  (let ((http-request-for-get-jwks
-         (lambda* (uri #:key (method 'GET))
-           (http-get uri))))
-    (get-jwks (oidc-configuration-jwks-uri cfg)
-              #:http-request http-request-for-get-jwks)))
+(define-method (->json-data (cfg <oidc-configuration>))
+  `((jwks_uri . ,(uri->string (jwks-uri cfg)))
+    (authorization_endpoint . ,(uri->string (authorization-endpoint cfg)))
+    (token_endpoint . ,(uri->string (token-endpoint cfg)))
+    (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc")))
 
-(define (serve-oidc-configuration expiration-date cfg)
+(define-method (serve (cfg <oidc-configuration>) expiration-date)
   (values (build-response #:headers `((content-type . (application/json))
                                       (expires . ,expiration-date)))
-          (stubs:scm->json-string cfg)))
+          (stubs:scm->json-string (->json-data cfg))))
 
-(define* (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 (error)
-            (let ((final-message
-                   (if (exception-with-message? error)
-                       (format #f (G_ "cannot fetch the OIDC configuration: ~a")
-                               (exception-message error))
-                       (format #f (G_ "cannot fetch the OIDC configuration")))))
-              (raise-exception
-               (make-exception
-                (make-invalid-oidc-configuration)
-                (make-exception-with-message final-message)
-                error))))
-        (lambda ()
-          (unless (eqv? (response-code response) 200)
-            (fail (format #f (G_ "the server responded with ~s ~s")
-                          (response-code response)
-                          (response-reason-phrase response))))
-          (let ((content-type (response-content-type response)))
-            (unless content-type
-              (fail (format #f (G_ "there is no 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))))
-              (fail (format #f (G_ "unexpected content-type: ~s")
-                            content-type)))
-            (unless (string? response-body)
-              (set! response-body (utf8->string response-body)))
-            (the-oidc-configuration (stubs:json-string->scm response-body))))))))
+(define-method (jwks (cfg <oidc-configuration>))
+  (get-jwks (jwks-uri cfg) #:http-request (p:anonymous-http-request)))