1 files changed, 38 insertions, 7 deletions

diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
index e0308cb..f06818d 100644
--- a/src/scm/webid-oidc/jwk.scm
+++ b/src/scm/webid-oidc/jwk.scm
@@ -31,7 +31,7 @@
   #:declarative? #t
   #:export
   (
-   <private-key>
+   <private-key> alg
    <public-key>
    <key-pair> public-key private-key
    <rsa-key-pair>
@@ -72,7 +72,8 @@
   make-not-a-jwks
   not-a-jwks?)
 
-(define-class <private-key> ())
+(define-class <private-key> ()
+  (alg #:init-keyword #:alg #:accessor alg))
 
 (define-class <public-key> ())
 
@@ -154,6 +155,12 @@
 
 (define-method (initialize (key <rsa-private-key>) initargs)
   (next-method)
+  (let-keywords
+   initargs #t
+   ((alg #f))
+   (when (string? alg)
+     (set! alg (string->symbol alg)))
+   (slot-set! key 'alg (or alg 'RS256)))
   (check-key key))
 
 (define-method (initialize (key <rsa-public-key>) initargs)
@@ -166,8 +173,17 @@
 
 (define-method (initialize (key <ec-scalar>) initargs)
   (next-method)
+  (let-keywords
+   initargs #t
+   ((alg #f))
+   (when (string? alg)
+     (set! alg (string->symbol alg)))
+   (slot-set! key 'alg (or alg 'ES256)))
   (check-key key))
 
+(define-method (alg (key <key-pair>))
+  (alg (private-key key)))
+
 (define-method (rsa-d (key <rsa-key-pair>))
   (rsa-d (private-key key)))
 
@@ -216,7 +232,8 @@
        (equal? (rsa-e x) (rsa-e y))))
 
 (define-method (equal? (x <rsa-private-key>) (y <rsa-private-key>))
-  (and (equal? (rsa-d x) (rsa-d y))
+  (and (equal? (alg x) (alg y))
+       (equal? (rsa-d x) (rsa-d y))
        (equal? (rsa-p x) (rsa-p y))
        (equal? (rsa-q x) (rsa-q y))
        (equal? (rsa-dp x) (rsa-dp y))
@@ -228,7 +245,8 @@
        (equal? (ec-y x) (ec-y y))))
 
 (define-method (equal? (x <ec-scalar>) (y <ec-scalar>))
-  (equal? (ec-z x) (ec-z y)))
+  (and (equal? (alg x) (alg y))
+       (equal? (ec-z x) (ec-z y))))
 
 (define (check-and-kty key)
   (with-exception-handler
@@ -273,6 +291,7 @@
 
 (define-method (key->jwk (key <rsa-private-key>))
   `((kty . ,(symbol->string (kty key)))
+    (alg . ,(symbol->string (alg key)))
     (d . ,(rsa-d key))
     (p  . ,(rsa-p key))
     (q . ,(rsa-q key))
@@ -294,6 +313,7 @@
 (define-method (key->jwk (key <ec-scalar>))
   `((crv . ,(symbol->string (ec-crv key)))
     (kty . ,(symbol->string (kty key)))
+    (alg . ,(symbol->string (alg key)))
     (z . ,(ec-z key))))
 
 (define-method (check-key key)
@@ -348,7 +368,8 @@
   key)
 
 (define (jwk->key fields)
-  (let ((kty (stubs:kty fields)))
+  (let ((kty (stubs:kty fields))
+        (alg (assq-ref fields 'alg)))
     (let ((explicit-kty (assq-ref fields 'kty)))
       (when (and kty explicit-kty (not (eq? kty (string->symbol explicit-kty))))
         (raise-exception
@@ -371,7 +392,14 @@
                      (make <rsa-public-key> #:n n #:e e)))
                (private
                 (and d p q dp dq qi
-                     (make <rsa-private-key> #:d d #:p p #:q q #:dp dp #:dq dq #:qi qi))))
+                     (make <rsa-private-key>
+                       #:alg (and alg (string->symbol alg))
+                       #:d d
+                       #:p p
+                       #:q q
+                       #:dp dp
+                       #:dq dq
+                       #:qi qi))))
            (if (and public private)
                (make <rsa-key-pair> #:public-key public #:private-key private)
                (or public private)))))
@@ -385,7 +413,10 @@
                      (make <ec-point> #:crv crv #:x x #:y y)))
                (private
                 (and z
-                     (make <ec-scalar> #:crv crv #:z z))))
+                     (make <ec-scalar>
+                       #:alg (and alg (string->symbol alg))
+                       #:crv crv
+                       #:z z))))
            (if (and public private)
                (make <ec-key-pair> #:public-key public #:private-key private)
                (or public private)))))