Client manifest: use GOOPS

2 files changed, 146 insertions, 140 deletions

diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm
index e859d47..cbf91cf 100644
--- a/src/scm/webid-oidc/authorization-endpoint.scm
+++ b/src/scm/webid-oidc/authorization-endpoint.scm
@@ -30,7 +30,9 @@
   #:use-module (ice-9 receive)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 match)
+  #:use-module (oop goops)
   #:declarative? #t
+  #:duplicates (merge-generics)
   #:export
   (
 
@@ -107,8 +109,9 @@
                            jwk
                            #:webid subject
                            #:client-id client-id))
-                    (mf (get-client-manifest client-id)))
-                (client-manifest-check-redirect-uri mf redirect-uri)
+                    (mf (make <client-manifest>
+                          #:client-id client-id)))
+                (check-redirect-uri mf redirect-uri)
                 (let ((query
                        (if state
                            (format #f "code=~a&state=~a"
diff --git a/src/scm/webid-oidc/client-manifest.scm b/src/scm/webid-oidc/client-manifest.scm
index 7ea4931..dd29152 100644
--- a/src/scm/webid-oidc/client-manifest.scm
+++ b/src/scm/webid-oidc/client-manifest.scm
@@ -18,6 +18,7 @@
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc fetch)
   #:use-module (webid-oidc web-i18n)
+  #:use-module (webid-oidc serializable)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (web uri)
@@ -33,12 +34,11 @@
   #:use-module (ice-9 match)
   #:use-module (sxml match)
   #:use-module (sxml simple)
+  #:use-module (oop goops)
   #:declarative? #t
   #:export
   (
 
-   public-oidc-client
-
    &invalid-client-manifest
    make-invalid-client-manifest
    invalid-client-manifest?
@@ -59,19 +59,16 @@
    make-cannot-fetch-client-manifest
    cannot-fetch-client-manifest?
 
-   the-client-manifest
-   client-manifest?
-   make-client-manifest
-   client-manifest-client-id
-   client-manifest-check-redirect-uri
+   <client-manifest>
+   client-id
+   redirect-uris
 
-   serve-client-manifest
-   get-client-manifest
+   ->json-data
 
-   ))
+   check-redirect-uri
+   serve
 
-(define public-oidc-client
-  'public-oidc-client)
+   ))
 
 (define-exception-type
   &invalid-client-manifest
@@ -103,84 +100,129 @@
   make-cannot-fetch-client-manifest
   cannot-fetch-client-manifest?)
 
-(define (the-client-manifest x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((sysadmin-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "this is not a client manifest: ~a")
-                           (exception-message error))
-                   (format #f (G_ "this is not a client manifest"))))
-              (user-message
-               (let ((new-paragraph
-                      (sxml-match
-                       (xml->sxml (W_ "<p>The client manifest could
-not be queried. It can be because the client application is down, or
-it is incomplete, or unusable for other reasons.</p>"))
-                       ((*TOP* ,element)
-                        element))))
-                 (if (message-for-the-user? error)
-                     (sxml-match
-                      (user-message error)
-                      ((div ,element ...)
-                       `(div ,new-paragraph ,element ...))
-                      (,element
-                          `(div ,new-paragraph ,element)))
-                     new-paragraph))))
-          (raise-exception
-           (make-exception
-            (make-invalid-client-manifest)
-            (make-exception-with-message sysadmin-message)
-            (make-message-for-the-user user-message)
-            error))))
-    (lambda ()
-      (let examine-fields ((fields x)
-                           (client-id #f)
-                           (redirect-uris #f)
-                           (other-fields '()))
-        (match fields
-          (()
-           (unless (and client-id redirect-uris)
-             (fail (format #f (G_ "the client manifest is missing ~s")
-                           (apply append
-                                  `(,@(if client-id '() '("client_id"))
-                                    ,@(if redirect-uris '() '("redirect_uris")))))))
-           `((client_id . ,(uri->string client-id))
-             (redirect_uris . ,(list->vector (map uri->string redirect-uris)))
-             ,@(reverse other-fields)))
-          ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) fields ...)
-           (examine-fields fields (or client-id client-id-given)
-                           redirect-uris other-fields))
-          ((('client_id . invalid) _ ...)
-           (fail (format #f (G_ "~s is an invalid \"client_id\" value, because it is not an URI")
-                         invalid)))
-          ((('redirect_uris . #((? string? (= string->uri (? uri? uri))) ...)) fields ...)
-           (examine-fields fields client-id (or redirect-uris uri) other-fields))
-          ((('redirect_uris . #(_ ...)) _ ...)
-           (fail (format #f (G_ "at least one of the redirect URIs is not a proper URI"))))
-          ((('redirect_uris . _) _ ...)
-           (fail (format #f (G_ "the \"redirect_uris\" field should be a vector of URIs"))))
-          ((other-field fields ...)
-           (examine-fields fields client-id redirect-uris
-                           `(,other-field ,@other-fields)))
-          (else
-           (fail (format #f (G_ "the client manifest should be a JSON object")))))))))
+(define public-client-uri
+  (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient"))
 
-(define (client-manifest? x)
-  (false-if-exception
-   (the-client-manifest x)))
+(define-class <client-manifest> ()
+  (client-id #:init-keyword #:client-id #:accessor client-id #:->jwks uri->string)
+  (redirect-uris #:init-keyword #:redirect-uris #:accessor redirect-uris #:->jwks uri->string)
+  #:metaclass <plugin-class>
+  #:module-name '(webid-oidc client-manifest))
 
-(define (make-client-manifest client-id redirect-uris)
-  (the-client-manifest
-   `((client_id . ,(uri->string client-id))
-     (redirect_uris . ,(list->vector
-                        (map uri->string
-                             redirect-uris))))))
-
-(define (client-manifest-client-id mf)
-  (if (eq? mf public-oidc-client)
-      (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient")
-      (string->uri (assq-ref (the-client-manifest mf) 'client_id))))
+(define-method (initialize (client <client-manifest>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((client-id #f)
+    (redirect-uris #f))
+   (let do-initialize ((client-id client-id)
+                       (redirect-uris redirect-uris))
+     (when (list? redirect-uris)
+       (set! redirect-uris
+             (map
+              (match-lambda
+                ((or (? string? (= string->uri (? uri? value)))
+                     value)
+                 value))
+              redirect-uris)))
+     (cond
+      ((string? client-id)
+       (do-initialize (string->uri client-id) redirect-uris))
+      ((equal? client-id public-client-uri)
+       (slot-set! client 'client-id client-id)
+       (slot-set! client 'redirect-uris '()))
+      ((not redirect-uris)
+       (receive (response response-body) ((p:anonymous-http-request) client-id)
+         (with-exception-handler
+             (lambda (error)
+               (raise-exception
+                (make-exception
+                 (make-cannot-fetch-client-manifest)
+                 (make-exception-with-message
+                  (if (exception-with-message? error)
+                      (format #f (G_ "cannot fetch a client manifest: ~a")
+                              (exception-message error))
+                      (format #f (G_ "cannot fetch a client manifest"))))
+                 error)))
+           (lambda ()
+             (when (bytevector? response-body)
+               (set! response-body (utf8->string response-body)))
+             (unless (eqv? (response-code response) 200)
+               (raise-exception
+                (make-exception
+                 (make-exception-with-message
+                  (format #f (G_ "the server responded with code ~a")
+                          (response-code response)))
+                 (make-message-for-the-user
+                  `(p ,(format #f (W_ "The server hosting your application responded with code ~a.")
+                               (response-code response)))))))
+             (let ((json-data (stubs:json-string->scm response-body)))
+               (let ((new-client-id (assq-ref json-data 'client_id))
+                     (redirect-uris (assq-ref json-data 'redirect_uris)))
+                 (unless (string? new-client-id)
+                   (raise-exception
+                    (make-exception
+                     (make-exception-with-message
+                      (G_ "the client manifest does not have a client_id field"))
+                     (make-message-for-the-user
+                      `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the client_id field."))))))
+                 (set! redirect-uris
+                       (let fix-redirect-uris ((redirect-uris redirect-uris))
+                         (match redirect-uris
+                           ((? vector? (= vector->list redirect-uris))
+                            redirect-uris)
+                           ((? list? redirect-uris)
+                            (map fix-redirect-uris redirect-uris))
+                           ((? string? (= string->uri (? uri? uri)))
+                            uri)
+                           (anything anything))))
+                 (set! new-client-id
+                       (match new-client-id
+                         ((? string? (= string->uri (? uri? uri)))
+                          uri)
+                         (anything anything)))
+                 (unless redirect-uris
+                   (raise-exception
+                    (make-exception
+                     (make-exception-with-message
+                      (G_ "the client manifest does not have a redirect_uris field"))
+                     (make-message-for-the-user
+                      `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the redirect_uris field."))))))
+                 (unless new-client-id
+                   (raise-exception
+                    (make-exception
+                     (make-exception-with-message
+                      (G_ "the client manifest does not have a client_id field"))
+                     (make-message-for-the-user
+                      `(p ,(W_ "The server hosting your application does not behave correctly, because it lacks the client_id field."))))))
+                 (unless (equal? client-id new-client-id)
+                   (raise-exception
+                    (make-exception
+                     (make-inconsistent-client-manifest)
+                     (make-exception-with-message
+                      (format #f (G_ "the client manifest under ~s has a client_id of ~s")
+                              (uri->string client-id)
+                              (uri->string new-client-id)))
+                     (make-message-for-the-user
+                      `(p ,(W_ "The application you want to use does not control the domain name it appears to represent."))))))
+                 (do-initialize new-client-id redirect-uris)))))))
+      (else
+       (unless (uri? client-id)
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:client-id should be an URI")
+                    '()
+                    (list client-id)))
+       (unless (let check-redirect-uris ((redirect-uris redirect-uris))
+                 (match redirect-uris
+                   (() #t)
+                   (((? uri?) redirect-uris ...)
+                    (check-redirect-uris redirect-uris))))
+         (scm-error 'wrong-type-arg "make"
+                    (G_ "#:redirect-uris should be a list of URIs")
+                    '()
+                    (list redirect-uri)))
+       (slot-set! client 'client-id client-id)
+       (slot-set! client 'redirect-uris redirect-uris))))))
 
 (define (check-redirect mf uris redir)
   (match uris
@@ -204,19 +246,19 @@ approved.</p>"))
     ((_ uris ...)
      (check-redirect mf uris redir))))
 
-(define (client-manifest-check-redirect-uri mf redir)
+(define-method (check-redirect-uri (mf <client-manifest>) redir)
   (unless (uri? redir)
     (set! redir (string->uri redir)))
-  (if (eq? mf public-oidc-client)
-      #t
-      (let ((redirect-uris
-             (assq-ref (the-client-manifest mf) 'redirect_uris)))
-        (check-redirect (the-client-manifest mf)
-                        (map string->uri (vector->list redirect-uris))
-                        redir))))
+  (or (equal? (client-id mf) public-client-uri)
+      (check-redirect mf (redirect-uris mf) redir)))
+
+(define-method (->json-data (mf <client-manifest>))
+  `((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld")
+    (client_id . ,(uri->string (client-id mf)))
+    (redirect_uris . ,(list->vector (map uri->string (redirect-uris mf))))))
 
-(define (serve-client-manifest expiration-date mf)
-  (when (eq? mf public-oidc-client)
+(define-method (serve (mf <client-manifest>) expiration-date)
+  (when (equal? (client-id mf) public-client-uri)
     (let ((final-message
            (format #f (G_ "cannot serve the public manifest"))))
       (raise-exception
@@ -224,46 +266,7 @@ approved.</p>"))
         (make-cannot-serve-public-manifest)
         (make-exception-with-message final-message)))))
   (let ((json-object (stubs:scm->json-string
-                      `((@context . "https://www.w3.org/ns/solid/oidc-context.jsonld")
-                        ,@(the-client-manifest mf)))))
+                      (->json-data mf))))
     (values (build-response #:headers `((content-type application/ld+json)
                                         (expires . ,expiration-date)))
             json-object)))
-
-(define* (get-client-manifest id)
-  (unless (uri? id)
-    (set! id (string->uri id)))
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "cannot fetch the client manifest ~s: ~a")
-                           (uri->string id)
-                           (exception-message error))
-                   (format #f (G_ "cannot fetch the client manifest ~s")
-                           (uri->string id)))))
-          (raise-exception
-           (make-exception
-            (make-cannot-fetch-client-manifest)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (if (equal? id
-                  (string->uri
-                   "http://www.w3.org/ns/solid/terms#PublicOidcClient"))
-          public-oidc-client
-          (receive (response response-body)
-              ((p:anonymous-http-request) id)
-            (when (bytevector? response-body)
-              (set! response-body (utf8->string response-body)))
-            (let ((mf (the-client-manifest (stubs:json-string->scm response-body))))
-              (unless (equal? (client-manifest-client-id mf) id)
-                (let ((final-message
-                       (format #f (G_ "the client manifest is dereferenced from ~s, but it pretends to be ~s")
-                               (uri->string id)
-                               (uri->string (client-manifest-client-id mf)))))
-                  (raise-exception
-                   (make-exception
-                    (make-inconsistent-client-manifest)
-                    (make-exception-with-message final-message)))))
-              mf))))))