Provide a higher-level API for JWKs and JWKSs

6 files changed, 273 insertions, 60 deletions

diff --git a/doc/webid-oidc.texi b/doc/webid-oidc.texi
index c7bfa5b..46ca253 100644
--- a/doc/webid-oidc.texi
+++ b/doc/webid-oidc.texi
@@ -151,6 +151,18 @@ The identifier @var{crv} does not identify an elliptic curve.
 @var{value} does not identify a JWK.
 @end deftp
 
+@deftp {exception type} &not-a-public-jwk @var{value} @var{cause}
+@var{value} does not identify a public JWK.
+@end deftp
+
+@deftp {exception type} &not-a-private-jwk @var{value} @var{cause}
+@var{value} does not identify a private JWK.
+@end deftp
+
+@deftp {exception type} &not-a-jwks @var{value} @var{cause}
+@var{value} does not identify a set of public keys.
+@end deftp
+
 @deftp {exception type} &unsupported-alg @var{value}
 @var{value} does not identify a valid hash algorithm.
 @end deftp
diff --git a/po/fr.po b/po/fr.po
index 677db22..096e5c6 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -126,82 +126,112 @@ 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:75
+#: src/scm/webid-oidc/errors.scm:105
 msgid "that’s how it is"
 msgstr "c’est comme ça"
 
-#: src/scm/webid-oidc/errors.scm:80
+#: src/scm/webid-oidc/errors.scm:110
 #, 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:83
+#: src/scm/webid-oidc/errors.scm:113
 #, 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:86
+#: src/scm/webid-oidc/errors.scm:116
 #, 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:91
+#: src/scm/webid-oidc/errors.scm:121
 #, 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:93
+#: src/scm/webid-oidc/errors.scm:123
 #, 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:96
+#: src/scm/webid-oidc/errors.scm:128
+#, 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:130
+#, 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:135
+#, 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:137
+#, 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:142
+#, 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:144
+#, 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:147
 #, 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:101
+#: src/scm/webid-oidc/errors.scm:152
 msgid "that’s it"
 msgstr "c’est tout"
 
-#: src/scm/webid-oidc/errors.scm:105
+#: src/scm/webid-oidc/errors.scm:156
 #, scheme-format
 msgid "~a and ~a"
 msgstr "~a et ~a"
 
-#: src/scm/webid-oidc/errors.scm:108
+#: src/scm/webid-oidc/errors.scm:159
 #, scheme-format
 msgid "~a, ~a"
 msgstr "~a, ~a"
 
-#: src/scm/webid-oidc/errors.scm:112
+#: src/scm/webid-oidc/errors.scm:163
 msgid "there is an undefined variable"
 msgstr "il y a une variable non définie"
 
-#: src/scm/webid-oidc/errors.scm:114
+#: src/scm/webid-oidc/errors.scm:165
 #, scheme-format
 msgid "the origin is ~a"
 msgstr "l’origine est ~a"
 
-#: src/scm/webid-oidc/errors.scm:117
+#: src/scm/webid-oidc/errors.scm:168
 #, scheme-format
 msgid "a message is attached: ~a"
 msgstr "un message est attaché : ~a"
 
-#: src/scm/webid-oidc/errors.scm:120
+#: src/scm/webid-oidc/errors.scm:171
 #, scheme-format
 msgid "the values ~s are problematic"
 msgstr "les valeurs ~s sont problématiques"
 
-#: src/scm/webid-oidc/errors.scm:123
+#: src/scm/webid-oidc/errors.scm:174
 msgid "there is a kind and args"
 msgstr "il y a un type et des arguments"
 
-#: src/scm/webid-oidc/errors.scm:125
+#: src/scm/webid-oidc/errors.scm:176
 msgid "there is an assertion failure"
 msgstr "il y a un échec d’assertion"
 
-#: src/scm/webid-oidc/errors.scm:127
+#: src/scm/webid-oidc/errors.scm:178
 #, scheme-format
 msgid "Unhandled exception type ~a."
 msgstr "Type d’exception non pris en charge ~a."
@@ -211,30 +241,6 @@ msgstr "Type d’exception non pris en charge ~a."
 #~ msgstr "la valeur ~s n’est pas du Turtle (parce que ~a)"
 
 #, 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)"
-
-#, scheme-format
-#~ msgid "the value ~s does not identify a public JWK"
-#~ msgstr "la valeur ~s n’identifie pas une JWK publique"
-
-#, 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)"
-
-#, scheme-format
-#~ msgid "the value ~s does not identify a private JWK"
-#~ msgstr "la valeur ~s n’identifie pas une JWK privée"
-
-#, 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)"
-
-#, scheme-format
-#~ msgid "the value ~s does not identify a JWKS"
-#~ msgstr "la valeur ~s n’identifie pas un JWKS"
-
-#, 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"
 
