client: extend the client manifest for the client service

3 files changed, 305 insertions, 128 deletions

diff --git a/po/disfluid.pot b/po/disfluid.pot
index 5f695c9..388ba8a 100644
--- a/po/disfluid.pot
+++ b/po/disfluid.pot
@@ -8,7 +8,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: disfluid SNAPSHOT\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-10-04 23:00+0200\n"
+"POT-Creation-Date: 2021-10-04 23:03+0200\n"
 "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
 "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
 "Language-Team: LANGUAGE <LL@li.org>\n"
@@ -277,7 +277,9 @@ msgid ""
 msgstr ""
 
 #: src/scm/webid-oidc/authorization-page-unsafe.scm:52
-#: src/scm/webid-oidc/hello-world.scm:40 src/scm/webid-oidc/hello-world.scm:167
+#: src/scm/webid-oidc/client.scm:307 src/scm/webid-oidc/client.scm:324
+#: src/scm/webid-oidc/client.scm:341 src/scm/webid-oidc/hello-world.scm:40
+#: src/scm/webid-oidc/hello-world.scm:167
 #: src/scm/webid-oidc/hello-world.scm:187
 #: src/scm/webid-oidc/identity-provider.scm:136
 #: src/scm/webid-oidc/token-endpoint.scm:112
@@ -287,6 +289,7 @@ msgid "xml-lang|en"
 msgstr ""
 
 #: src/scm/webid-oidc/authorization-page-unsafe.scm:67
+#: src/scm/webid-oidc/client.scm:309
 msgid "page-title|Authorization"
 msgstr ""
 
@@ -464,6 +467,60 @@ msgstr ""
 msgid "cannot serve the public manifest"
 msgstr ""
 
+#: src/scm/webid-oidc/client.scm:177
+msgid "Example application"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:204
+msgid "#:client-name should be a string"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:211
+msgid "#:client-uri should be an URI"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:220
+msgid "#:response-types should be a list of symbols"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:229
+msgid "#:grant-types should be a list of symbols"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:281 src/scm/webid-oidc/resource-server.scm:173
+msgid "reason-phrase|Not Modified"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:311
+msgid ""
+"You have been authorized. Please paste the following code in the application:"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:316
+msgid "reason-phrase|Invalid Request"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:326
+msgid "page-title|Error"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:328
+msgid "Your identity provider did not authorize you. :("
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:333
+#: src/scm/webid-oidc/identity-provider.scm:129
+msgid "reason-phrase|Not Found"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:343
+msgid "page-title|Not Found"
+msgstr ""
+
+#: src/scm/webid-oidc/client.scm:345
+msgid "This page does not exist on the server."
+msgstr ""
+
 #: src/scm/webid-oidc/client/accounts.scm:239
 msgid "The refresh token has expired."
 msgstr ""
@@ -973,10 +1030,6 @@ msgstr ""
 msgid "Warning: generating a new key pair."
 msgstr ""
 
-#: src/scm/webid-oidc/identity-provider.scm:129
-msgid "reason-phrase|Not Found"
-msgstr ""
-
 #: src/scm/webid-oidc/jti.scm:59
 #, scheme-format
 msgid "a replay has been detected with JTI ~s"
@@ -1972,10 +2025,6 @@ msgstr ""
 msgid "reason-phrase|Precondition Failed"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:173
-msgid "reason-phrase|Not Modified"
-msgstr ""
-
 #: src/scm/webid-oidc/resource-server.scm:188
 msgid "The owner is not defined."
 msgstr ""
diff --git a/po/fr.po b/po/fr.po
index 3c51f45..9cb0a4f 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -2,8 +2,8 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc 0.0.0\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-10-04 23:00+0200\n"
-"PO-Revision-Date: 2021-10-04 22:59+0200\n"
+"POT-Creation-Date: 2021-10-04 23:03+0200\n"
+"PO-Revision-Date: 2021-10-04 23:02+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
 "Language: fr\n"
