From 57aea257548dbfbe0324baf7919d1fe29e91bb3d Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Fri, 27 Nov 2020 19:42:01 +0100 Subject: Implement JWS encoding and decoding --- NEWS | 2 + doc/webid-oidc.texi | 80 +++++++++++++++++++++++ po/fr.po | 130 +++++++++++++++++++------------------ po/webid-oidc.pot | 92 +++++++++++++++++++------- src/scm/webid-oidc.scm | 3 +- src/scm/webid-oidc/Makefile.am | 7 +- src/scm/webid-oidc/errors.scm | 104 ++++++++++++++++++++++++++++++ src/scm/webid-oidc/jws.scm | 143 +++++++++++++++++++++++++++++++++++++++++ tests/Makefile.am | 3 +- tests/jws.scm | 51 +++++++++++++++ 10 files changed, 524 insertions(+), 91 deletions(-) create mode 100644 src/scm/webid-oidc/jws.scm create mode 100644 tests/jws.scm diff --git a/NEWS b/NEWS index 8148e14..31a0278 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,8 @@ correct key. ** Sign and verify signatures The function =sign= creates a signature with a known JWA, and =verify= verifies the signature. +** Encode and decode a JWS +The decoding function lets you fetch a key for validation. # Local Variables: # mode: org # End: diff --git a/doc/webid-oidc.texi b/doc/webid-oidc.texi index a435c33..7a1b6ea 100644 --- a/doc/webid-oidc.texi +++ b/doc/webid-oidc.texi @@ -108,6 +108,47 @@ following, we will only be interested by public-key cryptography. The concatenation of header, dot, payload, dot and signature in base64 is the encoding of the JWT. +Decoded JWT are represented as a pair. The car of the pair is the +header, and the cdr is the payload. Both the header and the payload +use the JSON representation from srfi-180: objects are alists of +@strong{symbols} to values, arrays are vectors. It is unfortunate that +guile-json has a slightly different representation, where alist keys +are @emph{strings}, but we hope that in the future SRFI-180 will be +more closely respected. + +@menu +* Generic JWTs:: +@end menu + +@node Generic JWTs +@section Generic JWTs + +You can parse generic JWTs signed with JWS with the following +functions from @emph{(webid-oidc jws)}. + +@deffn function jws? @var{jwt} +Check that @var{jwt} is a decoded JWT signed with JWS. +@end deffn + +@deffn function jws-alg @var{jwt} +Get the algorithm used to sign @var{jwt}. +@end deffn + +@deffn function jws-decode @var{str} @var{lookup-keys} +Check and decode a JWT signed with JWS and encoded as @var{str}. + +Since the decoding and signature verification happen at the same time +(for user friendliness), the @var{lookup-keys} function is used. It is +passed as arguments the decoded JWT (but the signature is not checked +yet), and it should return a public key, a public key set or a list of +public keys. If the key lookup failed, this function should raise an +exception. +@end deffn + +@deffn function jws-encode @var{jwt} @var{key} +Encode the JWT and sign it with @var{key}. +@end deffn + @node Exceptional conditions @chapter Exceptional conditions @@ -143,6 +184,11 @@ Each JWT type – access token, DPoP proof, ID token, authorization code (this is internal to the identity provider) has different validation rules, and can fail in different ways. + +@deftp {exception type} ¬-json @var{value} @var{cause} +Cannot decode @var{value} to a JSON object. +@end deftp + @deftp {exception type} &unsupported-crv @var{crv} The identifier @var{crv} does not identify an elliptic curve. @end deftp @@ -171,6 +217,40 @@ The identifier @var{crv} does not identify an elliptic curve. @var{key} has not signed @var{payload} with @var{signature}. @end deftp +@deftp {exception type} &missing-alist-key @var{value} @var{key} +@var{value} isn’t an alist, or is missing a value with @var{key}. +@end deftp + +@deftp {exception type} ¬-a-jws-header @var{value} @var{cause} +@var{value} does not identify a decoded JWS header. +@end deftp + +@deftp {exception type} ¬-a-jws-payload @var{value} @var{cause} +@var{value} does not identify a decoded JWS payload. +@end deftp + +@deftp {exception type} ¬-a-jws @var{value} @var{cause} +@var{value} does not identify a decoded JWS. +@end deftp + +@deftp {exception type} ¬-in-3-parts @var{string} @var{separator} +@var{string} cannot be split into 3 parts with @var{separator}. +@end deftp + +@deftp {exception type} &no-matching-key @var{candidates} @var{alg} @var{payload} @var{signature} +No key among @var{candidates} could verify @var{signature} signed with +@var{alg} for @var{payload}, because the signature mismatched for all +keys. +@end deftp + +@deftp {exception type} &cannot-decode-jws @var{value} @var{cause} +The @var{value} string is not an encoding of a valid JWS. +@end deftp + +@deftp {exception type} &cannot-encode-jws @var{jws} @var{key} @var{cause} +The @var{jws} cannot be signed. +@end deftp + @node GNU Free Documentation License @appendix GNU Free Documentation License diff --git a/po/fr.po b/po/fr.po index 66fe7b1..d8023b3 100644 --- a/po/fr.po +++ b/po/fr.po @@ -126,122 +126,166 @@ 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:115 +#: src/scm/webid-oidc/errors.scm:195 msgid "that’s how it is" msgstr "c’est comme ça" -#: src/scm/webid-oidc/errors.scm:120 +#: src/scm/webid-oidc/errors.scm:200 #, 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:123 +#: src/scm/webid-oidc/errors.scm:203 #, 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:126 +#: src/scm/webid-oidc/errors.scm:206 #, 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:131 +#: src/scm/webid-oidc/errors.scm:211 #, 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:133 +#: src/scm/webid-oidc/errors.scm:213 #, 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:138 +#: src/scm/webid-oidc/errors.scm:218 #, 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:140 +#: src/scm/webid-oidc/errors.scm:220 #, 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:145 +#: src/scm/webid-oidc/errors.scm:225 #, 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:147 +#: src/scm/webid-oidc/errors.scm:227 #, 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:152 +#: src/scm/webid-oidc/errors.scm:232 #, 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:154 +#: src/scm/webid-oidc/errors.scm:234 #, 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:157 +#: src/scm/webid-oidc/errors.scm:237 #, 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:162 +#: src/scm/webid-oidc/errors.scm:240 +#, 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:243 +#, 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:246 +#, 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:249 +#, 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:252 +#, 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:255 +#, scheme-format +msgid "" +"all key candidates failed to verify signature ~s with algorithm ~s and " +"payload ~a (there were ~a: ~s)" +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:258 +#, 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:261 +#, 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:266 msgid "that’s it" msgstr "c’est tout" -#: src/scm/webid-oidc/errors.scm:166 +#: src/scm/webid-oidc/errors.scm:270 #, scheme-format msgid "~a and ~a" msgstr "~a et ~a" -#: src/scm/webid-oidc/errors.scm:169 +#: src/scm/webid-oidc/errors.scm:273 #, scheme-format msgid "~a, ~a" msgstr "~a, ~a" -#: src/scm/webid-oidc/errors.scm:173 +#: src/scm/webid-oidc/errors.scm:277 #, 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:176 +#: src/scm/webid-oidc/errors.scm:280 msgid "there is an undefined variable" msgstr "il y a une variable non définie" -#: src/scm/webid-oidc/errors.scm:178 +#: src/scm/webid-oidc/errors.scm:282 #, scheme-format msgid "the origin is ~a" msgstr "l’origine est ~a" -#: src/scm/webid-oidc/errors.scm:181 +#: src/scm/webid-oidc/errors.scm:285 #, scheme-format msgid "a message is attached: ~a" msgstr "un message est attaché : ~a" -#: src/scm/webid-oidc/errors.scm:184 +#: src/scm/webid-oidc/errors.scm:288 #, scheme-format msgid "the values ~s are problematic" msgstr "les valeurs ~s sont problématiques" -#: src/scm/webid-oidc/errors.scm:187 +#: src/scm/webid-oidc/errors.scm:291 msgid "there is a kind and args" msgstr "il y a un type et des arguments" -#: src/scm/webid-oidc/errors.scm:189 +#: src/scm/webid-oidc/errors.scm:293 msgid "there is an assertion failure" msgstr "il y a un échec d’assertion" -#: src/scm/webid-oidc/errors.scm:191 +#: src/scm/webid-oidc/errors.scm:295 #, scheme-format msgid "the program quits with code ~a" msgstr "le programme quitte avec le code ~a" -#: src/scm/webid-oidc/errors.scm:194 +#: src/scm/webid-oidc/errors.scm:298 #, scheme-format msgid "Unhandled exception type ~a." msgstr "Type d’exception non pris en charge ~a." @@ -250,42 +294,6 @@ msgstr "Type d’exception non pris en charge ~a." #~ msgid "the value ~s is not Turtle (because ~a)" #~ msgstr "la valeur ~s n’est pas du Turtle (parce que ~a)" -#, 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" - -#, 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)" - -#, 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)" - -#, scheme-format -#~ msgid "the value ~s is not a JWS (because ~a)" -#~ msgstr "la valeur ~s n’est pas un JWS (parce que ~a)" - -#, 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" - -#, scheme-format -#~ msgid "" -#~ "all key candidates failed to verify signature ~s with algorithm ~s and " -#~ "payload ~a (there were ~a: ~s)" -#~ 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)" - -#, 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)" - -#, scheme-format -#~ msgid "I cannot encode JWS ~a (because ~a)" -#~ msgstr "je n’ai pas pu encoder le JWS ~a (parce que ~a)" - #, scheme-format #~ msgid "" #~ "the server request unexpectedly failed with code ~a and reason phrase ~s" diff --git a/po/webid-oidc.pot b/po/webid-oidc.pot index 29153a4..147fe5e 100644 --- a/po/webid-oidc.pot +++ b/po/webid-oidc.pot @@ -122,122 +122,164 @@ msgstr "" msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n" msgstr "" -#: src/scm/webid-oidc/errors.scm:115 +#: src/scm/webid-oidc/errors.scm:195 msgid "that’s how it is" msgstr "" -#: src/scm/webid-oidc/errors.scm:120 +#: src/scm/webid-oidc/errors.scm:200 #, scheme-format msgid "the value ~s is not a base64 string (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:123 +#: src/scm/webid-oidc/errors.scm:203 #, scheme-format msgid "the value ~s is not JSON (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:126 +#: src/scm/webid-oidc/errors.scm:206 #, scheme-format msgid "the value ~s does not identify an elleptic curve" msgstr "" -#: src/scm/webid-oidc/errors.scm:131 +#: src/scm/webid-oidc/errors.scm:211 #, scheme-format msgid "the value ~s does not identify a JWK (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:133 +#: src/scm/webid-oidc/errors.scm:213 #, scheme-format msgid "the value ~s does not identify a JWK" msgstr "" -#: src/scm/webid-oidc/errors.scm:138 +#: src/scm/webid-oidc/errors.scm:218 #, scheme-format msgid "the value ~s does not identify a public JWK (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:140 +#: src/scm/webid-oidc/errors.scm:220 #, scheme-format msgid "the value ~s does not identify a public JWK" msgstr "" -#: src/scm/webid-oidc/errors.scm:145 +#: src/scm/webid-oidc/errors.scm:225 #, scheme-format msgid "the value ~s does not identify a private JWK (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:147 +#: src/scm/webid-oidc/errors.scm:227 #, scheme-format msgid "the value ~s does not identify a private JWK" msgstr "" -#: src/scm/webid-oidc/errors.scm:152 +#: src/scm/webid-oidc/errors.scm:232 #, scheme-format msgid "the value ~s does not identify a JWKS (because ~a)" msgstr "" -#: src/scm/webid-oidc/errors.scm:154 +#: src/scm/webid-oidc/errors.scm:234 #, scheme-format msgid "the value ~s does not identify a JWKS" msgstr "" -#: src/scm/webid-oidc/errors.scm:157 +#: src/scm/webid-oidc/errors.scm:237 #, scheme-format msgid "the value ~s does not identify a hash algorithm" msgstr "" -#: src/scm/webid-oidc/errors.scm:162 +#: src/scm/webid-oidc/errors.scm:240 +#, scheme-format +msgid "the value ~s is not an alist or misses key ~s" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:243 +#, scheme-format +msgid "the value ~s is not a JWS header (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:246 +#, scheme-format +msgid "the value ~s is not a JWS payload (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:249 +#, scheme-format +msgid "the value ~s is not a JWS (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:252 +#, scheme-format +msgid "the string ~s cannot be split in 3 parts with ~s" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:255 +#, 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:258 +#, scheme-format +msgid "I cannot decode JWS ~a (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:261 +#, scheme-format +msgid "I cannot encode JWS ~a (because ~a)" +msgstr "" + +#: src/scm/webid-oidc/errors.scm:266 msgid "that’s it" msgstr "" -#: src/scm/webid-oidc/errors.scm:166 +#: src/scm/webid-oidc/errors.scm:270 #, scheme-format msgid "~a and ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:169 +#: src/scm/webid-oidc/errors.scm:273 #, scheme-format msgid "~a, ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:173 +#: src/scm/webid-oidc/errors.scm:277 #, scheme-format msgid "the signature ~a does not match key ~s with payload ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:176 +#: src/scm/webid-oidc/errors.scm:280 msgid "there is an undefined variable" msgstr "" -#: src/scm/webid-oidc/errors.scm:178 +#: src/scm/webid-oidc/errors.scm:282 #, scheme-format msgid "the origin is ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:181 +#: src/scm/webid-oidc/errors.scm:285 #, scheme-format msgid "a message is attached: ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:184 +#: src/scm/webid-oidc/errors.scm:288 #, scheme-format msgid "the values ~s are problematic" msgstr "" -#: src/scm/webid-oidc/errors.scm:187 +#: src/scm/webid-oidc/errors.scm:291 msgid "there is a kind and args" msgstr "" -#: src/scm/webid-oidc/errors.scm:189 +#: src/scm/webid-oidc/errors.scm:293 msgid "there is an assertion failure" msgstr "" -#: src/scm/webid-oidc/errors.scm:191 +#: src/scm/webid-oidc/errors.scm:295 #, scheme-format msgid "the program quits with code ~a" msgstr "" -#: src/scm/webid-oidc/errors.scm:194 +#: src/scm/webid-oidc/errors.scm:298 #, scheme-format msgid "Unhandled exception type ~a." msgstr "" diff --git a/src/scm/webid-oidc.scm b/src/scm/webid-oidc.scm index a9a4699..38c563d 100644 --- a/src/scm/webid-oidc.scm +++ b/src/scm/webid-oidc.scm @@ -1,2 +1,3 @@ (define-module (webid-oidc) - #:use-module (webid-oidc config)) + #:use-module (webid-oidc config) + #:use-module (webid-oidc jws)) diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 8c504d2..aca5f0c 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -2,10 +2,11 @@ dist_webidoidcmod_DATA += \ %reldir%/errors.scm \ %reldir%/stubs.scm \ %reldir%/testing.scm \ - %reldir%/jwk.scm - + %reldir%/jwk.scm \ + %reldir%/jws.scm webidoidcgo_DATA += \ %reldir%/errors.go \ %reldir%/stubs.go \ %reldir%/testing.go \ - %reldir%/jwk.go + %reldir%/jwk.go \ + %reldir%/jws.go diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index ad8fef3..e6c7a3e 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -104,6 +104,86 @@ (raise-exception ((record-constructor &invalid-signature) key payload signature))) +(define-public ¬-a-jws-header + (make-exception-type + '¬-a-jws-header + &external-error + '(value cause))) + +(define-public (raise-not-a-jws-header value cause) + (raise-exception + ((record-constructor ¬-a-jws-header) value cause))) + +(define-public ¬-a-jws-payload + (make-exception-type + '¬-a-jws-payload + &external-error + '(value cause))) + +(define-public (raise-not-a-jws-payload value cause) + (raise-exception + ((record-constructor ¬-a-jws-payload) value cause))) + +(define-public ¬-a-jws + (make-exception-type + '¬-a-jws + &external-error + '(value cause))) + +(define-public (raise-not-a-jws value cause) + (raise-exception + ((record-constructor ¬-a-jws-payload) value cause))) + +(define-public ¬-in-3-parts + (make-exception-type + '¬-in-3-parts + &external-error + '(string separator))) + +(define-public (raise-not-in-3-parts string separator) + (raise-exception + ((record-constructor ¬-in-3-parts) string separator))) + +(define-public &missing-alist-key + (make-exception-type + '&missing-alist-key + &external-error + '(value key))) + +(define-public (raise-missing-alist-key value key) + (raise-exception + ((record-constructor &missing-alist-key) value key))) + +(define-public &no-matching-key + (make-exception-type + '&no-matching-key + &external-error + '(candidates alg payload signature other-problems))) + +(define-public (raise-no-matching-key candidates alg payload signature) + (raise-exception + ((record-constructor &no-matching-key) candidates alg payload signature))) + +(define-public &cannot-decode-jws + (make-exception-type + '&cannot-decode-jws + &external-error + '(value cause))) + +(define-public (raise-cannot-decode-jws value cause) + (raise-exception + ((record-constructor &cannot-decode-jws) value cause))) + +(define-public &cannot-encode-jws + (make-exception-type + '&cannot-encode-jws + &external-error + '(jws key cause))) + +(define-public (raise-cannot-encode-jws jws key cause) + (raise-exception + ((record-constructor &cannot-encode-jws) jws key cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -156,6 +236,30 @@ ((&unsupported-alg) (format #f (G_ "the value ~s does not identify a hash algorithm") (get 'value))) + ((&missing-alist-key) + (format #f (G_ "the value ~s is not an alist or misses key ~s") + (get 'value) (get 'key))) + ((¬-a-jws-header) + (format #f (G_ "the value ~s is not a JWS header (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-jws-payload) + (format #f (G_ "the value ~s is not a JWS payload (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-jws) + (format #f (G_ "the value ~s is not a JWS (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-in-3-parts) + (format #f (G_ "the string ~s cannot be split in 3 parts with ~s") + (get 'string) (get 'separator))) + ((&no-matching-key) + (format #f (G_ "all key candidates failed to verify signature ~s with algorithm ~s and payload ~a (there were ~a: ~s)") + (get 'signature) (get 'alg) (get 'payload) (length (get 'candidates)) (get 'candidates))) + ((&cannot-decode-jws) + (format #f (G_ "I cannot decode JWS ~a (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((&cannot-encode-jws) + (format #f (G_ "I cannot encode JWS ~a (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm new file mode 100644 index 0000000..fb3edd1 --- /dev/null +++ b/src/scm/webid-oidc/jws.scm @@ -0,0 +1,143 @@ +(define-module (webid-oidc jws) + #:use-module (webid-oidc jwk) + #:use-module (webid-oidc errors) + #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 receive)) + +(define-public (the-jws-header x) + (with-exception-handler + (lambda (cause) + (raise-not-a-jws-header x cause)) + (lambda () + (let ((alg (assq-ref x 'alg))) + (unless alg + (raise-missing-alist-key x 'alg)) + (unless (string? alg) + (raise-unsupported-alg alg)) + (case (string->symbol alg) + ((HS256 HS384 HS512 RS256 RS384 RS512 ES256 ES384 ES512 PS256 PS384 PS512) + x) + (else + (raise-unsupported-alg (string->symbol alg)))))))) + +(define-public (the-jws-payload x) + (with-exception-handler + (lambda (cause) + (raise-not-a-jws-payload x cause)) + (lambda () + (unless (list? x) + (scm-error 'wrong-type-arg "the-jws-payload" "expected a list" '() (list x))) + x))) + +(define-public (the-jws x) + (with-exception-handler + (lambda (cause) + (raise-not-a-jws x cause)) + (lambda () + (unless (pair? x) + (scm-error 'wrong-type-arg "the-jws" "expected a pair" '() (list x))) + (cons (the-jws-header (car x)) + (the-jws-payload (cdr x)))))) + +(define-public (jws-header? x) + (false-if-exception + (and (the-jws-header x) #t))) + +(define-public (jws-payload? x) + (false-if-exception + (and (the-jws-payload x) #t))) + +(define-public (jws? x) + (false-if-exception + (and (the-jws x) #t))) + +(define-public (make-jws header payload) + (the-jws (cons (the-jws-header header) + (the-jws-payload payload)))) + +(define-public (jws-header jws) + (car (the-jws jws))) + +(define-public (jws-payload jws) + (cdr (the-jws jws))) + +(define-public (jws-alg jws) + (if (jws? jws) + (jws-alg (jws-header jws)) + (string->symbol (assq-ref (the-jws-header jws) 'alg)))) + +(define (split-in-3-parts string separator) + (let ((parts (list->vector (string-split string separator)))) + (unless (eqv? (vector-length parts) 3) + (raise-not-in-3-parts string separator)) + (values (vector-ref parts 0) (vector-ref parts 1) (vector-ref parts 2)))) + +(define (base64-decode-json str) + (with-exception-handler + (lambda (error) + (cond + (((record-predicate ¬-base64) error) + (raise-exception error)) + (((record-predicate ¬-json) error) + (raise-exception error)) + (else + ;; From utf8->string + (raise-not-base64 str error)))) + (lambda () + (stubs:json-string->scm (utf8->string (stubs:base64-decode str)))))) + +(define (parse str verify) + (receive (header payload signature) + (split-in-3-parts str #\.) + (let ((base (string-append header "." payload)) + (header (base64-decode-json header)) + (payload (base64-decode-json payload))) + (let ((ret (make-jws header payload))) + (verify ret base signature) + ret)))) + +(define (verify-any alg keys payload signature) + (define (aux candidates) + (if (null? keys) + (raise-no-matching-key keys alg payload signature) + (let ((next-ok + (with-exception-handler + (lambda (error) + #f) + (lambda () + (stubs:verify alg (car candidates) payload signature) + #t) + #:unwind? #t + #:unwind-for-type &invalid-signature))) + (or next-ok + (aux (cdr candidates)))))) + (aux keys)) + +(define-public (jws-decode str lookup-keys) + (with-exception-handler + (lambda (error) + (raise-cannot-decode-jws str error)) + (lambda () + (parse str + (lambda (jws payload signature) + (let ((keys (lookup-keys jws))) + (let ((keys (cond ((jwk? keys) (list keys)) + ((jwks? keys) (jwks-keys keys)) + (else keys)))) + (verify-any (jws-alg jws) keys payload signature)))))))) + +(define-public (jws-encode jws key) + (with-exception-handler + (lambda (error) + (raise-cannot-encode-jws jws key error)) + (lambda () + (let ((header (jws-header jws)) + (payload (jws-payload jws))) + (let ((header (stubs:scm->json-string header)) + (payload (stubs:scm->json-string payload))) + (let ((header (stubs:base64-encode header)) + (payload (stubs:base64-encode payload))) + (let ((payload (string-append header "." payload))) + (let ((signature (stubs:sign (jws-alg jws) key payload))) + (string-append payload "." signature))))))))) diff --git a/tests/Makefile.am b/tests/Makefile.am index 22718cf..e2330a4 100644 --- a/tests/Makefile.am +++ b/tests/Makefile.am @@ -10,7 +10,8 @@ TESTS = %reldir%/load-library.scm \ %reldir%/hash-unsupported.scm \ %reldir%/jkt.scm \ %reldir%/verify.scm \ - %reldir%/verification-failed.scm + %reldir%/verification-failed.scm \ + %reldir%/jws.scm EXTRA_DIST += $(TESTS) diff --git a/tests/jws.scm b/tests/jws.scm new file mode 100644 index 0000000..502daf2 --- /dev/null +++ b/tests/jws.scm @@ -0,0 +1,51 @@ +(use-modules (webid-oidc stubs) + (webid-oidc jws) + (webid-oidc testing)) + +(with-test-environment + "jws" + (lambda () + (let* ((key (json-string->scm "{\"kty\":\"RSA\",\"e\":\"AQAB\",\"kid\":\"db7cdbbf-0ca3-48da-abf6-8f34002a4651\",\"n\":\"nzyis1ZjfNB0bBgKFMSvvkTtwlvBsaJq7S5wA-kzeVOVpVWwkWdVha4s38XM_pa_yr47av7-z3VTmvDRyAHcaT92whREFpLv9cj5lTeJSibyr_Mrm_YtjCZVWgaOYIhwrXwKLqPr_11inWsAkfIytvHWTxZYEcXLgAXFuUuaS3uF9gEiNQwzGTU1v0FqkqTBr4B8nW3HCN47XUu0t8Y0e-lf4s4OxQawWD79J9_5d3Ry0vbV3Am1FtGJiJvOwRsIfVChDpYStTcHTCMqtvWbV6L11BWkpzGXSW4Hv43qa-GSYOD2QU68Mb59oSk2OB-BtOLpJofmbGEGgvmwyCI9Mw\"}")) + (other-key (generate-key #:n-size 2048)) + (encoded "eyJhbGciOiJQUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiIxMjM0NTY3ODkwIiwibmFtZSI6IkpvaG4gRG9lIiwiYWRtaW4iOnRydWUsImlhdCI6MTUxNjIzOTAyMn0.hZnl5amPk_I3tb4O-Otci_5XZdVWhPlFyVRvcqSwnDo_srcysDvhhKOD01DigPK1lJvTSTolyUgKGtpLqMfRDXQlekRsF4XhAjYZTmcynf-C-6wO5EI4wYewLNKFGGJzHAknMgotJFjDi_NCVSjHsW3a10nTao1lB82FRS305T226Q0VqNVJVWhE4G0JQvi2TssRtCxYTqzXVt22iDKkXeZJARZ1paXHGV5Kd1CljcZtkNZYIGcwnj65gvuCwohbkIxAnhZMJXCLaVvHqv9l-AAUV7esZvkQR1IpwBAiDQJh4qxPjFGylyXrHMqh5NlT_pWL2ZoULWTg_TJjMO9TuQ") + (expected-alg "PS256") + (expected-typ "JWT") + (expected-sub "1234567890") + (expected-name "John Doe") + (expected-admin #t) + (expected-iat 1516239022) + (parsed (jws-decode encoded (lambda (jws) + (and (jws? jws) + key)))) + (parsed-header (jws-header parsed)) + (parsed-payload (jws-payload parsed)) + (alg (jws-alg parsed)) + (typ (assq-ref parsed-header 'typ)) + (sub (assq-ref parsed-payload 'sub)) + (name (assq-ref parsed-payload 'name)) + (admin (assq-ref parsed-payload 'admin)) + (iat (assq-ref parsed-payload 'iat)) + (re-encoded (jws-encode parsed other-key)) + (re-parsed (jws-decode re-encoded (lambda (jws) other-key))) + (re-parsed-header (jws-header re-parsed)) + (re-parsed-payload (jws-payload re-parsed)) + (re-alg (jws-alg re-parsed)) + (re-typ (assq-ref re-parsed-header 'typ)) + (re-sub (assq-ref re-parsed-payload 'sub)) + (re-name (assq-ref re-parsed-payload 'name)) + (re-admin (assq-ref re-parsed-payload 'admin)) + (re-iat (assq-ref re-parsed-payload 'iat))) + (unless (and (equal? alg expected-alg) + (equal? re-alg expected-alg) + (equal? typ expected-typ) + (equal? re-typ expected-typ) + (equal? sub expected-sub) + (equal? re-sub expected-sub) + (equal? name expected-name) + (equal? re-name expected-name) + (equal? admin expected-admin) + (equal? re-admin expected-admin) + (equal? iat expected-iat) + (equal? re-iat expected-iat)) + (format (current-error-port) + "The JWS test failed."))))) -- cgit v1.2.3