diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-01 09:38:10 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-10-04 23:04:41 +0200 |
commit | e3f75ea67bb6442a9613088d42f98c68dce6e816 (patch) | |
tree | 36fd9dd33a32ba4a79e805a09d6d3b8ec2ddf110 | |
parent | 424989e6541eb8a7c2c7d80ea9988e2dfa882426 (diff) |
client: extend the client manifest for the client service
-rw-r--r-- | po/disfluid.pot | 69 | ||||
-rw-r--r-- | po/fr.po | 73 | ||||
-rw-r--r-- | src/scm/webid-oidc/client.scm | 291 |
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 "" @@ -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.")))))))))))))))) |