diff --git a/po/webid-oidc.pot b/po/webid-oidc.pot
index 83704c4..606b5e0 100644
--- a/po/webid-oidc.pot
+++ b/po/webid-oidc.pot
@@ -122,82 +122,112 @@ msgstr ""
 msgid "Usage: generate-key [NUMBER OF BITS | CURVE]\n"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:75
+#: src/scm/webid-oidc/errors.scm:105
 msgid "that’s how it is"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:80
+#: src/scm/webid-oidc/errors.scm:110
 #, scheme-format
 msgid "the value ~s is not a base64 string (because ~a)"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:83
+#: src/scm/webid-oidc/errors.scm:113
 #, scheme-format
 msgid "the value ~s is not JSON (because ~a)"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:86
+#: src/scm/webid-oidc/errors.scm:116
 #, scheme-format
 msgid "the value ~s does not identify an elleptic curve"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:91
+#: src/scm/webid-oidc/errors.scm:121
 #, scheme-format
 msgid "the value ~s does not identify a JWK (because ~a)"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:93
+#: src/scm/webid-oidc/errors.scm:123
 #, scheme-format
 msgid "the value ~s does not identify a JWK"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:96
+#: src/scm/webid-oidc/errors.scm:128
+#, scheme-format
+msgid "the value ~s does not identify a public JWK (because ~a)"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:130
+#, scheme-format
+msgid "the value ~s does not identify a public JWK"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:135
+#, scheme-format
+msgid "the value ~s does not identify a private JWK (because ~a)"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:137
+#, scheme-format
+msgid "the value ~s does not identify a private JWK"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:142
+#, scheme-format
+msgid "the value ~s does not identify a JWKS (because ~a)"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:144
+#, scheme-format
+msgid "the value ~s does not identify a JWKS"
+msgstr ""
+
+#: src/scm/webid-oidc/errors.scm:147
 #, scheme-format
 msgid "the value ~s does not identify a hash algorithm"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:101
+#: src/scm/webid-oidc/errors.scm:152
 msgid "that’s it"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:105
+#: src/scm/webid-oidc/errors.scm:156
 #, scheme-format
 msgid "~a and ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:108
+#: src/scm/webid-oidc/errors.scm:159
 #, scheme-format
 msgid "~a, ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:112
+#: src/scm/webid-oidc/errors.scm:163
 msgid "there is an undefined variable"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:114
+#: src/scm/webid-oidc/errors.scm:165
 #, scheme-format
 msgid "the origin is ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:117
+#: src/scm/webid-oidc/errors.scm:168
 #, scheme-format
 msgid "a message is attached: ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:120
+#: src/scm/webid-oidc/errors.scm:171
 #, scheme-format
 msgid "the values ~s are problematic"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:123
+#: src/scm/webid-oidc/errors.scm:174
 msgid "there is a kind and args"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:125
+#: src/scm/webid-oidc/errors.scm:176
 msgid "there is an assertion failure"
 msgstr ""
 
-#: src/scm/webid-oidc/errors.scm:127
+#: src/scm/webid-oidc/errors.scm:178
 #, 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 e74b26c..8c504d2 100644
--- a/src/scm/webid-oidc/Makefile.am
+++ b/src/scm/webid-oidc/Makefile.am
@@ -1,9 +1,11 @@
 dist_webidoidcmod_DATA += \
   %reldir%/errors.scm \
   %reldir%/stubs.scm \
-  %reldir%/testing.scm
+  %reldir%/testing.scm \
+  %reldir%/jwk.scm
 
 webidoidcgo_DATA += \
   %reldir%/errors.go \
   %reldir%/stubs.go \
-  %reldir%/testing.go
+  %reldir%/testing.go \
+  %reldir%/jwk.go
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm
index b575a77..a690088 100644
--- a/src/scm/webid-oidc/errors.scm
+++ b/src/scm/webid-oidc/errors.scm
@@ -54,6 +54,36 @@
   (raise-exception
    ((record-constructor &not-a-jwk) value cause)))
 
