From 0dfaa2a0a9f9772557b06ca7542d4c1b915d7b0c Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Mon, 30 Nov 2020 21:39:32 +0100 Subject: Implement the DPoP proof --- doc/webid-oidc.texi | 136 +++++++++++++++ po/fr.po | 332 ++++++++++++++++++++----------------- po/webid-oidc.pot | 236 +++++++++++++++++++------- src/scm/webid-oidc/Makefile.am | 8 +- src/scm/webid-oidc/dpop-proof.scm | 217 ++++++++++++++++++++++++ src/scm/webid-oidc/errors.scm | 283 ++++++++++++++++++++++++++++--- src/scm/webid-oidc/jti.scm | 34 ++++ tests/Makefile.am | 9 +- tests/dpop-proof-iat-in-future.scm | 37 +++++ tests/dpop-proof-iat-too-late.scm | 37 +++++ tests/dpop-proof-replay.scm | 40 +++++ tests/dpop-proof-valid.scm | 30 ++++ tests/dpop-proof-wrong-htm.scm | 37 +++++ tests/dpop-proof-wrong-htu.scm | 37 +++++ tests/dpop-proof-wrong-key.scm | 37 +++++ 15 files changed, 1270 insertions(+), 240 deletions(-) create mode 100644 src/scm/webid-oidc/dpop-proof.scm create mode 100644 src/scm/webid-oidc/jti.scm create mode 100644 tests/dpop-proof-iat-in-future.scm create mode 100644 tests/dpop-proof-iat-too-late.scm create mode 100644 tests/dpop-proof-replay.scm create mode 100644 tests/dpop-proof-valid.scm create mode 100644 tests/dpop-proof-wrong-htm.scm create mode 100644 tests/dpop-proof-wrong-htu.scm create mode 100644 tests/dpop-proof-wrong-key.scm diff --git a/doc/webid-oidc.texi b/doc/webid-oidc.texi index 27295e0..0fa9a42 100644 --- a/doc/webid-oidc.texi +++ b/doc/webid-oidc.texi @@ -119,6 +119,7 @@ more closely respected. @menu * The access token:: +* The DPoP proof:: * Generic JWTs:: @end menu @@ -174,6 +175,64 @@ of the client key, or set @code{#:client-key} directly, in which case the fingerprint will be computed for you. @end deffn +@node The DPoP proof +@section The DPoP proof + +This is a special JWT, that is signed by a key controlled by the +application. The access token certifies that the key used to sign the +proof is approved by the identity provider. + +@deffn function dpop-proof? @var{proof} +Check that the @var{proof} is a decoded DPoP proof. The validity of +the proof is not checked by this function. +@end deffn + +@deffn function dpop-proof-alg @var{proof} +@deffnx function dpop-proof-jwk @var{proof} +@deffnx function dpop-proof-jti @var{proof} +@deffnx function dpop-proof-htm @var{proof} +@deffnx function dpop-proof-htu @var{proof} +@deffnx function dpop-proof-iat @var{proof} +Get the corresponding field of the proof. +@end deffn + +@deffn function dpop-proof-decode @var{current-time} @var{jti-list} @var{method} @var{uri} @var{str} @var{cnf/check} +Check and decode a DPoP proof encoded as @var{str}. + +The @var{current-time} is passed as a date, time or number (of +seconds). + +In order to prevent replay attacks, each proof has a unique random +string that is remembered in @var{jti-list} until its expiration date +is reached. See the @code{make-jti-list} function. + +The proof is limited to the scope of one @var{uri} and one +@var{method} (@code{'GET}, @code{'POST} and so on). + +Finally, the key that is used to sign the proof should be confirmed by +the identity provider. To this end, the @var{cnf/check} function is +called with the fingerprint of the key. The function should check that +the fingerprint is OK (return a boolean). +@end deffn + +@deffn function make-jti-list +This function in @emph{(webid-oidc jti-list)} creates an in-memory, +async-safe, thread-safe cache for the proof IDs. +@end deffn + +@deffn function dpop-proof-encode @var{proof} @var{key} +Encode the proof and sign it with @var{key}. To generate valid proofs, +@var{key} should be the private key corresponding to the @code{jwk} +field of the proof. +@end deffn + +@deffn function issue-dpop-proof @var{client-key} @var{#alg} @var{#htm} @var{#htu} @var{#iat} +Create a proof, sign it and encode it with +@var{client-key}. @var{client-key} should contain both the private and +public key, because the public part is written in the proof and the +private part is used to sign it. +@end deffn + @node Generic JWTs @section Generic JWTs @@ -258,6 +317,7 @@ Return a string explaining the @var{error}. You can limit the * Invalid data format:: * Invalid JWT:: * Cannot fetch data on the web:: +* Other errors in the protocol or from a reasonable implementation:: @end menu @node Invalid data format @@ -300,6 +360,28 @@ The @var{value} of the cnf/jkt field is incorrect. The @var{value} of the client-id field is incorrect. @end deftp +@deftp {exception type} &incorrect-typ-field @var{value} +The @var{value} of the typ field in the DPoP proof header is +incorrect. +@end deftp + +@deftp {exception type} &incorrect-jwk-field @var{value} @var{cause} +The @var{value} of the jwk field in the DPoP proof header is +incorrect. +@end deftp + +@deftp {exception type} &incorrect-jti-field @var{value} +The @var{value} of the jti field in the DPoP proof is incorrect. +@end deftp + +@deftp {exception type} &incorrect-htm-field @var{value} +The @var{value} of the htm field in the DPoP proof is incorrect. +@end deftp + +@deftp {exception type} &incorrect-htu-field @var{value} +The @var{value} of the htu field in the DPoP proof is incorrect. +@end deftp + @node Invalid JWT @section Invalid JWT Each JWT type – access token, DPoP proof, ID token, authorization code @@ -392,6 +474,26 @@ The @var{value} string is not an encoding of a valid access token. The @var{access-token} cannot be signed. @end deftp +@deftp {exception type} ¬-a-dpop-proof @var{value} @var{cause} +The @var{value} is not a DPoP proof. +@end deftp + +@deftp {exception type} ¬-a-dpop-proof-header @var{value} @var{cause} +The @var{value} is not a DPoP proof header. +@end deftp + +@deftp {exception type} ¬-a-dpop-proof-payload @var{value} @var{cause} +The @var{value} is not a DPoP proof payload. +@end deftp + +@deftp {exception type} &cannot-decode-dpop-proof @var{value} @var{cause} +The @var{value} string is not an encoding of a valid DPoP proof. +@end deftp + +@deftp {exception type} &cannot-encode-dpop-proof @var{dpop-proof} @var{key} @var{cause} +The @var{dpop-proof} cannot be signed. +@end deftp + @node Cannot fetch data on the web @section Cannot fetch data on the web In the client (local and public parts), resource server and identity @@ -423,6 +525,40 @@ It is impossible to fetch the configuration of @var{issuer}. It is impossible to fetch the keys of @var{issuer} at @var{uri}. @end deftp +@node Other errors in the protocol or from a reasonable implementation +@section Other errors in the protocol or from a reasonable implementation +The protocol does not rely solely on JWT validation, so these errors +may happen too. + +@deftp {exception type} &dpop-method-mismatch @var{signed} @var{requested} +The method value @var{signed} in the DPoP proof does not match the +method that is @var{requested} on the server. +@end deftp + +@deftp {exception type} &dpop-uri-mismatch @var{signed} @var{requested} +The URI value @var{signed} in the DPoP proof does not match the URI +that is @var{requested} on the server. +@end deftp + +@deftp {exception type} &dpop-signed-in-future @var{signed} @var{current} +The proof is @var{signed} for a date which is too much ahead of the +@var{current} time. +@end deftp + +@deftp {exception type} &dpop-too-old @var{signed} @var{current} +The proof was @var{signed} at a past date of @var{current}. +@end deftp + +@deftp {exception type} &dpop-unconfirmed-key @var{key} @var{expected} @var{cause} +The confirmation of @var{key} is not what is @var{expected}, or (if a +function was passed as @var{cnf/check}) the @var{cause} exception +occurred while confirming. +@end deftp + +@deftp {exception type} &jti-found @var{jti} @var{cause} +The @var{jti} of the proof has already been issued in a recent past. +@end deftp + @node GNU Free Documentation License @appendix GNU Free Documentation License diff --git a/po/fr.po b/po/fr.po index 4444391..e25ffb1 100644 --- a/po/fr.po +++ b/po/fr.po @@ -126,96 +126,96 @@ msgstr "Utilisation : generate-random [NOMBRE D'OCTETS]\n" msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n" msgstr "Utilisation : generate-key [NOMBRE DE BITS | COURBE]\n" -#: src/scm/webid-oidc/errors.scm:378 +#: src/scm/webid-oidc/errors.scm:540 msgid "that’s how it is" msgstr "c’est comme ça" -#: src/scm/webid-oidc/errors.scm:383 +#: src/scm/webid-oidc/errors.scm:545 #, scheme-format msgid "the value ~s is not a base64 string (because ~a)" msgstr "la valeur ~s n’est pas une chaîne base64 (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:386 +#: src/scm/webid-oidc/errors.scm:548 #, scheme-format msgid "the value ~s is not JSON (because ~a)" msgstr "la valeur ~s n’est pas du JSON (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:389 +#: src/scm/webid-oidc/errors.scm:551 #, scheme-format msgid "the value ~s does not identify an elleptic curve" msgstr "la valeur ~s n’identifie pas une courbe elliptique" -#: src/scm/webid-oidc/errors.scm:394 +#: src/scm/webid-oidc/errors.scm:556 #, scheme-format msgid "the value ~s does not identify a JWK (because ~a)" msgstr "la valeur ~s n’identifie pas une JWK (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:396 +#: src/scm/webid-oidc/errors.scm:558 #, scheme-format msgid "the value ~s does not identify a JWK" msgstr "la valeur ~s n’identifie pas une JWK" -#: src/scm/webid-oidc/errors.scm:401 +#: src/scm/webid-oidc/errors.scm:563 #, scheme-format msgid "the value ~s does not identify a public JWK (because ~a)" msgstr "la valeur ~s n’identifie pas une JWK publique (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:403 +#: src/scm/webid-oidc/errors.scm:565 #, scheme-format msgid "the value ~s does not identify a public JWK" msgstr "la valeur ~s n’identifie pas une JWK publique" -#: src/scm/webid-oidc/errors.scm:408 +#: src/scm/webid-oidc/errors.scm:570 #, scheme-format msgid "the value ~s does not identify a private JWK (because ~a)" msgstr "la valeur ~s n’identifie pas une JWK privée (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:410 +#: src/scm/webid-oidc/errors.scm:572 #, scheme-format msgid "the value ~s does not identify a private JWK" msgstr "la valeur ~s n’identifie pas une JWK privée" -#: src/scm/webid-oidc/errors.scm:415 +#: src/scm/webid-oidc/errors.scm:577 #, scheme-format msgid "the value ~s does not identify a JWKS (because ~a)" msgstr "la valeur ~s n’identifie pas un JWKS (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:417 +#: src/scm/webid-oidc/errors.scm:579 #, scheme-format msgid "the value ~s does not identify a JWKS" msgstr "la valeur ~s n’identifie pas un JWKS" -#: src/scm/webid-oidc/errors.scm:420 +#: src/scm/webid-oidc/errors.scm:582 #, scheme-format msgid "the value ~s does not identify a hash algorithm" msgstr "la valeur ~s n’identifie pas un algorithme de hachage" -#: src/scm/webid-oidc/errors.scm:423 +#: src/scm/webid-oidc/errors.scm:585 #, scheme-format msgid "the value ~s is not an alist or misses key ~s" msgstr "la valeur ~s n’est pas une alist ou il manque la clé ~s" -#: src/scm/webid-oidc/errors.scm:426 +#: src/scm/webid-oidc/errors.scm:588 #, scheme-format msgid "the value ~s is not a JWS header (because ~a)" msgstr "la valeur ~s n’est pas un header JWS (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:429 +#: src/scm/webid-oidc/errors.scm:591 #, scheme-format msgid "the value ~s is not a JWS payload (because ~a)" msgstr "la valeur ~s n’est pas un contenu JWS (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:432 +#: src/scm/webid-oidc/errors.scm:594 #, scheme-format msgid "the value ~s is not a JWS (because ~a)" msgstr "la valeur ~s n’est pas un JWS (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:435 +#: src/scm/webid-oidc/errors.scm:597 #, scheme-format msgid "the string ~s cannot be split in 3 parts with ~s" msgstr "la chaîne ~s ne peut pas être découpée en 3 parties avec ~s" -#: src/scm/webid-oidc/errors.scm:438 +#: src/scm/webid-oidc/errors.scm:600 #, scheme-format msgid "" "all key candidates failed to verify signature ~s with algorithm ~s and " @@ -224,17 +224,17 @@ msgstr "" "aucune clé candidate n’a pu vérifier la signature ~s avec l’algorithme ~s et " "le contenu ~a (il y en avait ~a : ~s)" -#: src/scm/webid-oidc/errors.scm:441 +#: src/scm/webid-oidc/errors.scm:603 #, scheme-format msgid "I cannot decode JWS ~a (because ~a)" msgstr "je n’ai pas pu décoder le JWS encodé par ~a (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:444 +#: src/scm/webid-oidc/errors.scm:606 #, scheme-format msgid "I cannot encode JWS ~a (because ~a)" msgstr "je n’ai pas pu encoder le JWS ~a (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:447 +#: src/scm/webid-oidc/errors.scm:609 #, scheme-format msgid "" "the server request unexpectedly failed with code ~a and reason phrase ~s" @@ -242,179 +242,298 @@ msgstr "" "la requête au serveur a échoué de façon inattendue avec un code ~a et une " "raison ~s" -#: src/scm/webid-oidc/errors.scm:452 +#: src/scm/webid-oidc/errors.scm:614 #, scheme-format msgid "the header ~a should not have the value ~s" msgstr "l’en-tête ~a ne devrait pas avoir la valeur ~s" -#: src/scm/webid-oidc/errors.scm:454 +#: src/scm/webid-oidc/errors.scm:616 #, scheme-format msgid "the header ~a should be present" msgstr "l’en-tête ~a devrait être présent" -#: src/scm/webid-oidc/errors.scm:457 +#: src/scm/webid-oidc/errors.scm:619 #, scheme-format msgid "the server response wasn't expected: ~s (because ~a)" msgstr "la réponse du serveur est inattendue : ~s (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:463 +#: src/scm/webid-oidc/errors.scm:625 #, scheme-format msgid "the value ~s is not an OIDC configuration (because ~a)" msgstr "la valeur ~s n’est pas une configuration OIDC (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:468 +#: src/scm/webid-oidc/errors.scm:630 #, scheme-format msgid "the webid field is incorrect: ~s" msgstr "le champ webid est incorrect : ~s" -#: src/scm/webid-oidc/errors.scm:469 +#: src/scm/webid-oidc/errors.scm:631 msgid "the webid field is missing" msgstr "le champ webid est manquant" -#: src/scm/webid-oidc/errors.scm:473 +#: src/scm/webid-oidc/errors.scm:635 #, scheme-format msgid "the iss field is incorrect: ~s" msgstr "le champ iss est incorrect : ~s" -#: src/scm/webid-oidc/errors.scm:474 +#: src/scm/webid-oidc/errors.scm:636 msgid "the iss field is missing" msgstr "le champ iss est manquant" -#: src/scm/webid-oidc/errors.scm:478 +#: src/scm/webid-oidc/errors.scm:640 #, scheme-format msgid "the aud field is incorrect: ~s" msgstr "le champ aud est incorrect : ~s" -#: src/scm/webid-oidc/errors.scm:479 +#: src/scm/webid-oidc/errors.scm:641 msgid "the aud field is missing" msgstr "le champ aud est manquant" -#: src/scm/webid-oidc/errors.scm:483 +#: src/scm/webid-oidc/errors.scm:645 #, scheme-format msgid "the iat field is incorrect: ~s" msgstr "le champ iat est incorrect : ~s" -#: src/scm/webid-oidc/errors.scm:484 +#: src/scm/webid-oidc/errors.scm:646 msgid "the iat field is missing" msgstr "le champ iat est manquant" -#: src/scm/webid-oidc/errors.scm:488 +#: src/scm/webid-oidc/errors.scm:650 #, scheme-format msgid "the exp field is incorrect: ~s" msgstr "le champ exp est incorrect : ~s" -#: src/scm/webid-oidc/errors.scm:489 +#: src/scm/webid-oidc/errors.scm:651 msgid "the exp field is missing" msgstr "le champ exp est manquant" -#: src/scm/webid-oidc/errors.scm:493 +#: src/scm/webid-oidc/errors.scm:655 #, scheme-format msgid "the cnf/jkt field is incorrect: ~s" msgstr "le champ cnf/jkt est incorrect : ~s" -#: src/scm/webid-oidc/errors.scm:494 +#: src/scm/webid-oidc/errors.scm:656 msgid "the cnf/jkt field is missing" msgstr "le champ cnf/jkt est manquant" -#: src/scm/webid-oidc/errors.scm:498 +#: src/scm/webid-oidc/errors.scm:660 #, scheme-format msgid "the client-id field is incorrect: ~s" msgstr "le champ client-id est incorrect : ~s" -#: src/scm/webid-oidc/errors.scm:499 +#: src/scm/webid-oidc/errors.scm:661 msgid "the client-id field is missing" msgstr "le champ client-id est manquant" -#: src/scm/webid-oidc/errors.scm:501 +#: src/scm/webid-oidc/errors.scm:665 +#, scheme-format +msgid "the typ field is incorrect: ~s" +msgstr "le champ typ est incorrect : ~s" + +#: src/scm/webid-oidc/errors.scm:666 +msgid "the typ field is missing" +msgstr "le champ typ est manquant" + +#: src/scm/webid-oidc/errors.scm:670 +#, scheme-format +msgid "the jwk field is incorrect: ~s (because ~a)" +msgstr "le champ jwk est incorrect : ~s (parce que ~a)" + +#: src/scm/webid-oidc/errors.scm:672 +msgid "the jwk field is missing" +msgstr "le champ jwk est manquant" + +#: src/scm/webid-oidc/errors.scm:676 +#, scheme-format +msgid "the jti field is incorrect: ~s" +msgstr "le champ jti est incorrect : ~s" + +#: src/scm/webid-oidc/errors.scm:677 +msgid "the jti field is missing" +msgstr "le champ jti est manquant" + +#: src/scm/webid-oidc/errors.scm:681 +#, scheme-format +msgid "the htm field is incorrect: ~s" +msgstr "le champ htm est incorrect : ~s" + +#: src/scm/webid-oidc/errors.scm:682 +msgid "the htm field is missing" +msgstr "le champ htm est manquant" + +#: src/scm/webid-oidc/errors.scm:686 +#, scheme-format +msgid "the htu field is incorrect: ~s" +msgstr "le champ htu est incorrect : ~s" + +#: src/scm/webid-oidc/errors.scm:687 +msgid "the htu field is missing" +msgstr "le champ htu est manquant" + +#: src/scm/webid-oidc/errors.scm:689 #, scheme-format msgid "~s is not an access token (because ~a)" msgstr "~s n’est pas un jeton d’accès (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:504 +#: src/scm/webid-oidc/errors.scm:692 #, scheme-format msgid "~s is not an access token header (because ~a)" msgstr "~s n’est pas un en-tête de jeton d’accès (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:507 +#: src/scm/webid-oidc/errors.scm:695 #, scheme-format msgid "~s is not an access token payload (because ~a)" msgstr "~s n’est pas un contenu de jeton d’accès (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:510 +#: src/scm/webid-oidc/errors.scm:698 +#, scheme-format +msgid "~s is not a DPoP proof (because ~a)" +msgstr "~s n’est pas une preuve DPoP (parce que ~a)" + +#: src/scm/webid-oidc/errors.scm:701 +#, scheme-format +msgid "~s is not a DPoP proof header (because ~a)" +msgstr "~s n’est pas un en-tête de preuve DPoP (parce que ~a)" + +#: src/scm/webid-oidc/errors.scm:704 +#, scheme-format +msgid "~s is not a DPoP proof payload (because ~a)" +msgstr "~s n’est pas un contenu de preuve DPoP (parce que ~a)" + +#: src/scm/webid-oidc/errors.scm:707 #, scheme-format msgid "I cannot fetch the issuer configuration of ~a (because ~a)" msgstr "" "je n’ai pas pu récupérer la configuration de l’émetteur ~a (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:517 +#: src/scm/webid-oidc/errors.scm:714 #, scheme-format msgid "I cannot fetch the JWKS of ~a at ~a (because ~a)" msgstr "je n’ai pas pu récupérer le JWKS de ~a à ~a (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:528 +#: src/scm/webid-oidc/errors.scm:725 +#, scheme-format +msgid "the HTTP method is signed for ~s, but ~s was requested" +msgstr "la méthode HTTP a été signée pour ~s, mais ~s a été demandé" + +#: src/scm/webid-oidc/errors.scm:728 +#, scheme-format +msgid "the HTTP uri is signed for ~a, but ~a was requested" +msgstr "l’uri HTTP a été signé pour ~a, mais ~a a été demandé" + +#: src/scm/webid-oidc/errors.scm:731 +#, scheme-format +msgid "the date is ~a, but the DPoP proof is signed in the future at ~a" +msgstr "la date est ~a, mais la preuve DPoP a été signée dans le futur à ~a" + +#: src/scm/webid-oidc/errors.scm:735 +#, scheme-format +msgid "the date is ~a, but the DPoP proof was signed too long ago at ~a" +msgstr "" +"la date est ~a, mais la preuve DPoP a été signée il y a trop longtemps à ~a" + +#: src/scm/webid-oidc/errors.scm:744 +#, scheme-format +msgid "the key ~s does not hash to ~a" +msgstr "la clé ~s ne donne pas un hash de ~a" + +#: src/scm/webid-oidc/errors.scm:746 +#, scheme-format +msgid "the key confirmation of ~s failed (because ~a)" +msgstr "la confirmation de clé de ~s a échoué (parce que ~a)" + +#: src/scm/webid-oidc/errors.scm:748 +#, scheme-format +msgid "the key confirmation of ~s failed" +msgstr "la confirmation de la clé ~s a échoué" + +#: src/scm/webid-oidc/errors.scm:750 +#, scheme-format +msgid "the jti ~s has already been found (because ~a)" +msgstr "le jti ~s a déjà été trouvé (parce que ~a)" + +#: src/scm/webid-oidc/errors.scm:753 #, scheme-format msgid "I cannot decode ~s as an access token (because ~a)" msgstr "je n’ai pas pu décoder ~s comme jeton d’accès (parce que ~a)" -#: src/scm/webid-oidc/errors.scm:531 +#: src/scm/webid-oidc/errors.scm:756 #, scheme-format msgid "I cannot encode ~s as an access token with key ~s (because ~a)" msgstr "" "je n’ai pas pu encoder ~s comme un jeton d’accès avec la clé ~s (parce que " "~a)" -#: src/scm/webid-oidc/errors.scm:536 +#: src/scm/webid-oidc/errors.scm:759 +#, scheme-format +msgid "I cannot decode ~s as a DPoP proof (because ~a)" +msgstr "je n’ai pas pu décoder ~s comme preuve DPoP (parce que ~a)" + +#: src/scm/webid-oidc/errors.scm:762 +#, scheme-format +msgid "I cannot encode ~s as a DPoP proof (because ~a)" +msgstr "je n’ai pas pu encoder ~s comme une preuve DPoP (parce que ~a)" + +#: src/scm/webid-oidc/errors.scm:767 msgid "that’s it" msgstr "c’est tout" -#: src/scm/webid-oidc/errors.scm:540 +#: src/scm/webid-oidc/errors.scm:771 #, scheme-format msgid "~a and ~a" msgstr "~a et ~a" -#: src/scm/webid-oidc/errors.scm:543 +#: src/scm/webid-oidc/errors.scm:774 #, scheme-format msgid "~a, ~a" msgstr "~a, ~a" -#: src/scm/webid-oidc/errors.scm:547 +#: src/scm/webid-oidc/errors.scm:778 #, scheme-format msgid "the signature ~a does not match key ~s with payload ~a" msgstr "la signature ~a ne correspond pas à la clé ~s avec le contenu ~a" -#: src/scm/webid-oidc/errors.scm:550 +#: src/scm/webid-oidc/errors.scm:781 msgid "there is an undefined variable" msgstr "il y a une variable non définie" -#: src/scm/webid-oidc/errors.scm:552 +#: src/scm/webid-oidc/errors.scm:783 #, scheme-format msgid "the origin is ~a" msgstr "l’origine est ~a" -#: src/scm/webid-oidc/errors.scm:555 +#: src/scm/webid-oidc/errors.scm:786 #, scheme-format msgid "a message is attached: ~a" msgstr "un message est attaché : ~a" -#: src/scm/webid-oidc/errors.scm:558 +#: src/scm/webid-oidc/errors.scm:789 #, scheme-format msgid "the values ~s are problematic" msgstr "les valeurs ~s sont problématiques" -#: src/scm/webid-oidc/errors.scm:561 +#: src/scm/webid-oidc/errors.scm:792 msgid "there is a kind and args" msgstr "il y a un type et des arguments" -#: src/scm/webid-oidc/errors.scm:563 +#: src/scm/webid-oidc/errors.scm:794 msgid "there is an assertion failure" msgstr "il y a un échec d’assertion" -#: src/scm/webid-oidc/errors.scm:565 +#: src/scm/webid-oidc/errors.scm:796 #, scheme-format msgid "the program quits with code ~a" msgstr "le programme quitte avec le code ~a" -#: src/scm/webid-oidc/errors.scm:568 +#: src/scm/webid-oidc/errors.scm:799 +msgid "the program cannot recover from this exception" +msgstr "le programme ne peut pas récupérer après cette exception" + +#: src/scm/webid-oidc/errors.scm:801 +msgid "there is an error" +msgstr "il y a une erreur" + +#: src/scm/webid-oidc/errors.scm:803 #, scheme-format msgid "Unhandled exception type ~a." msgstr "Type d’exception non pris en charge ~a." @@ -437,27 +556,6 @@ msgstr "Type d’exception non pris en charge ~a." #~ msgid "the redirect_uris field is missing" #~ msgstr "le champ redirect_uris est manquant" -#, scheme-format -#~ msgid "the typ field is incorrect: ~s" -#~ msgstr "le champ typ est incorrect : ~s" - -#~ msgid "the typ field is missing" -#~ msgstr "le champ typ est manquant" - -#, scheme-format -#~ msgid "the jwk field is incorrect: ~s (because ~a)" -#~ msgstr "le champ jwk est incorrect : ~s (parce que ~a)" - -#~ msgid "the jwk field is missing" -#~ msgstr "le champ jwk est manquant" - -#, scheme-format -#~ msgid "the jti field is incorrect: ~s" -#~ msgstr "le champ jti est incorrect : ~s" - -#~ msgid "the jti field is missing" -#~ msgstr "le champ jti est manquant" - #, scheme-format #~ msgid "the nonce field is incorrect: ~s" #~ msgstr "le champ nonce est incorrect : ~s" @@ -465,74 +563,6 @@ msgstr "Type d’exception non pris en charge ~a." #~ msgid "the nonce field is missing" #~ msgstr "le champ nonce est manquant" -#, scheme-format -#~ msgid "the htm field is incorrect: ~s" -#~ msgstr "le champ htm est incorrect : ~s" - -#~ msgid "the htm field is missing" -#~ msgstr "le champ htm est manquant" - -#, scheme-format -#~ msgid "the htu field is incorrect: ~s" -#~ msgstr "le champ htu est incorrect : ~s" - -#~ msgid "the htu field is missing" -#~ msgstr "le champ htu est manquant" - -#, scheme-format -#~ msgid "~s is not a DPoP proof (because ~a)" -#~ msgstr "~s n’est pas une preuve DPoP (parce que ~a)" - -#, scheme-format -#~ msgid "~s is not a DPoP proof header (because ~a)" -#~ msgstr "~s n’est pas un en-tête de preuve DPoP (parce que ~a)" - -#, scheme-format -#~ msgid "~s is not a DPoP proof payload (because ~a)" -#~ msgstr "~s n’est pas un contenu de preuve DPoP (parce que ~a)" - -#, scheme-format -#~ msgid "the HTTP method is signed for ~s, but ~s was requested" -#~ msgstr "la méthode HTTP a été signée pour ~s, mais ~s a été demandé" - -#, scheme-format -#~ msgid "the HTTP uri is signed for ~a, but ~a was requested" -#~ msgstr "l’uri HTTP a été signé pour ~a, mais ~a a été demandé" - -#, scheme-format -#~ msgid "the date is ~a, but the DPoP proof is signed in the future at ~a" -#~ msgstr "la date est ~a, mais la preuve DPoP a été signée dans le futur à ~a" - -#, scheme-format -#~ msgid "the date is ~a, but the DPoP proof was signed too long ago at ~a" -#~ msgstr "" -#~ "la date est ~a, mais la preuve DPoP a été signée il y a trop longtemps à " -#~ "~a" - -#, scheme-format -#~ msgid "the key ~s does not hash to ~a" -#~ msgstr "la clé ~s ne donne pas un hash de ~a" - -#, scheme-format -#~ msgid "the key confirmation of ~s failed (because ~a)" -#~ msgstr "la confirmation de clé de ~s a échoué (parce que ~a)" - -#, scheme-format -#~ msgid "the key confirmation of ~s failed" -#~ msgstr "la confirmation de la clé ~s a échoué" - -#, scheme-format -#~ msgid "the jti ~s has already been found (because ~a)" -#~ msgstr "le jti ~s a déjà été trouvé (parce que ~a)" - -#, scheme-format -#~ msgid "I cannot decode ~s as a DPoP proof (because ~a)" -#~ msgstr "je n’ai pas pu décoder ~s comme preuve DPoP (parce que ~a)" - -#, scheme-format -#~ msgid "I cannot encode ~s as a DPoP proof (because ~a)" -#~ msgstr "je n’ai pas pu encoder ~s comme une preuve DPoP (parce que ~a)" - #, scheme-format #~ msgid "I could not fetch a RDF graph at ~a (because ~a)" #~ msgstr "je n’ai pas pu récupérer de graphe RDF à ~a (parce que ~a)" @@ -722,12 +752,6 @@ msgstr "Type d’exception non pris en charge ~a." #~ msgid "the container ~s should be emptied before being deleted" #~ msgstr "le conteneur ~s doit être vidé avant d’être détruit" -#~ msgid "the program cannot recover from this exception" -#~ msgstr "le programme ne peut pas récupérer après cette exception" - -#~ msgid "there is an error" -#~ msgstr "il y a une erreur" - #~ msgid "there is an external error" #~ msgstr "il y a une erreur externe" diff --git a/po/webid-oidc.pot b/po/webid-oidc.pot index e008e38..1ab669d 100644 --- a/po/webid-oidc.pot +++ b/po/webid-oidc.pot @@ -122,288 +122,406 @@ msgstr "" msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n" msgstr "" -#: src/scm/webid-oidc/errors.scm:378 +#: src/scm/webid-oidc/errors.scm:540 msgid "that’s how it is" msgstr "" -#: src/scm/webid-oidc/errors.scm:383 +#: src/scm/webid-oidc/errors.scm:545 #, scheme-format msgid "the value ~s is not a base64 string (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:386 +#: src/scm/webid-oidc/errors.scm:548 #, scheme-format msgid "the value ~s is not JSON (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:389 +#: src/scm/webid-oidc/errors.scm:551 #, scheme-format msgid "the value ~s does not identify an elleptic curve" msgstr "" -#: src/scm/webid-oidc/errors.scm:394 +#: src/scm/webid-oidc/errors.scm:556 #, scheme-format msgid "the value ~s does not identify a JWK (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:396 +#: src/scm/webid-oidc/errors.scm:558 #, scheme-format msgid "the value ~s does not identify a JWK" msgstr "" -#: src/scm/webid-oidc/errors.scm:401 +#: src/scm/webid-oidc/errors.scm:563 #, scheme-format msgid "the value ~s does not identify a public JWK (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:403 +#: src/scm/webid-oidc/errors.scm:565 #, scheme-format msgid "the value ~s does not identify a public JWK" msgstr "" -#: src/scm/webid-oidc/errors.scm:408 +#: src/scm/webid-oidc/errors.scm:570 #, scheme-format msgid "the value ~s does not identify a private JWK (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:410 +#: src/scm/webid-oidc/errors.scm:572 #, scheme-format msgid "the value ~s does not identify a private JWK" msgstr "" -#: src/scm/webid-oidc/errors.scm:415 +#: src/scm/webid-oidc/errors.scm:577 #, scheme-format msgid "the value ~s does not identify a JWKS (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:417 +#: src/scm/webid-oidc/errors.scm:579 #, scheme-format msgid "the value ~s does not identify a JWKS" msgstr "" -#: src/scm/webid-oidc/errors.scm:420 +#: src/scm/webid-oidc/errors.scm:582 #, scheme-format msgid "the value ~s does not identify a hash algorithm" msgstr "" -#: src/scm/webid-oidc/errors.scm:423 +#: src/scm/webid-oidc/errors.scm:585 #, scheme-format msgid "the value ~s is not an alist or misses key ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:426 +#: src/scm/webid-oidc/errors.scm:588 #, scheme-format msgid "the value ~s is not a JWS header (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:429 +#: src/scm/webid-oidc/errors.scm:591 #, scheme-format msgid "the value ~s is not a JWS payload (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:432 +#: src/scm/webid-oidc/errors.scm:594 #, scheme-format msgid "the value ~s is not a JWS (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:435 +#: src/scm/webid-oidc/errors.scm:597 #, scheme-format msgid "the string ~s cannot be split in 3 parts with ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:438 +#: src/scm/webid-oidc/errors.scm:600 #, scheme-format msgid "" "all key candidates failed to verify signature ~s with algorithm ~s and " "payload ~a (there were ~a: ~s)" msgstr "" -#: src/scm/webid-oidc/errors.scm:441 +#: src/scm/webid-oidc/errors.scm:603 #, scheme-format msgid "I cannot decode JWS ~a (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:444 +#: src/scm/webid-oidc/errors.scm:606 #, scheme-format msgid "I cannot encode JWS ~a (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:447 +#: src/scm/webid-oidc/errors.scm:609 #, scheme-format msgid "" "the server request unexpectedly failed with code ~a and reason phrase ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:452 +#: src/scm/webid-oidc/errors.scm:614 #, scheme-format msgid "the header ~a should not have the value ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:454 +#: src/scm/webid-oidc/errors.scm:616 #, scheme-format msgid "the header ~a should be present" msgstr "" -#: src/scm/webid-oidc/errors.scm:457 +#: src/scm/webid-oidc/errors.scm:619 #, scheme-format msgid "the server response wasn't expected: ~s (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:463 +#: src/scm/webid-oidc/errors.scm:625 #, scheme-format msgid "the value ~s is not an OIDC configuration (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:468 +#: src/scm/webid-oidc/errors.scm:630 #, scheme-format msgid "the webid field is incorrect: ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:469 +#: src/scm/webid-oidc/errors.scm:631 msgid "the webid field is missing" msgstr "" -#: src/scm/webid-oidc/errors.scm:473 +#: src/scm/webid-oidc/errors.scm:635 #, scheme-format msgid "the iss field is incorrect: ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:474 +#: src/scm/webid-oidc/errors.scm:636 msgid "the iss field is missing" msgstr "" -#: src/scm/webid-oidc/errors.scm:478 +#: src/scm/webid-oidc/errors.scm:640 #, scheme-format msgid "the aud field is incorrect: ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:479 +#: src/scm/webid-oidc/errors.scm:641 msgid "the aud field is missing" msgstr "" -#: src/scm/webid-oidc/errors.scm:483 +#: src/scm/webid-oidc/errors.scm:645 #, scheme-format msgid "the iat field is incorrect: ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:484 +#: src/scm/webid-oidc/errors.scm:646 msgid "the iat field is missing" msgstr "" -#: src/scm/webid-oidc/errors.scm:488 +#: src/scm/webid-oidc/errors.scm:650 #, scheme-format msgid "the exp field is incorrect: ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:489 +#: src/scm/webid-oidc/errors.scm:651 msgid "the exp field is missing" msgstr "" -#: src/scm/webid-oidc/errors.scm:493 +#: src/scm/webid-oidc/errors.scm:655 #, scheme-format msgid "the cnf/jkt field is incorrect: ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:494 +#: src/scm/webid-oidc/errors.scm:656 msgid "the cnf/jkt field is missing" msgstr "" -#: src/scm/webid-oidc/errors.scm:498 +#: src/scm/webid-oidc/errors.scm:660 #, scheme-format msgid "the client-id field is incorrect: ~s" msgstr "" -#: src/scm/webid-oidc/errors.scm:499 +#: src/scm/webid-oidc/errors.scm:661 msgid "the client-id field is missing" msgstr "" -#: src/scm/webid-oidc/errors.scm:501 +#: src/scm/webid-oidc/errors.scm:665 +#, scheme-format +msgid "the typ field is incorrect: ~s" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:666 +msgid "the typ field is missing" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:670 +#, scheme-format +msgid "the jwk field is incorrect: ~s (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:672 +msgid "the jwk field is missing" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:676 +#, scheme-format +msgid "the jti field is incorrect: ~s" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:677 +msgid "the jti field is missing" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:681 +#, scheme-format +msgid "the htm field is incorrect: ~s" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:682 +msgid "the htm field is missing" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:686 +#, scheme-format +msgid "the htu field is incorrect: ~s" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:687 +msgid "the htu field is missing" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:689 #, scheme-format msgid "~s is not an access token (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:504 +#: src/scm/webid-oidc/errors.scm:692 #, scheme-format msgid "~s is not an access token header (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:507 +#: src/scm/webid-oidc/errors.scm:695 #, scheme-format msgid "~s is not an access token payload (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:510 +#: src/scm/webid-oidc/errors.scm:698 +#, scheme-format +msgid "~s is not a DPoP proof (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:701 +#, scheme-format +msgid "~s is not a DPoP proof header (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:704 +#, scheme-format +msgid "~s is not a DPoP proof payload (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:707 #, scheme-format msgid "I cannot fetch the issuer configuration of ~a (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:517 +#: src/scm/webid-oidc/errors.scm:714 #, scheme-format msgid "I cannot fetch the JWKS of ~a at ~a (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:528 +#: src/scm/webid-oidc/errors.scm:725 +#, scheme-format +msgid "the HTTP method is signed for ~s, but ~s was requested" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:728 +#, scheme-format +msgid "the HTTP uri is signed for ~a, but ~a was requested" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:731 +#, scheme-format +msgid "the date is ~a, but the DPoP proof is signed in the future at ~a" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:735 +#, scheme-format +msgid "the date is ~a, but the DPoP proof was signed too long ago at ~a" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:744 +#, scheme-format +msgid "the key ~s does not hash to ~a" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:746 +#, scheme-format +msgid "the key confirmation of ~s failed (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:748 +#, scheme-format +msgid "the key confirmation of ~s failed" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:750 +#, scheme-format +msgid "the jti ~s has already been found (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:753 #, scheme-format msgid "I cannot decode ~s as an access token (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:531 +#: src/scm/webid-oidc/errors.scm:756 #, scheme-format msgid "I cannot encode ~s as an access token with key ~s (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:536 +#: src/scm/webid-oidc/errors.scm:759 +#, scheme-format +msgid "I cannot decode ~s as a DPoP proof (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:762 +#, scheme-format +msgid "I cannot encode ~s as a DPoP proof (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:767 msgid "that’s it" msgstr "" -#: src/scm/webid-oidc/errors.scm:540 +#: src/scm/webid-oidc/errors.scm:771 #, scheme-format msgid "~a and ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:543 +#: src/scm/webid-oidc/errors.scm:774 #, scheme-format msgid "~a, ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:547 +#: src/scm/webid-oidc/errors.scm:778 #, scheme-format msgid "the signature ~a does not match key ~s with payload ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:550 +#: src/scm/webid-oidc/errors.scm:781 msgid "there is an undefined variable" msgstr "" -#: src/scm/webid-oidc/errors.scm:552 +#: src/scm/webid-oidc/errors.scm:783 #, scheme-format msgid "the origin is ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:555 +#: src/scm/webid-oidc/errors.scm:786 #, scheme-format msgid "a message is attached: ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:558 +#: src/scm/webid-oidc/errors.scm:789 #, scheme-format msgid "the values ~s are problematic" msgstr "" -#: src/scm/webid-oidc/errors.scm:561 +#: src/scm/webid-oidc/errors.scm:792 msgid "there is a kind and args" msgstr "" -#: src/scm/webid-oidc/errors.scm:563 +#: src/scm/webid-oidc/errors.scm:794 msgid "there is an assertion failure" msgstr "" -#: src/scm/webid-oidc/errors.scm:565 +#: src/scm/webid-oidc/errors.scm:796 #, scheme-format msgid "the program quits with code ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:568 +#: src/scm/webid-oidc/errors.scm:799 +msgid "the program cannot recover from this exception" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:801 +msgid "there is an error" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:803 #, scheme-format msgid "Unhandled exception type ~a." msgstr "" diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index a63fa89..ecb3f0a 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -6,7 +6,9 @@ dist_webidoidcmod_DATA += \ %reldir%/jws.scm \ %reldir%/cache.scm \ %reldir%/oidc-configuration.scm \ - %reldir%/access-token.scm + %reldir%/access-token.scm \ + %reldir%/jti.scm \ + %reldir%/dpop-proof.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ @@ -15,4 +17,6 @@ webidoidcgo_DATA += \ %reldir%/jws.go \ %reldir%/cache.go \ %reldir%/oidc-configuration.go \ - %reldir%/access-token.go + %reldir%/access-token.go \ + %reldir%/jti.go \ + %reldir%/dpop-proof.go diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm new file mode 100644 index 0000000..89c78af --- /dev/null +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -0,0 +1,217 @@ +(define-module (webid-oidc dpop-proof) + #:use-module (webid-oidc jws) + #:use-module (webid-oidc errors) + #:use-module (webid-oidc jwk) + #:use-module (webid-oidc jti) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (web uri) + #:use-module (ice-9 optargs) + #:use-module (srfi srfi-19)) + +(define-public (the-dpop-proof-header x) + (with-exception-handler + (lambda (error) + (raise-not-a-dpop-proof-header x error)) + (lambda () + (let ((x (the-jws-header x))) + (let ((alg (assq-ref x 'alg)) + (typ (assq-ref x 'typ)) + (jwk (assq-ref x 'jwk))) + (unless (and alg (string? alg)) + (raise-unsupported-alg alg)) + (case (string->symbol alg) + ((RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512) + #t) + (else + (raise-unsupported-alg alg))) + (unless (equal? typ "dpop+jwt") + (raise-incorrect-typ-field typ)) + (with-exception-handler + (lambda (error) + (raise-incorrect-jwk-field jwk error)) + (lambda () + (the-public-jwk jwk))) + x))))) + +(define-public (dpop-proof-header? x) + (false-if-exception + (and (the-dpop-proof-header x) #t))) + +(define-public (the-dpop-proof-payload x) + (with-exception-handler + (lambda (error) + (raise-not-a-dpop-proof-payload x error)) + (lambda () + (let ((x (the-jws-payload x))) + (let ((jti (assq-ref x 'jti)) + (htm (assq-ref x 'htm)) + (htu (assq-ref x 'htu)) + (iat (assq-ref x 'iat))) + (unless (and jti (string? jti)) + (raise-incorrect-jti-field jti)) + (unless (and htm (string? htm)) + (raise-incorrect-htm-field htm)) + (unless (and htu (string? htu) (string->uri htu)) + (raise-incorrect-htu-field htu)) + (unless (and iat (integer? iat)) + (raise-incorrect-iat-field iat)) + x))))) + +(define-public (dpop-proof-payload? x) + (false-if-exception + (and (the-dpop-proof-payload x) #t))) + +(define-public (the-dpop-proof x) + (with-exception-handler + (lambda (error) + (raise-not-a-dpop-proof x error)) + (lambda () + (cons (the-dpop-proof-header (car x)) + (the-dpop-proof-payload (cdr x)))))) + +(define-public (dpop-proof? x) + (false-if-exception + (and (the-dpop-proof x) #t))) + +(define-public (make-dpop-proof header payload) + (the-dpop-proof (cons header payload))) + +(define-public (make-dpop-proof-header alg jwk) + (when (symbol? alg) + (set! alg (symbol->string alg))) + (the-dpop-proof-header + `((alg . ,alg) + (typ . "dpop+jwt") + (jwk . ,(stubs:strip-key jwk))))) + +(define-public (make-dpop-proof-payload jti htm htu iat) + (when (symbol? htm) + (set! htm (symbol->string htm))) + (when (uri? htu) + (set! htu (uri->string htu))) + (when (date? iat) + (set! iat (date->time-utc iat))) + (when (time? iat) + (set! iat (time-second iat))) + (the-dpop-proof-payload + `((jti . ,jti) + (htm . ,htm) + (htu . ,htu) + (iat . ,iat)))) + +(define-public (dpop-proof-header dpop) + (car (the-dpop-proof dpop))) + +(define-public (dpop-proof-payload dpop) + (cdr (the-dpop-proof dpop))) + +(define-public (dpop-proof-alg code) + (when (dpop-proof? code) + (set! code (dpop-proof-header code))) + (jws-alg (the-dpop-proof-header code))) + +(define-public (dpop-proof-jwk dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-header dpop))) + (assq-ref (the-dpop-proof-header dpop) 'jwk)) + +(define-public (dpop-proof-jti dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (assq-ref (the-dpop-proof-payload dpop) 'jti)) + +(define-public (dpop-proof-htm dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (string->symbol + (assq-ref (the-dpop-proof-payload dpop) + 'htm))) + +(define-public (dpop-proof-htu dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (string->uri + (assq-ref (the-dpop-proof-payload dpop) + 'htu))) + +(define-public (dpop-proof-iat dpop) + (when (dpop-proof? dpop) + (set! dpop (dpop-proof-payload dpop))) + (time-utc->date + (make-time time-utc + 0 + (assq-ref (the-dpop-proof-payload dpop) + 'iat)))) + +(define (uris-compatible a b) + ;; a is what is signed, b is the request + (unless + (and (eq? (uri-scheme a) + (uri-scheme b)) + (equal? (uri-userinfo a) + (uri-userinfo b)) + (equal? (uri-port a) + (uri-port b)) + (equal? (split-and-decode-uri-path + (uri-path a)) + (split-and-decode-uri-path + (uri-path b)))) + (raise-dpop-uri-mismatch a b))) + +(define-public (dpop-proof-decode current-time jti-list method uri str cnf/check) + (when (date? current-time) + (set! current-time (date->time-utc current-time))) + (when (time? current-time) + (set! current-time (time-second current-time))) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-dpop-proof str error)) + (lambda () + (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk)))) + (unless (eq? method (dpop-proof-htm decoded)) + (raise-dpop-method-mismatch (dpop-proof-htm decoded) method)) + (uris-compatible (dpop-proof-htu decoded) + (if (string? uri) + (string->uri uri) + uri)) + (let ((iat (time-second (date->time-utc (dpop-proof-iat decoded))))) + (unless (>= current-time (- iat 5)) + (raise-dpop-signed-in-future iat current-time)) + (unless (<= current-time (+ iat 120)) ;; Valid for 2 min + (raise-dpop-too-old iat current-time))) + (if (string? cnf/check) + (unless (equal? cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) cnf/check #f)) + (with-exception-handler + (lambda (error) + (raise-dpop-unconfirmed-key (dpop-proof-jwk decoded) #f error)) + (lambda () + (unless (cnf/check (stubs:jkt (dpop-proof-jwk decoded))) + ;; deprecated; throw an error instead! + (error "the cnf/check function returned #f"))))) + (unless (jti-check current-time (dpop-proof-jti decoded) jti-list 120) + (with-exception-handler + (lambda (error) + (raise-jti-found (dpop-proof-jti decoded) error)) + (lambda () + (error "the jti-check function returned #f")))) + decoded)))) + +(define-public (dpop-proof-encode dpop-proof key) + (with-exception-handler + (lambda (error) + (raise-cannot-encode-dpop-proof dpop-proof key error)) + (lambda () + (jws-encode dpop-proof key)))) + +(define*-public (issue-dpop-proof + client-key + #:key + (alg #f) + (htm #f) + (htu #f) + (iat #f)) + (dpop-proof-encode + (make-dpop-proof (make-dpop-proof-header alg client-key) + (make-dpop-proof-payload (stubs:random 12) htm htu iat)) + client-key)) diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 50d526c..959b04e 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -3,6 +3,8 @@ #:use-module (ice-9 exceptions) #:use-module (ice-9 optargs) #:use-module (ice-9 i18n) + #:use-module (srfi srfi-19) + #:use-module (web uri) #:use-module (web response)) (define (G_ text) @@ -297,6 +299,56 @@ (raise-exception ((record-constructor &incorrect-client-id-field) value))) +(define-public &incorrect-typ-field + (make-exception-type + '&incorrect-typ-field + &external-error + '(value))) + +(define-public (raise-incorrect-typ-field value) + (raise-exception + ((record-constructor &incorrect-typ-field) value))) + +(define-public &incorrect-jwk-field + (make-exception-type + '&incorrect-jwk-field + &external-error + '(value cause))) + +(define-public (raise-incorrect-jwk-field value cause) + (raise-exception + ((record-constructor &incorrect-jwk-field) value cause))) + +(define-public &incorrect-jti-field + (make-exception-type + '&incorrect-jti-field + &external-error + '(value))) + +(define-public (raise-incorrect-jti-field value) + (raise-exception + ((record-constructor &incorrect-jti-field) value))) + +(define-public &incorrect-htm-field + (make-exception-type + '&incorrect-htm-field + &external-error + '(value))) + +(define-public (raise-incorrect-htm-field value) + (raise-exception + ((record-constructor &incorrect-htm-field) value))) + +(define-public &incorrect-htu-field + (make-exception-type + '&incorrect-htu-field + &external-error + '(value))) + +(define-public (raise-incorrect-htu-field value) + (raise-exception + ((record-constructor &incorrect-htu-field) value))) + (define-public ¬-an-access-token (make-exception-type '¬-an-access-token @@ -327,6 +379,36 @@ (raise-exception ((record-constructor ¬-an-access-token-payload) value cause))) +(define-public ¬-a-dpop-proof + (make-exception-type + '¬-a-dpop-proof + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof) value cause))) + +(define-public ¬-a-dpop-proof-header + (make-exception-type + '¬-a-dpop-proof-header + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof-header value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof-header) value cause))) + +(define-public ¬-a-dpop-proof-payload + (make-exception-type + '¬-a-dpop-proof-payload + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof-payload value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof-payload) value cause))) + (define-public &cannot-fetch-issuer-configuration (make-exception-type '&cannot-fetch-issuer-configuration @@ -347,6 +429,66 @@ (raise-exception ((record-constructor &cannot-fetch-jwks) issuer uri cause))) +(define-public &dpop-method-mismatch + (make-exception-type + '&dpop-method-mismatch + &external-error + '(signed requested))) + +(define-public (raise-dpop-method-mismatch signed requested) + (raise-exception + ((record-constructor &dpop-method-mismatch) signed requested))) + +(define-public &dpop-uri-mismatch + (make-exception-type + '&dpop-uri-mismatch + &external-error + '(signed requested))) + +(define-public (raise-dpop-uri-mismatch signed requested) + (raise-exception + ((record-constructor &dpop-uri-mismatch) signed requested))) + +(define-public &dpop-signed-in-future + (make-exception-type + '&dpop-signed-in-future + &external-error + '(signed requested))) + +(define-public (raise-dpop-signed-in-future signed requested) + (raise-exception + ((record-constructor &dpop-signed-in-future) signed requested))) + +(define-public &dpop-too-old + (make-exception-type + '&dpop-too-old + &external-error + '(signed requested))) + +(define-public (raise-dpop-too-old signed requested) + (raise-exception + ((record-constructor &dpop-too-old) signed requested))) + +(define-public &dpop-unconfirmed-key + (make-exception-type + '&dpop-unconfirmed-key + &external-error + '(key expected cause))) + +(define-public (raise-dpop-unconfirmed-key key expected cause) + (raise-exception + ((record-constructor &dpop-unconfirmed-key) key expected cause))) + +(define-public &jti-found + (make-exception-type + '&jti-found + &external-error + '(jti cause))) + +(define-public (raise-jti-found jti cause) + (raise-exception + ((record-constructor &jti-found) jti cause))) + (define-public &cannot-decode-access-token (make-exception-type '&cannot-decode-access-token @@ -367,6 +509,26 @@ (raise-exception ((record-constructor &cannot-encode-access-token) access-token key cause))) +(define-public &cannot-decode-dpop-proof + (make-exception-type + '&cannot-decode-dpop-proof + &external-error + '(value cause))) + +(define-public (raise-cannot-decode-dpop-proof value cause) + (raise-exception + ((record-constructor &cannot-decode-dpop-proof) value cause))) + +(define-public &cannot-encode-dpop-proof + (make-exception-type + '&cannot-encode-dpop-proof + &external-error + '(dpop-proof key cause))) + +(define-public (raise-cannot-encode-dpop-proof dpop-proof key cause) + (raise-exception + ((record-constructor &cannot-encode-dpop-proof) dpop-proof key cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -497,39 +659,108 @@ (if value (format #f (G_ "the client-id field is incorrect: ~s") value) (format #f (G_ "the client-id field is missing"))))) + ((&incorrect-typ-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the typ field is incorrect: ~s") value) + (format #f (G_ "the typ field is missing"))))) + ((&incorrect-jwk-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the jwk field is incorrect: ~s (because ~a)") + value (recurse (get 'cause))) + (format #f (G_ "the jwk field is missing"))))) + ((&incorrect-jti-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the jti field is incorrect: ~s") value) + (format #f (G_ "the jti field is missing"))))) + ((&incorrect-htm-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the htm field is incorrect: ~s") value) + (format #f (G_ "the htm field is missing"))))) + ((&incorrect-htu-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the htu field is incorrect: ~s") value) + (format #f (G_ "the htu field is missing"))))) ((¬-an-access-token) - (format #f (G_ "~s is not an access token (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token (because ~a)") + (get 'value) (recurse (get 'cause)))) ((¬-an-access-token-header) - (format #f (G_ "~s is not an access token header (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token header (because ~a)") + (get 'value) (recurse (get 'cause)))) ((¬-an-access-token-payload) - (format #f (G_ "~s is not an access token payload (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token payload (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof) + (format #f (G_ "~s is not a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof-header) + (format #f (G_ "~s is not a DPoP proof header (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof-payload) + (format #f (G_ "~s is not a DPoP proof payload (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&cannot-fetch-issuer-configuration) - (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)" - (let ((iss (get 'issuer))) - (when (uri? iss) - (set! iss (uri->string iss))) - iss) - (recurse (get 'cause))))) + (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)") + (let ((iss (get 'issuer))) + (when (uri? iss) + (set! iss (uri->string iss))) + iss) + (recurse (get 'cause)))) ((&cannot-fetch-jwks) - (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)" - (let ((iss (get 'issuer))) - (when (uri? iss) - (set! iss (uri->string iss))) - iss) - (let ((uri (get 'uri))) - (when (uri? uri) - (set! uri (uri->string uri))) - uri) - (recurse (get 'cause))))) + (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)") + (let ((iss (get 'issuer))) + (when (uri? iss) + (set! iss (uri->string iss))) + iss) + (let ((uri (get 'uri))) + (when (uri? uri) + (set! uri (uri->string uri))) + uri) + (recurse (get 'cause)))) + ((&dpop-method-mismatch) + (format #f (G_ "the HTTP method is signed for ~s, but ~s was requested") + (get 'signed) (get 'requested))) + ((&dpop-uri-mismatch) + (format #f (G_ "the HTTP uri is signed for ~a, but ~a was requested") + (uri->string (get 'signed)) (uri->string (get 'requested)))) + ((&dpop-signed-in-future) + (format #f (G_ "the date is ~a, but the DPoP proof is signed in the future at ~a") + (time-second (date->time-utc (get 'signed))) + (time-second (date->time-utc (get 'requested))))) + ((&dpop-too-old) + (format #f (G_ "the date is ~a, but the DPoP proof was signed too long ago at ~a") + (time-second (date->time-utc (get 'signed))) + (time-second (date->time-utc (get 'requested))))) + ((&dpop-unconfirmed-key) + (let ((key (get 'key)) + (expected (get 'expected)) + (cause (get 'cause))) + (cond + (expected + (format #f (G_ "the key ~s does not hash to ~a") key expected)) + (cause + (format #f (G_ "the key confirmation of ~s failed (because ~a)") key (recurse cause))) + (else + (format #f (G_ "the key confirmation of ~s failed") key))))) + ((&jti-found) + (format #f (G_ "the jti ~s has already been found (because ~a)") + (get 'jti) (recurse (get 'cause)))) ((&cannot-decode-access-token) - (format #f (G_ "I cannot decode ~s as an access token (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "I cannot decode ~s as an access token (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&cannot-encode-access-token) (format #f (G_ "I cannot encode ~s as an access token with key ~s (because ~a)") (get 'access-token) (get 'key) (recurse (get 'cause)))) + ((&cannot-decode-dpop-proof) + (format #f (G_ "I cannot decode ~s as a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((&cannot-encode-dpop-proof) + (format #f (G_ "I cannot encode ~s as a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) @@ -564,6 +795,10 @@ ((&quit-exception) (format #f (G_ "the program quits with code ~a") (get 'code))) + ((&non-continuable) + (format #f (G_ "the program cannot recover from this exception"))) + ((&error) + (format #f (G_ "there is an error"))) (else (error (format #f (G_ "Unhandled exception type ~a.") (record-type-name type)))))) diff --git a/src/scm/webid-oidc/jti.scm b/src/scm/webid-oidc/jti.scm new file mode 100644 index 0000000..423382a --- /dev/null +++ b/src/scm/webid-oidc/jti.scm @@ -0,0 +1,34 @@ +(define-module (webid-oidc jti) + #:use-module (ice-9 atomic) + #:use-module (ice-9 threads) + #:use-module (srfi srfi-19)) + +(define-public (make-jti-list) + (make-atomic-box '())) + +(define-public (lookup list jti) + (if (null? list) + #f + (or (string=? (assq-ref (car list) 'jti) jti) + (lookup (cdr list) jti)))) + +(define-public (jti-check current-time jti list valid-time) + (when (date? current-time) + (set! current-time (date->time-utc current-time))) + (when (time? current-time) + (set! current-time (time-second current-time))) + (let* ((old (atomic-box-ref list)) + (new-entry `((exp . ,(+ current-time valid-time)) + (jti . ,jti))) + (new (filter + (lambda (entry) + (let ((exp (assq-ref entry 'exp))) + (>= exp current-time))) + (cons new-entry old)))) + (let ((present? (lookup old jti))) + (if present? + #f + (let ((discarded (atomic-box-compare-and-swap! list old new))) + (if (eq? discarded old) + #t + (jti-check current-time jti list valid-time))))))) diff --git a/tests/Makefile.am b/tests/Makefile.am index 1959c84..37a4a82 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -16,7 +16,14 @@ TESTS = %reldir%/load-library.scm \ %reldir%/jws.scm \ %reldir%/cache-valid.scm \ %reldir%/cache-revalidate.scm \ - %reldir%/oidc-configuration.scm + %reldir%/oidc-configuration.scm \ + %reldir%/dpop-proof-valid.scm \ + %reldir%/dpop-proof-wrong-htm.scm \ + %reldir%/dpop-proof-wrong-htu.scm \ + %reldir%/dpop-proof-iat-in-future.scm \ + %reldir%/dpop-proof-iat-too-late.scm \ + %reldir%/dpop-proof-wrong-key.scm \ + %reldir%/dpop-proof-replay.scm EXTRA_DIST += $(TESTS) diff --git a/tests/dpop-proof-iat-in-future.scm b/tests/dpop-proof-iat-in-future.scm new file mode 100644 index 0000000..7444a02 --- /dev/null +++ b/tests/dpop-proof-iat-in-future.scm @@ -0,0 +1,37 @@ +(use-modules (webid-oidc dpop-proof) + (webid-oidc jti) + (webid-oidc jwk) + (webid-oidc testing) + (webid-oidc errors) + (web uri) + (srfi srfi-19) + (web response)) + +(with-test-environment + "dpop-proof-iat-in-future" + (lambda () + (define jwk (generate-key #:n-size 2048)) + (define cnf (jkt jwk)) + (define blacklist (make-jti-list)) + (define proof + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag") + #:iat (time-utc->date (make-time time-utc 0 10)))) + (with-exception-handler + (lambda (error) + (unless ((record-predicate &dpop-signed-in-future) + ((record-accessor &cannot-decode-dpop-proof 'cause) error)) + (raise-exception error))) + (lambda () + (dpop-proof-decode (time-utc->date (make-time time-utc 0 0)) + blacklist + 'GET + (string->uri "https://example.com/res?query") + proof + cnf) + (exit 2)) + #:unwind? #t + #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-iat-too-late.scm b/tests/dpop-proof-iat-too-late.scm new file mode 100644 index 0000000..1a56f22 --- /dev/null +++ b/tests/dpop-proof-iat-too-late.scm @@ -0,0 +1,37 @@ +(use-modules (webid-oidc dpop-proof) + (webid-oidc jti) + (webid-oidc jwk) + (webid-oidc testing) + (webid-oidc errors) + (web uri) + (srfi srfi-19) + (web response)) + +(with-test-environment + "dpop-proof-iat-too-late" + (lambda () + (define jwk (generate-key #:n-size 2048)) + (define cnf (jkt jwk)) + (define blacklist (make-jti-list)) + (define proof + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag") + #:iat (time-utc->date (make-time time-utc 0 0)))) + (with-exception-handler + (lambda (error) + (unless ((record-predicate &dpop-too-old) + ((record-accessor &cannot-decode-dpop-proof 'cause) error)) + (raise-exception error))) + (lambda () + (dpop-proof-decode (time-utc->date (make-time time-utc 0 600)) + blacklist + 'GET + (string->uri "https://example.com/res?query") + proof + cnf) + (exit 2)) + #:unwind? #t + #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-replay.scm b/tests/dpop-proof-replay.scm new file mode 100644 index 0000000..b527dce --- /dev/null +++ b/tests/dpop-proof-replay.scm @@ -0,0 +1,40 @@ +(use-modules (webid-oidc dpop-proof) + (webid-oidc jti) + (webid-oidc jwk) + (webid-oidc testing) + (webid-oidc errors) + (web uri) + (srfi srfi-19) + (web response)) + +(with-test-environment + "dpop-proof-replay" + (lambda () + (define jwk (generate-key #:n-size 2048)) + (define cnf (jkt jwk)) + (define blacklist (make-jti-list)) + (define proof + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag") + #:iat (time-utc->date (make-time time-utc 0 0)))) + (define (decode) + (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) + blacklist + 'GET + (string->uri "https://example.com/res?query") + proof + cnf)) + (define decoded-once (decode)) + (with-exception-handler + (lambda (error) + (unless ((record-predicate &jti-found) + ((record-accessor &cannot-decode-dpop-proof 'cause) error)) + (raise-exception error))) + (lambda () + (decode) + (exit 2)) + #:unwind? #t + #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-valid.scm b/tests/dpop-proof-valid.scm new file mode 100644 index 0000000..a05a223 --- /dev/null +++ b/tests/dpop-proof-valid.scm @@ -0,0 +1,30 @@ +(use-modules (webid-oidc dpop-proof) + (webid-oidc jti) + (webid-oidc jwk) + (webid-oidc testing) + (web uri) + (srfi srfi-19) + (web response)) + +(with-test-environment + "dpop-proof-valid" + (lambda () + (define jwk (generate-key #:n-size 2048)) + (define cnf (jkt jwk)) + (define blacklist (make-jti-list)) + (define proof + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag") + #:iat (time-utc->date (make-time time-utc 0 0)))) + (define decoded + (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) + blacklist + 'GET + (string->uri "https://example.com/res?query") + proof + cnf)) + (unless decoded + (exit 1)))) diff --git a/tests/dpop-proof-wrong-htm.scm b/tests/dpop-proof-wrong-htm.scm new file mode 100644 index 0000000..4531a44 --- /dev/null +++ b/tests/dpop-proof-wrong-htm.scm @@ -0,0 +1,37 @@ +(use-modules (webid-oidc dpop-proof) + (webid-oidc jti) + (webid-oidc jwk) + (webid-oidc testing) + (webid-oidc errors) + (web uri) + (srfi srfi-19) + (web response)) + +(with-test-environment + "dpop-proof-wrong-htm" + (lambda () + (define jwk (generate-key #:n-size 2048)) + (define cnf (jkt jwk)) + (define blacklist (make-jti-list)) + (define proof + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'POST + #:htu (string->uri "https://example.com/res#frag") + #:iat (time-utc->date (make-time time-utc 0 0)))) + (with-exception-handler + (lambda (error) + (unless ((record-predicate &dpop-method-mismatch) + ((record-accessor &cannot-decode-dpop-proof 'cause) error)) + (raise-exception error))) + (lambda () + (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) + blacklist + 'GET + (string->uri "https://example.com/res?query") + proof + cnf) + (exit 2)) + #:unwind? #t + #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-wrong-htu.scm b/tests/dpop-proof-wrong-htu.scm new file mode 100644 index 0000000..f8ecb29 --- /dev/null +++ b/tests/dpop-proof-wrong-htu.scm @@ -0,0 +1,37 @@ +(use-modules (webid-oidc dpop-proof) + (webid-oidc jti) + (webid-oidc jwk) + (webid-oidc testing) + (webid-oidc errors) + (web uri) + (srfi srfi-19) + (web response)) + +(with-test-environment + "dpop-proof-wrong-htu" + (lambda () + (define jwk (generate-key #:n-size 2048)) + (define cnf (jkt jwk)) + (define blacklist (make-jti-list)) + (define proof + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/other-res#frag") + #:iat (time-utc->date (make-time time-utc 0 0)))) + (with-exception-handler + (lambda (error) + (unless ((record-predicate &dpop-uri-mismatch) + ((record-accessor &cannot-decode-dpop-proof 'cause) error)) + (raise-exception error))) + (lambda () + (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) + blacklist + 'GET + (string->uri "https://example.com/res?query") + proof + cnf) + (exit 2)) + #:unwind? #t + #:unwind-for-type &cannot-decode-dpop-proof))) diff --git a/tests/dpop-proof-wrong-key.scm b/tests/dpop-proof-wrong-key.scm new file mode 100644 index 0000000..9ea98ee --- /dev/null +++ b/tests/dpop-proof-wrong-key.scm @@ -0,0 +1,37 @@ +(use-modules (webid-oidc dpop-proof) + (webid-oidc jti) + (webid-oidc jwk) + (webid-oidc testing) + (webid-oidc errors) + (web uri) + (srfi srfi-19) + (web response)) + +(with-test-environment + "dpop-proof-wrong-key" + (lambda () + (define jwk (generate-key #:n-size 2048)) + (define cnf (jkt (generate-key #:n-size 2048))) + (define blacklist (make-jti-list)) + (define proof + (issue-dpop-proof + jwk + #:alg 'RS256 + #:htm 'GET + #:htu (string->uri "https://example.com/res#frag") + #:iat (time-utc->date (make-time time-utc 0 0)))) + (with-exception-handler + (lambda (error) + (unless ((record-predicate &dpop-unconfirmed-key) + ((record-accessor &cannot-decode-dpop-proof 'cause) error)) + (raise-exception error))) + (lambda () + (dpop-proof-decode (time-utc->date (make-time time-utc 0 10)) + blacklist + 'GET + (string->uri "https://example.com/res?query") + proof + cnf) + (exit 2)) + #:unwind? #t + #:unwind-for-type &cannot-decode-dpop-proof))) -- cgit v1.2.3