@@ -308,7 +308,9 @@ msgstr ""
 "requis (#:webid et #:client-id), soit (#:jwt-header et #:jwt-payload)"
 
 #: src/scm/webid-oidc/authorization-page-unsafe.scm:52
-#: src/scm/webid-oidc/hello-world.scm:40 src/scm/webid-oidc/hello-world.scm:167
+#: src/scm/webid-oidc/client.scm:307 src/scm/webid-oidc/client.scm:324
+#: src/scm/webid-oidc/client.scm:341 src/scm/webid-oidc/hello-world.scm:40
+#: src/scm/webid-oidc/hello-world.scm:167
 #: src/scm/webid-oidc/hello-world.scm:187
 #: src/scm/webid-oidc/identity-provider.scm:136
 #: src/scm/webid-oidc/token-endpoint.scm:112
@@ -318,6 +320,7 @@ msgid "xml-lang|en"
 msgstr "fr"
 
 #: src/scm/webid-oidc/authorization-page-unsafe.scm:67
+#: src/scm/webid-oidc/client.scm:309
 msgid "page-title|Authorization"
 msgstr "Autorisation"
 
@@ -506,6 +509,62 @@ msgstr ""
 msgid "cannot serve the public manifest"
 msgstr "impossible de servir le manifeste public"
 
+#: src/scm/webid-oidc/client.scm:177
+msgid "Example application"
+msgstr "Application exemple"
+
+#: src/scm/webid-oidc/client.scm:204
+msgid "#:client-name should be a string"
+msgstr "#:client-name doit être une chaîne de caractères"
+
+#: src/scm/webid-oidc/client.scm:211
+msgid "#:client-uri should be an URI"
+msgstr "#:client-uri doit être une URI"
+
+#: src/scm/webid-oidc/client.scm:220
+msgid "#:response-types should be a list of symbols"
+msgstr "#:response-types doit être une liste de symboles"
+
+#: src/scm/webid-oidc/client.scm:229
+msgid "#:grant-types should be a list of symbols"
+msgstr "#:grant-types doit être une liste de symboles"
+
+#: src/scm/webid-oidc/client.scm:281 src/scm/webid-oidc/resource-server.scm:173
+msgid "reason-phrase|Not Modified"
+msgstr "Non Modifié"
+
+#: src/scm/webid-oidc/client.scm:311
+msgid ""
+"You have been authorized. Please paste the following code in the application:"
+msgstr ""
+"Vous avez été autorisé. Veuillez coller le code suivant dans votre "
+"application :"
+
+#: src/scm/webid-oidc/client.scm:316
+msgid "reason-phrase|Invalid Request"
+msgstr "Requête Invalide"
+
+#: src/scm/webid-oidc/client.scm:326
+msgid "page-title|Error"
+msgstr "Erreur"
+
+#: src/scm/webid-oidc/client.scm:328
+msgid "Your identity provider did not authorize you. :("
+msgstr "Votre fournisseur d’identité ne vous a pas autorisé. :("
+
+#: src/scm/webid-oidc/client.scm:333
+#: src/scm/webid-oidc/identity-provider.scm:129
+msgid "reason-phrase|Not Found"
+msgstr "Non Trouvé"
+
+#: src/scm/webid-oidc/client.scm:343
+msgid "page-title|Not Found"
+msgstr "Non Trouvé"
+
+#: src/scm/webid-oidc/client.scm:345
+msgid "This page does not exist on the server."
+msgstr "Cette page n’existe pas sur le serveur."
+
 #: src/scm/webid-oidc/client/accounts.scm:239
 msgid "The refresh token has expired."
 msgstr "le jeton de rafraîchissement a expiré."
@@ -1077,10 +1136,6 @@ msgstr ""
 msgid "Warning: generating a new key pair."
 msgstr "Attention : génération d'une nouvelle paire de clé."
 
-#: src/scm/webid-oidc/identity-provider.scm:129
-msgid "reason-phrase|Not Found"
-msgstr "Non Trouvé"
-
 #: src/scm/webid-oidc/jti.scm:59
 #, scheme-format
 msgid "a replay has been detected with JTI ~s"