+(define-public &not-a-public-jwk
+  (make-exception-type
+   '&not-a-public-jwk
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-a-public-jwk value cause)
+  (raise-exception
+   ((record-constructor &not-a-public-jwk) value cause)))
+
+(define-public &not-a-private-jwk
+  (make-exception-type
+   '&not-a-private-jwk
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-a-private-jwk value cause)
+  (raise-exception
+   ((record-constructor &not-a-private-jwk) value cause)))
+
+(define-public &not-a-jwks
+  (make-exception-type
+   '&not-a-jwks
+   &external-error
+   '(value cause)))
+
+(define-public (raise-not-a-jwks value cause)
+  (raise-exception
+   ((record-constructor &not-a-jwks) value cause)))
+
 (define-public &unsupported-alg
   (make-exception-type
    '&unsupported-alg
@@ -92,6 +122,27 @@
                          (get 'value) cause)
                  (format #f (G_ "the value ~s does not identify a JWK")
                          (get 'value)))))
+          ((&not-a-public-jwk)
+           (let ((cause (get 'cause)))
+             (if cause
+                 (format #f (G_ "the value ~s does not identify a public JWK (because ~a)")
+                         (get 'value) cause)
+                 (format #f (G_ "the value ~s does not identify a public JWK")
+                         (get 'value)))))
+          ((&not-a-private-jwk)
+           (let ((cause (get 'cause)))
+             (if cause
+                 (format #f (G_ "the value ~s does not identify a private JWK (because ~a)")
+                         (get 'value) cause)
+                 (format #f (G_ "the value ~s does not identify a private JWK")
+                         (get 'value)))))
+          ((&not-a-jwks)
+           (let ((cause (get 'cause)))
+             (if cause
+                 (format #f (G_ "the value ~s does not identify a JWKS (because ~a)")
+                         (get 'value) cause)
+                 (format #f (G_ "the value ~s does not identify a JWKS")
+                         (get 'value)))))
           ((&unsupported-alg)
            (format #f (G_ "the value ~s does not identify a hash algorithm")
                    (get 'value)))
diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
new file mode 100644
index 0000000..1ad54ad
--- /dev/null
+++ b/src/scm/webid-oidc/jwk.scm
@@ -0,0 +1,112 @@
+(define-module (webid-oidc jwk)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (webid-oidc errors)
+  #:use-module (json))
+
+(define-public (the-jwk x)
+  (with-exception-handler
+      (lambda (cause)
+        (raise-not-a-jwk x cause))
+    (lambda ()
+      (let ((kty (stubs:kty x)))
+        (unless (or (eq? kty 'EC) (eq? kty 'RSA))
+          (throw 'really-not-a-jwk))
+        x))))
+
+(define-public (jwk? x)
+  (false-if-exception
+   (and (the-jwk x) #t)))
+
+(define-public (kty x)
+  (stubs:kty (the-jwk x)))
+
+(define-public (the-public-jwk x)
+  (with-exception-handler
+      (lambda (cause)
+        (raise-not-a-public-jwk x cause))
+    (lambda ()
+      (let ((key (the-jwk x)))
+        (let ((crv (assq-ref key 'crv))
+              (x (assq-ref key 'x))
+              (y (assq-ref key 'y))
+              (n (assq-ref key 'n))
+              (e (assq-ref key 'e)))
+          (let ((ec-part `((crv . ,crv)
+                           (x . ,x)
+                           (y . ,y)))
+                (rsa-part `((n . ,n)
+                            (e . ,e))))
+            (case (stubs:kty ec-part)
+              ((EC) ec-part)
+              ((RSA) rsa-part))))))))
+
+(define-public (jwk-public? key)
+  (false-if-exception
+   (and (the-public-jwk x) #t)))
+
+(define-public (strip key)
+  (with-exception-handler
+      (lambda (cause)
+        (raise-not-a-public-jwk key cause))
+    (lambda ()
+      (stubs:strip-key key))))
+
+(define-public (jkt x)
+  (stubs:jkt (the-public-jwk x)))
+
+(define-public (make-rsa-public-key n e)
+  (the-public-jwk
+   `((n . ,n)
+     (e . ,e))))
+
+(define-public (make-rsa-private-key d p q dp dq qi)
+  (the-jwk
+   `((d . ,d)
+     (p . ,p)
+     (q . ,q)
+     (dp . ,dp)
+     (dq . ,dq)
+     (qi . ,qi))))
+
+(define-public (make-ec-point crv x y)
+  (if (symbol? crv)
+      (make-ec-point (symbol->string crv) x y)
+      (the-public-jwk
+       `((crv . ,crv)
+         (x . ,x)
+         (y . ,y)))))
+
+(define-public (make-ec-scalar crv d)
+  (if (symbol? crv)
+      (make-ec-scalar (symbol->string crv) d)
+      (the-jwk
+       `((crv . ,crv)
+         (d . ,d)))))
+
+(define-public generate-key stubs:generate-key)
+
+(define (the-public-keys keys)
+  (map the-public-key keys))
+
+(define-public (the-jwks jwks)
+  (let ((keys (vector->list (assoc-ref jwks 'keys))))
+    (unless keys
+      (raise-not-a-jwks jwks #f))
+    (with-exception-handler
+        (lambda (cause)
+          (raise-not-a-jwks jwks cause))
+      (lambda ()
+        `((keys . ,(list->vector (the-public-keys keys))))))))
+
+(define-public (jwks? jwks)
+  (false-if-exception
+   (and (the-jwks jwks) #t)))
+
+(define-public (make-jwks keys)
+  (if (vector? keys)
+      (make-jwks (vector->list keys))
+      (let ((pubs (list->vector (map strip keys))))
+        (the-jwks `((keys . ,pubs))))))
+
+(define-public (jwks-keys jwks)
+  (vector->list (assq-ref (the-jwks jwks) keys)))