JWK: add an explicit value for kty in the JSON representation

1 files changed, 35 insertions, 4 deletions

diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
index 7675d04..e0308cb 100644
--- a/src/scm/webid-oidc/jwk.scm
+++ b/src/scm/webid-oidc/jwk.scm
@@ -21,6 +21,8 @@
   #:use-module (ice-9 receive)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 hash-table)
+  #:use-module (ice-9 match)
   #:use-module (srfi srfi-19)
   #:use-module (web response)
   #:use-module (web client)
@@ -248,11 +250,30 @@
         kty))))
 
 (define-method (key->jwk (key <key-pair>))
-  (append (key->jwk (public-key key))
-          (key->jwk (private-key key))))
+  ;; kty and crv fields are present in both the public and private
+  ;; key, but they must not be duplicated, and we want to keep all
+  ;; fields in order.
+  (let ((with-duplicates
+         (append (key->jwk (public-key key))
+                 (key->jwk (private-key key)))))
+  (let ((lookup
+         (alist->hash-table with-duplicates)))
+    (let keep-unique-in-order ((order (map car with-duplicates))
+                               (constructed '()))
+      (match order
+        (()
+         (reverse constructed))
+        ((hd tl ...)
+         (let ((found (hash-ref lookup hd)))
+           (when found
+             (hash-remove! lookup hd))
+           (if found
+               (keep-unique-in-order tl `((,hd . ,found) ,@constructed))
+               (keep-unique-in-order tl constructed)))))))))
 
 (define-method (key->jwk (key <rsa-private-key>))
-  `((d . ,(rsa-d key))
+  `((kty . ,(symbol->string (kty key)))
+    (d . ,(rsa-d key))
     (p  . ,(rsa-p key))
     (q . ,(rsa-q key))
     (dp . ,(rsa-dp key))
@@ -260,16 +281,19 @@
     (qi . ,(rsa-qi key))))
 
 (define-method (key->jwk (key <rsa-public-key>))
-  `((n . ,(rsa-n key))
+  `((kty . ,(symbol->string (kty key)))
+    (n . ,(rsa-n key))
     (e . ,(rsa-e key))))
 
 (define-method (key->jwk (key <ec-point>))
   `((crv . ,(symbol->string (ec-crv key)))
+    (kty . ,(symbol->string (kty key)))
     (x . ,(ec-x key))
     (y . ,(ec-y key))))
 
 (define-method (key->jwk (key <ec-scalar>))
   `((crv . ,(symbol->string (ec-crv key)))
+    (kty . ,(symbol->string (kty key)))
     (z . ,(ec-z key))))
 
 (define-method (check-key key)
@@ -325,6 +349,13 @@
 
 (define (jwk->key fields)
   (let ((kty (stubs:kty fields)))
+    (let ((explicit-kty (assq-ref fields 'kty)))
+      (when (and kty explicit-kty (not (eq? kty (string->symbol explicit-kty))))
+        (raise-exception
+         (make-exception
+          (make-not-a-jwk)
+          (make-exception-with-message (format #f (G_ "the key advertises a key type of ~s, but actually it is ~s")
+                                               explicit-kty kty))))))
     (case kty
       ((RSA)
        (let ((d (assq-ref fields 'd))