From 9e2873b126bff9e0d13d2953729def4b0b3cd73e Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Thu, 30 Sep 2021 19:51:38 +0200 Subject: Client manifest: use GOOPS --- doc/disfluid.texi | 110 ++++++++++ po/disfluid.pot | 76 +++---- po/fr.po | 158 ++++++++++----- src/scm/webid-oidc/authorization-endpoint.scm | 7 +- src/scm/webid-oidc/client-manifest.scm | 279 +++++++++++++------------- tests/authorization-endpoint-submit-form.scm | 43 ++-- tests/client-manifest-fraudulent.scm | 28 +-- tests/client-manifest-public.scm | 29 +-- tests/client-manifest.scm | 27 ++- 9 files changed, 468 insertions(+), 289 deletions(-) diff --git a/doc/disfluid.texi b/doc/disfluid.texi index 5523a21..f655f76 100644 --- a/doc/disfluid.texi +++ b/doc/disfluid.texi @@ -63,6 +63,7 @@ is tracked in the Guix channel * Common parameters:: * Managing keys:: * OIDC discovery:: +* Client manifest:: * The Json Web Token:: * Caching on server side:: * Content negociation:: @@ -542,6 +543,115 @@ this value. They will not revalidate it until after @var{expiration-date}, a SRFI-19 date. @end deffn +@node Client manifest +@chapter Client manifest +To make sure that a client application is legitimate, it is mandated +that it serves a public document under its ID URI, and that document +should confirm the URI and the redirection URI, where the client +application gets the authorization code. + +@deftp {Class} () @var{client-id} @var{redirect-uris} +This is the class encapsulating a very basic client +manifest. @var{client-id} is an URI, and @var{redirect-uris} is a list +of URIs. + +You can construct one by providing both @code{#:@var{client-id}} and +@code{#:@var{redirect-uris}}, or by providing only +@code{#:@var{client-id}}, in which case it will be downloaded from the +web. +@end deftp + +Clients that cannot serve pages should use the anonymous client ID, +that accepts all redirect URIs. + +@deffn {Generic} client-id @var{manifest} +Return the client ID of @var{manifest}. +@end deffn + +@deffn {Generic} redirect-uris @var{manifest} +Return the list of accepted redirection URIs for @var{manifest}. +@end deffn + +@deffn {Generic} ->json-data @var{manifest} +Convert @var{manifest} to JSON data (alists for objects, vectors for +arrays). You should override this method if you design an extended +client manifest class. +@end deffn + +@deffn {Generic} check-redirect-uri @var{manifest} @var{uri} +Check that @var{manifest} controls @var{uri}, where to send the +authorization code. Raises an exception if that’s not the case. +@end deffn + +@deftp {Exception type} &invalid-client-manifest +This exception is raised when the client manifest is invalid. +@end deftp + +@deffn {function} make-invalid-client-manifest +Constructor for the @code{&invalid-client-manifest} exception type. +@end deffn + +@deffn {function} invalid-client-manifest? @var{exception} +Check whether @var{exception} was raised because of an invalid client +manifest. +@end deffn + +@deftp {Exception type} &unauthorized-redirect-uri +This exception is raised when the requested authorization URI is +unauthorized. +@end deftp + +@deffn {function} make-unauthorized-redirect-uri +Constructor for the @code{&unauthorized-redirect-uri} exception type. +@end deffn + +@deffn {function} unauthorized-redirect-uri? @var{exception} +Check whether @var{exception} was raised because of an unauthorized +redirection URI. +@end deffn + +@deftp {Exception type} &inconsistent-client-manifest +This exception is raised when the client ID does not match what the +client manifest says. +@end deftp + +@deffn {function} make-inconsistent-client-manifest +Constructor for the @code{&inconsistent-client-manifest} exception type. +@end deffn + +@deffn {function} inconsistent-client-manifest? @var{exception} +Check whether @var{exception} was raised because of an inconsistent +client manifest. +@end deffn + +@deftp {Exception type} &cannot-serve-public-manifest +This exception is raised when the manifest to serve has the public +client URI as ID. +@end deftp + +@deffn {function} make-cannot-serve-public-manifest +Constructor for the @code{&cannot-serve-public-manifest} exception type. +@end deffn + +@deffn {function} cannot-serve-public-manifest? @var{exception} +Check whether @var{exception} was raised because the server wants to +serve a public manifest. +@end deffn + +@deftp {Exception type} &cannot-fetch-client-manifest +This exception is raised when the server does not behave correctly +when fetching the manifest. +@end deftp + +@deffn {function} make-cannot-fetch-client-manifest +Constructor for the @code{&cannot-fetch-client-manifest} exception type. +@end deffn + +@deffn {function} cannot-fetch-client-manifest? @var{exception} +Check whether @var{exception} was raised because we could not fetch a +client manifest. +@end deffn + @node The Json Web Token @chapter The Json Web Token diff --git a/po/disfluid.pot b/po/disfluid.pot index e1692ba..0187767 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 22:50+0200\n" +"POT-Creation-Date: 2021-10-04 22:52+0200\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" @@ -238,6 +238,7 @@ msgid "#:webid should be an URI" msgstr "" #: src/scm/webid-oidc/access-token.scm:122 +#: src/scm/webid-oidc/client-manifest.scm:212 msgid "#:client-id should be an URI" msgstr "" @@ -390,74 +391,77 @@ msgstr "" msgid "Unsupported delegate catalog URI scheme: ~s\n" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:111 +#: src/scm/webid-oidc/client-manifest.scm:143 #, scheme-format -msgid "this is not a client manifest: ~a" +msgid "cannot fetch a client manifest: ~a" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:113 -msgid "this is not a client manifest" +#: src/scm/webid-oidc/client-manifest.scm:145 +msgid "cannot fetch a client manifest" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:117 -msgid "" -"

The client manifest could\n" -"not be queried. It can be because the client application is down, or\n" -"it is incomplete, or unusable for other reasons.

" +#: src/scm/webid-oidc/client-manifest.scm:154 +#, scheme-format +msgid "the server responded with code ~a" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:144 +#: src/scm/webid-oidc/client-manifest.scm:157 #, scheme-format -msgid "the client manifest is missing ~s" +msgid "The server hosting your application responded with code ~a." msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:155 -#, scheme-format -msgid "~s is an invalid \"client_id\" value, because it is not an URI" +#: src/scm/webid-oidc/client-manifest.scm:166 +#: src/scm/webid-oidc/client-manifest.scm:195 +msgid "the client manifest does not have a client_id field" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:160 -msgid "at least one of the redirect URIs is not a proper URI" +#: src/scm/webid-oidc/client-manifest.scm:168 +#: src/scm/webid-oidc/client-manifest.scm:197 +msgid "" +"The server hosting your application does not behave correctly, because it " +"lacks the client_id field." msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:162 -msgid "the \"redirect_uris\" field should be a vector of URIs" +#: src/scm/webid-oidc/client-manifest.scm:188 +msgid "the client manifest does not have a redirect_uris field" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:167 -msgid "the client manifest should be a JSON object" +#: src/scm/webid-oidc/client-manifest.scm:190 +msgid "" +"The server hosting your application does not behave correctly, because it " +"lacks the redirect_uris field." msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:189 +#: src/scm/webid-oidc/client-manifest.scm:203 #, scheme-format -msgid "the client manifest does not allow ~s as a redirection uri" +msgid "the client manifest under ~s has a client_id of ~s" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:193 -#, scheme-format +#: src/scm/webid-oidc/client-manifest.scm:207 msgid "" -"

The application wants to get your\n" -"authorization through ~s, which is not\n" -"approved.

" +"The application you want to use does not control the domain name it appears " +"to represent." msgstr "" #: src/scm/webid-oidc/client-manifest.scm:221 -msgid "cannot serve the public manifest" +msgid "#:redirect-uris should be a list of URIs" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:240 +#: src/scm/webid-oidc/client-manifest.scm:231 #, scheme-format -msgid "cannot fetch the client manifest ~s: ~a" +msgid "the client manifest does not allow ~s as a redirection uri" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:243 +#: src/scm/webid-oidc/client-manifest.scm:235 #, scheme-format -msgid "cannot fetch the client manifest ~s" +msgid "" +"

The application wants to get your\n" +"authorization through ~s, which is not\n" +"approved.

" msgstr "" -#: src/scm/webid-oidc/client-manifest.scm:262 -#, scheme-format -msgid "the client manifest is dereferenced from ~s, but it pretends to be ~s" +#: src/scm/webid-oidc/client-manifest.scm:263 +msgid "cannot serve the public manifest" msgstr "" #: src/scm/webid-oidc/client/accounts.scm:239 diff --git a/po/fr.po b/po/fr.po index b2c5a8e..e7d5d7f 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 22:50+0200\n" -"PO-Revision-Date: 2021-09-29 12:42+0200\n" +"POT-Creation-Date: 2021-10-04 22:52+0200\n" +"PO-Revision-Date: 2021-10-04 22:56+0200\n" "Last-Translator: Vivien Kraus \n" "Language-Team: French \n" "Language: fr\n" @@ -264,6 +264,7 @@ msgid "#:webid should be an URI" msgstr "#:webid doit être une URI" #: src/scm/webid-oidc/access-token.scm:122 +#: src/scm/webid-oidc/client-manifest.scm:212 msgid "#:client-id should be an URI" msgstr "#:client-id doit être une URI" @@ -424,54 +425,74 @@ msgstr "URI relative invalide" msgid "Unsupported delegate catalog URI scheme: ~s\n" msgstr "Schéma d’URI pour un catalogue délégé non supporté : ~s\n" -#: src/scm/webid-oidc/client-manifest.scm:111 +#: src/scm/webid-oidc/client-manifest.scm:143 #, scheme-format -msgid "this is not a client manifest: ~a" -msgstr "ce n’est pas un manifeste client : ~a" +msgid "cannot fetch a client manifest: ~a" +msgstr "impossible de télécharger un manifeste client : ~a" -#: src/scm/webid-oidc/client-manifest.scm:113 -msgid "this is not a client manifest" -msgstr "ce n’est pas un manifeste client" +#: src/scm/webid-oidc/client-manifest.scm:145 +msgid "cannot fetch a client manifest" +msgstr "impossible de télécharger un manifeste client" -#: src/scm/webid-oidc/client-manifest.scm:117 +#: src/scm/webid-oidc/client-manifest.scm:154 +#, scheme-format +msgid "the server responded with code ~a" +msgstr "le serveur a répondu avec le code ~a" + +#: src/scm/webid-oidc/client-manifest.scm:157 +#, scheme-format +msgid "The server hosting your application responded with code ~a." +msgstr "Le serveur hébergeant votre application a répondu avec le code ~a." + +#: src/scm/webid-oidc/client-manifest.scm:166 +#: src/scm/webid-oidc/client-manifest.scm:195 +msgid "the client manifest does not have a client_id field" +msgstr "le manifeste client n’a pas de champ client_id" + +#: src/scm/webid-oidc/client-manifest.scm:168 +#: src/scm/webid-oidc/client-manifest.scm:197 msgid "" -"

The client manifest could\n" -"not be queried. It can be because the client application is down, or\n" -"it is incomplete, or unusable for other reasons.

" +"The server hosting your application does not behave correctly, because it " +"lacks the client_id field." msgstr "" -"

Le manifeste client n’a pas pu être requêté. Peut-être l’application " -"cliente est-elle hors ligne, ou le manifeste est incomplet. ou inutilisable " -"pour d’autres raisons.

" +"Le serveur hébergeant votre application ne se comporte pas correctement, " +"parce qu’il lui manque le champ client_id." -#: src/scm/webid-oidc/client-manifest.scm:144 -#, scheme-format -msgid "the client manifest is missing ~s" -msgstr "il manque ~s au manifeste client" +#: src/scm/webid-oidc/client-manifest.scm:188 +msgid "the client manifest does not have a redirect_uris field" +msgstr "le manifeste client n’a pas de champ redirect_uris" -#: src/scm/webid-oidc/client-manifest.scm:155 -#, scheme-format -msgid "~s is an invalid \"client_id\" value, because it is not an URI" +#: src/scm/webid-oidc/client-manifest.scm:190 +msgid "" +"The server hosting your application does not behave correctly, because it " +"lacks the redirect_uris field." msgstr "" -"~s est une valeur invalide pour « client_id », parce que ce n’est pas une URI" +"Le serveur hébergeant votre application ne se comporte pas correctement, " +"parce qu’il lui manque le champ redirect_uris." -#: src/scm/webid-oidc/client-manifest.scm:160 -msgid "at least one of the redirect URIs is not a proper URI" -msgstr "l’une des URI de redirection au moins n’est pas une vraie URI" +#: src/scm/webid-oidc/client-manifest.scm:203 +#, scheme-format +msgid "the client manifest under ~s has a client_id of ~s" +msgstr "le manifeste client à ~s a un client_id valant ~s" -#: src/scm/webid-oidc/client-manifest.scm:162 -msgid "the \"redirect_uris\" field should be a vector of URIs" -msgstr "le champ « redirect_uris » doit être un vecteur d’URIs" +#: src/scm/webid-oidc/client-manifest.scm:207 +msgid "" +"The application you want to use does not control the domain name it appears " +"to represent." +msgstr "" +"L’application que vous voulez utiliser ne contrôle pas le nom de domaine " +"qu’elle prétend représenter." -#: src/scm/webid-oidc/client-manifest.scm:167 -msgid "the client manifest should be a JSON object" -msgstr "le manifeste client doit être un objet JSON" +#: src/scm/webid-oidc/client-manifest.scm:221 +msgid "#:redirect-uris should be a list of URIs" +msgstr "#:redirect-uris doit être une liste d’URIs" -#: src/scm/webid-oidc/client-manifest.scm:189 +#: src/scm/webid-oidc/client-manifest.scm:231 #, scheme-format msgid "the client manifest does not allow ~s as a redirection uri" msgstr "le manifeste client n’autorise pas ~s comme URI de redirection" -#: src/scm/webid-oidc/client-manifest.scm:193 +#: src/scm/webid-oidc/client-manifest.scm:235 #, scheme-format msgid "" "

The application wants to get your\n" @@ -481,25 +502,10 @@ msgstr "" "

L’applicationn veut récupérer votre code d’autorisation via ~s, qui n’est pas approuvé.

" -#: src/scm/webid-oidc/client-manifest.scm:221 +#: src/scm/webid-oidc/client-manifest.scm:263 msgid "cannot serve the public manifest" msgstr "impossible de servir le manifeste public" -#: src/scm/webid-oidc/client-manifest.scm:240 -#, scheme-format -msgid "cannot fetch the client manifest ~s: ~a" -msgstr "impossible de télécharger le manifeste client ~s : ~a" - -#: src/scm/webid-oidc/client-manifest.scm:243 -#, scheme-format -msgid "cannot fetch the client manifest ~s" -msgstr "impossible de télécharger le manifeste client ~s" - -#: src/scm/webid-oidc/client-manifest.scm:262 -#, scheme-format -msgid "the client manifest is dereferenced from ~s, but it pretends to be ~s" -msgstr "le manifeste client est déréférencé depuis ~s, mais il prétend être ~s" - #: src/scm/webid-oidc/client/accounts.scm:239 msgid "The refresh token has expired." msgstr "le jeton de rafraîchissement a expiré." @@ -2551,6 +2557,54 @@ msgstr "Annuler" msgid "Update" msgstr "Mettre à jour" +#, scheme-format +#~ msgid "this is not a client manifest: ~a" +#~ msgstr "ce n’est pas un manifeste client : ~a" + +#~ msgid "this is not a client manifest" +#~ msgstr "ce n’est pas un manifeste client" + +#~ msgid "" +#~ "

The client manifest could\n" +#~ "not be queried. It can be because the client application is down, or\n" +#~ "it is incomplete, or unusable for other reasons.

" +#~ msgstr "" +#~ "

Le manifeste client n’a pas pu être requêté. Peut-être l’application " +#~ "cliente est-elle hors ligne, ou le manifeste est incomplet. ou " +#~ "inutilisable pour d’autres raisons.

" + +#, scheme-format +#~ msgid "the client manifest is missing ~s" +#~ msgstr "il manque ~s au manifeste client" + +#, scheme-format +#~ msgid "~s is an invalid \"client_id\" value, because it is not an URI" +#~ msgstr "" +#~ "~s est une valeur invalide pour « client_id », parce que ce n’est pas une " +#~ "URI" + +#~ msgid "at least one of the redirect URIs is not a proper URI" +#~ msgstr "l’une des URI de redirection au moins n’est pas une vraie URI" + +#~ msgid "the client manifest should be a JSON object" +#~ msgstr "le manifeste client doit être un objet JSON" + +#, fuzzy, scheme-format +#~| msgid "cannot fetch a client manifest: ~a" +#~ msgid "cannot fetch the client manifest ~s: ~a" +#~ msgstr "impossible de télécharger un manifeste client : ~a" + +#, fuzzy, scheme-format +#~| msgid "cannot fetch a client manifest: ~a" +#~ msgid "cannot fetch the client manifest ~s" +#~ msgstr "impossible de télécharger un manifeste client : ~a" + +#, scheme-format +#~ msgid "" +#~ "the client manifest is dereferenced from ~s, but it pretends to be ~s" +#~ msgstr "" +#~ "le manifeste client est déréférencé depuis ~s, mais il prétend être ~s" + #~ msgid "Hello, world!\n" #~ msgstr "Bonjour, le monde !\n" @@ -3147,10 +3201,6 @@ msgstr "Mettre à jour" #~ msgid "~a does not have a client manifest registration triple" #~ msgstr "~a n’a pas de triplet d’enregistrement de manifeste client" -#, scheme-format -#~ msgid "the client manifest at ~a is advertised for ~a" -#~ msgstr "le manifeste client ~a est publié pour ~a" - #, scheme-format #~ msgid "I could not fetch the client manifest of ~a (because ~a)" #~ msgstr "je n’ai pas pu récupérer le manifeste client de ~a (parce que ~a)" 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-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-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_ "

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.

")) - ((*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-id #:init-keyword #:client-id #:accessor client-id #:->jwks uri->string) + (redirect-uris #:init-keyword #:redirect-uris #:accessor redirect-uris #:->jwks uri->string) + #:metaclass + #: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 ) 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.

")) ((_ uris ...) (check-redirect mf uris redir)))) -(define (client-manifest-check-redirect-uri mf redir) +(define-method (check-redirect-uri (mf ) 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 )) + `((@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 ) 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.

")) (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)))))) diff --git a/tests/authorization-endpoint-submit-form.scm b/tests/authorization-endpoint-submit-form.scm index 3de3e19..4f11db0 100644 --- a/tests/authorization-endpoint-submit-form.scm +++ b/tests/authorization-endpoint-submit-form.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -14,21 +14,25 @@ ;; You should have received a copy of the GNU Affero General Public License ;; along with this program. If not, see . -(use-modules (webid-oidc authorization-endpoint) - (webid-oidc authorization-code) - (webid-oidc client-manifest) - (webid-oidc jwk) - (webid-oidc cache) - (webid-oidc jti) - (webid-oidc testing) - ((webid-oidc parameters) #:prefix p:) - (web uri) - (web request) - (web response) - (srfi srfi-19) - (web response) - (ice-9 optargs) - (ice-9 receive)) +(define-module (tests authorization-endpoint-submit-form) + #:use-module (webid-oidc authorization-endpoint) + #:use-module (webid-oidc authorization-code) + #:use-module (webid-oidc client-manifest) + #:use-module (webid-oidc jwk) + #:use-module (webid-oidc cache) + #:use-module (webid-oidc jti) + #:use-module (webid-oidc testing) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module (web uri) + #:use-module (web request) + #:use-module (web response) + #:use-module (srfi srfi-19) + #:use-module (web response) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (oop goops) + #:declarative? #t + #:duplicates (merge-generics)) (with-test-environment "authorization-endpoint-submit-form" @@ -42,9 +46,10 @@ (define what-uri-to-expect client) (define served (receive (response response-body) - (serve-client-manifest - (time-utc->date (make-time time-utc 0 3600)) - (make-client-manifest client (list redirect))) + (serve (make + #:client-id client + #:redirect-uris (list redirect)) + (time-utc->date (make-time time-utc 0 3600))) (cons response response-body))) (define the-response (car served)) (define the-response-body (cdr served)) diff --git a/tests/client-manifest-fraudulent.scm b/tests/client-manifest-fraudulent.scm index 548f6c1..b1803f4 100644 --- a/tests/client-manifest-fraudulent.scm +++ b/tests/client-manifest-fraudulent.scm @@ -14,16 +14,20 @@ ;; You should have received a copy of the GNU Affero General Public License ;; along with this program. If not, see . -(use-modules (webid-oidc client-manifest) - (webid-oidc cache) - (webid-oidc testing) - ((webid-oidc parameters) #:prefix p:) - (webid-oidc errors) - (web uri) - (srfi srfi-19) - (web response) - (ice-9 optargs) - (ice-9 receive)) +(define-module (tests client-manifest-fraudulent) + #:use-module (webid-oidc client-manifest) + #:use-module (webid-oidc cache) + #:use-module (webid-oidc testing) + #:use-module ((webid-oidc parameters) #:prefix p:) + #:use-module (webid-oidc errors) + #:use-module (web uri) + #:use-module (srfi srfi-19) + #:use-module (web response) + #:use-module (ice-9 optargs) + #:use-module (ice-9 receive) + #:use-module (oop goops) + #:declarative? #t + #:duplicates (merge-generics)) ;; In this example, the client_id of the oidcRegistration does not ;; match the base URI. @@ -68,8 +72,8 @@ (exit 3))) (lambda () (parameterize ((p:current-date 0)) - (get-client-manifest - (string->uri "https://fraudulent-app.example.com/id#app"))) + (make + #:client-id "https://fraudulent-app.example.com/id#app")) (exit 4)) #:unwind? #t #:unwind-for-type &inconsistent-client-manifest)))))) diff --git a/tests/client-manifest-public.scm b/tests/client-manifest-public.scm index f4e0bd5..478679c 100644 --- a/tests/client-manifest-public.scm +++ b/tests/client-manifest-public.scm @@ -14,33 +14,34 @@ ;; You should have received a copy of the GNU Affero General Public License ;; along with this program. If not, see . -(use-modules (webid-oidc client-manifest) - (webid-oidc testing) - (webid-oidc errors) - (web uri) - (srfi srfi-19) - (web response)) +(define-module (tests client-manifest-public) + #:use-module (webid-oidc client-manifest) + #:use-module (webid-oidc testing) + #:use-module (webid-oidc errors) + #:use-module (web uri) + #:use-module (srfi srfi-19) + #:use-module (web response) + #:use-module (oop goops) + #:declarative? #t) (with-test-environment "client-manifest-public" (lambda () (define mf - (get-client-manifest - (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient"))) - (define id (client-manifest-client-id mf)) + (make + #:client-id "http://www.w3.org/ns/solid/terms#PublicOidcClient")) + (define id (client-id mf)) (unless (equal? id (string->uri "http://www.w3.org/ns/solid/terms#PublicOidcClient")) (exit 2)) - (unless (client-manifest-check-redirect-uri mf "https://example.com") + (unless (check-redirect-uri mf "https://example.com") (exit 3)) (with-exception-handler (lambda (error) (unless (cannot-serve-public-manifest? error) (exit 4))) (lambda () - (serve-client-manifest - (time-utc->date - (make-time time-utc 0 0)) - mf) + (serve mf (time-utc->date + (make-time time-utc 0 0))) (exit 5)) #:unwind? #t #:unwind-for-type &cannot-serve-public-manifest))) diff --git a/tests/client-manifest.scm b/tests/client-manifest.scm index 7f8e130..9aa32b5 100644 --- a/tests/client-manifest.scm +++ b/tests/client-manifest.scm @@ -24,7 +24,10 @@ #:use-module (srfi srfi-19) #:use-module (web response) #:use-module (ice-9 optargs) - #:use-module (ice-9 receive)) + #:use-module (ice-9 receive) + #:use-module (oop goops) + #:declarative? #t + #:duplicates (merge-generics)) (with-test-environment "client-manifest" @@ -59,38 +62,34 @@ (lambda () (define mf (parameterize ((p:current-date 0)) - (get-client-manifest - (string->uri "https://app.example.com/id#app")))) - (define id (client-manifest-client-id mf)) + (make + #:client-id "https://app.example.com/id#app"))) + (define id (client-id mf)) (unless (equal? id (string->uri "https://app.example.com/id#app")) (exit 3)) - (unless (client-manifest-check-redirect-uri mf "https://app.example.com/callback") + (unless (check-redirect-uri mf "https://app.example.com/callback") (exit 4)) (with-exception-handler (lambda (error) (unless (unauthorized-redirect-uri? error) (exit 5))) (lambda () - (client-manifest-check-redirect-uri mf "https://fraudulent-app.example.com/callback") + (check-redirect-uri mf "https://fraudulent-app.example.com/callback") (exit 55)) #:unwind? #t #:unwind-for-type &unauthorized-redirect-uri) (receive (response response-body) - (serve-client-manifest - (time-utc->date (make-time time-utc 0 3600)) - mf) + (serve mf (time-utc->date (make-time time-utc 0 3600))) (unless (equal? (response-content-type response) '(application/ld+json)) (exit 6)) (set! what-to-respond response) (set! what-to-respond-body response-body) (let ((re-parsed (parameterize ((p:current-date 10)) - (get-client-manifest - (string->uri "https://app.example.com/id#app"))))) + (make + #:client-id "https://app.example.com/id#app")))) (map (lambda (key) (unless (equal? (assq-ref mf key) (assq-ref re-parsed key)) (exit 9))) - '(client_id redirect_uris client_name client_uri - logo_uri tos_uri scope grant_types response_types - default_max_age require_auth_time))))))))) + '(client_id redirect_uris))))))))) -- cgit v1.2.3