Provide a higher-level API for JWKs and JWKSs

3 files changed, 167 insertions, 2 deletions

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)))