@@ -2348,10 +2403,6 @@ msgstr "~a : échec d’authentification\n"
 msgid "reason-phrase|Precondition Failed"
 msgstr "Échec de Précondition"
 
-#: src/scm/webid-oidc/resource-server.scm:173
-msgid "reason-phrase|Not Modified"
-msgstr "Non Modifié"
-
 #: src/scm/webid-oidc/resource-server.scm:188
 msgid "The owner is not defined."
 msgstr "Le propriétaire n’est pas défini."
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 6c1e368..9200332 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -20,6 +20,8 @@
   #:use-module (webid-oidc oidc-id-token)
   #:use-module (webid-oidc dpop-proof)
   #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc client-manifest)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
@@ -43,6 +45,7 @@
   #:use-module (ice-9 match)
   #:use-module (sxml simple)
   #:use-module (oop goops)
+  #:duplicates (merge-generics)
   #:re-export
   (
    (client:<client> . <client>)
@@ -59,6 +62,8 @@
    request
 
    serve-application
+
+   <extended-client-manifest>
    )
   #:declarative? #t)
 
@@ -158,111 +163,183 @@
       ((kw value args ...)
        (scan-arguments args headers `(,value ,kw ,@non-header-args) method)))))
 
-(define* (serve-application id redirect-uri
-                            #:key
-                            (client-name "Example application")
-                            (client-uri "https://webid-oidc-demo.planete-kraus.eu"))
-  (when (string? id)
-    (set! id (string->uri id)))
-  (when (string? redirect-uri)
-    (set! redirect-uri (string->uri redirect-uri)))
-  (when (string? client-uri)
-    (set! client-uri (string->uri client-uri)))
-  (let* ((manifest
-          (format #f
-                  "{
-  \"@context\": \"https://www.w3.org/ns/solid/oidc-context.jsonld\",
-  \"client_id\" : \"~a\",
-  \"redirect_uris\" : [\"~a\"],
-  \"client_name\" : \"~a\",
-  \"client_uri\" : \"~a\",
-  \"grant_types\" : [\"refresh_token\", \"authorization_code\"],
-  \"response_types\" : [\"code\"]
-}
-"
-                  (uri->string id)
-                  (uri->string redirect-uri)
-                  client-name
-                  (uri->string id)))
-         (manifest-etag (stubs:hash 'SHA-256 manifest)))
+(define-class <extended-client-manifest> (<client-manifest>)
+  (client-name #:init-keyword #:client-name #:accessor client-name)
+  (client-uri #:init-keyword #:client-uri #:accessor client-uri)
+  (grant-types #:init-keyword #:grant-types #:accessor grant-types)
+  (response-types #:init-keyword #:response-types #:accessor response-types)
+  #:module-name '(webid-oidc client))
+
+(define-method (initialize (client <extended-client-manifest>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((client-name (G_ "Example application"))
+    (client-uri "https://webid-oidc-demo.planete-kraus.eu")
+    (grant-types '(refresh_token authorization_code))
+    (response-types '(code)))
+   (let fix-grant-types ((grant-types grant-types)
+                         (ok '()))
+     (match grant-types
+       (()
+        (let ((grant-types (reverse ok)))
+          (let fix-response-types ((response-types response-types)
+                                   (ok '()))
+            (match response-types
+              (()
+               (let ((response-types (reverse ok)))
+                 (let fix-client-uri ((client-uri client-uri))
+                   (match client-uri
+                     ((? uri? client-uri)
+                      (let fix-client-name ((client-name client-name))
+                        (match client-name
+                          ((? string? client-name)
+                           (begin
+                             (slot-set! client 'client-name client-name)
+                             (slot-set! client 'client-uri client-uri)
+                             (slot-set! client 'grant-types grant-types)
+                             (slot-set! client 'response-types response-types)))
+                          (else
+                           (scm-error 'wrong-type-arg "make"
+                                      (G_ "#:client-name should be a string")
+                                      '()
+                                      (list client-name))))))
+                     ((? string? (= string->uri (? uri? client-uri)))
+                      (fix-client-uri client-uri))
+                     (else
+                      (scm-error 'wrong-type-arg "make"
+                                 (G_ "#:client-uri should be an URI")
+                                 '()
+                                 (list client-uri)))))))
+              (((or (? string? (= string->symbol hd))
+                    (? symbol? hd))
+                response-types ...)
+               (fix-response-types response-types `(,hd ,@ok)))
+              (else
+               (scm-error 'wrong-type-arg "make"
+                          (G_ "#:response-types should be a list of symbols")
+                          '()
+                          (list response-types)))))))
+       (((or (? string? (= string->symbol hd))
+             (? symbol? hd))
+         grant-types ...)
+        (fix-grant-types grant-types `(,hd ,@ok)))
+       (else
+        (scm-error 'wrong-type-arg "make"
+                   (G_ "#:grant-types should be a list of symbols")
+                   '()
+                   (list grant-types)))))))
+
+(define-method (->json-data (client <extended-client-manifest>))
+  (let ((other
+         (catch 'goops-error
+           (lambda ()
+             (next-method))
+           (lambda _
+             '()))))
+    (let ((all
+           `((client_name . ,(client-name client))
+             (client_uri . ,(uri->string (client-uri client)))
+             (grant_types . ,(list->vector (map symbol->string (grant-types client))))
+             (response_types . ,(list->vector (map symbol->string (response-types client))))
+             ,@other)))
+      ;; Put @context first
+      (receive (context non-context)
+          (let search-context ((fields all)
+                               (context-ones '())
+                               (non-context-ones '()))
+            (match fields
+              ((('@context . ,context) fields ...)
+               (search-context fields `(,context ,@context-ones) non-context-ones))
+              ((non-context fields ...)
+               (search-context fields context-ones `(,non-context ,@non-context-ones)))
+              (()
+               (values (reverse context-ones) (reverse non-context-ones)))))
+        (append
+         (map (lambda (ctx) `(@context . ,ctx)) context)
+         non-context)))))
+
+(define* (serve-application id redirect-uri . args)
+  (let ((manifest (apply make <extended-client-manifest>
+                         #:client-id id
+                         #:redirect-uris (list redirect-uri)
+                         args)))
     (lambda (request request-body)
-      (let ((uri (request-uri request)))
-        (cond
-         ((equal? (uri-path uri) (uri-path id))
-          (let ((if-none-match (request-if-none-match request)))
-            (if (and (list? if-none-match)
-                     (member manifest-etag
-                             (map car (request-if-none-match request))))
-                (values
-                 (build-response
-                  #:code 304
-                  #:reason-phrase "Not Modified"
-                  #:headers `((content-type application/ld+json)
-                              (etag . (,manifest-etag . #t))))
-                 #f)
-                (values
-                 (build-response
-                  #:headers `((content-type application/ld+json)
-                              (etag . (,manifest-etag . #t))
-                              (cache-control public must-revalidate)))
-                 manifest))))
-         ((equal? (uri-path uri) (uri-path redirect-uri))
-          (let ((query-args
-                 (map
-                  (lambda (key=value)
-                    (let ((splits
-                           (map uri-decode (string-split key=value #\=))))
-                      (if (or (null? splits) (null? (cdr splits)))
-                          splits
-                          (cons (string->symbol (car splits)) (cdr splits)))))
-                  (string-split (uri-query uri) #\&))))
-            (let ((code (assq-ref query-args 'code)))
-              (if code
-                  (values
-                   (build-response
-                    #:headers `((content-type application/xhtml+xml)))
-                   (with-output-to-string
-                     (lambda ()
-                       (sxml->xml
-                        `(*TOP*
-                          (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-                          (html (@ (xmlns "http://www.w3.org/1999/xhtml")
-                                   (xml:lang "en"))
-                                (head
-                                 (title "Authorization"))
-                                (body
-                                 (p "You have been authorized. Please paste the following code in the application:")
-                                 (p (strong ,code)))))))))
-                  (values
-                   (build-response
-                    #:code 400
-                    #:reason-phrase "Invalid Request"
-                    #:headers `((content-type application/xhtml+xml)))
-                   (with-output-to-string
-                     (lambda ()
-                       (sxml->xml
-                        `(*TOP*
-                          (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-                          (html (@ (xmlns "http://www.w3.org/1999/xhtml")
-                                   (xml:lang "en"))
-                                (head
-                                 (title "Error"))
-                                (body
-                                 (p "Your identity provider did not authorize you. :("))))))))))))
-         (else
-          (values
-           (build-response
-            #:code 404
-            #:reason-phrase "Not Found"
-            #:headers `((content-type application/xhtml+xml)))
-           (with-output-to-string
-             (lambda ()
-               (sxml->xml
-                `(*TOP*
-                  (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-                  (html (@ (xmlns "http://www.w3.org/1999/xhtml")
-                           (xml:lang "en"))
-                        (head
-                         (title "Not Found"))
-                        (body
-                         (p "This page does not exist on the server."))))))))))))))
+      (parameterize ((web-locale request))
+        (let ((uri (request-uri request)))
+          (cond
+           ((equal? (uri-path uri) (uri-path id))
+            (receive (response response-body) (serve manifest #f)
+              (let ((if-none-match (request-if-none-match request))
+                    (etag (response-etag response)))
+                (if (and (list? if-none-match)
+                         etag
+                         (member (car etag) (map car if-none-match)))
+                    (values
+                     (build-response
+                      #:code 304
+                      #:reason-phrase (W_ "reason-phrase|Not Modified")
+                      #:headers `((content-type application/ld+json)
+                                  (etag . ,etag)))
+                     #f)
+                    (values response response-body)))))
+           ((equal? (uri-path uri) (uri-path redirect-uri))
+            (let ((query-args
+                   (map
+                    (lambda (key=value)
+                      (let ((splits
+                             (map uri-decode (string-split key=value #\=))))
+                        (if (or (null? splits) (null? (cdr splits)))
+                            splits
+                            (cons (string->symbol (car splits)) (cdr splits)))))
+                    (string-split (uri-query uri) #\&))))
+              (let ((code (assq-ref query-args 'code)))
+                (if code
+                    (values
+                     (build-response
+                      #:headers `((content-type application/xhtml+xml)))
+                     (with-output-to-string
+                       (lambda ()
+                         (sxml->xml
+                          `(*TOP*
+                            (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                            (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                                     (xml:lang ,(W_ "xml-lang|en")))
+                                  (head
+                                   (title ,(W_ "page-title|Authorization")))
+                                  (body
+                                   (p ,(W_ "You have been authorized. Please paste the following code in the application:"))
+                                   (p (strong ,code)))))))))
+                    (values
+                     (build-response
+                      #:code 400
+                      #:reason-phrase (W_ "reason-phrase|Invalid Request")
+                      #:headers `((content-type application/xhtml+xml)))
+                     (with-output-to-string
+                       (lambda ()
+                         (sxml->xml
+                          `(*TOP*
+                            (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                            (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                                     (xml:lang ,(W_ "xml-lang|en")))
+                                  (head
+                                   (title ,(W_ "page-title|Error")))
+                                  (body
+                                   (p ,(W_ "Your identity provider did not authorize you. :(")))))))))))))
+           (else
+            (values
+             (build-response
+              #:code 404
+              #:reason-phrase (W_ "reason-phrase|Not Found")
+              #:headers `((content-type application/xhtml+xml)))
+             (with-output-to-string
+               (lambda ()
+                 (sxml->xml
+                  `(*TOP*
+                    (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                    (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                             (xml:lang ,(W_ "xml-lang|en")))
+                          (head
+                           (title ,(W_ "page-title|Not Found")))
+                          (body
+                           (p ,(W_ "This page does not exist on the server."))))))))))))))))