JWK: document it, and use GOOPS

1 files changed, 318 insertions, 150 deletions

diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
index e4f2119..7675d04 100644
--- a/src/scm/webid-oidc/jwk.scm
+++ b/src/scm/webid-oidc/jwk.scm
@@ -25,26 +25,28 @@
   #:use-module (web response)
   #:use-module (web client)
   #:use-module (rnrs bytevectors)
+  #:use-module (oop goops)
   #:declarative? #t
   #:export
   (
-   the-jwk
-   jwk?
+   <private-key>
+   <public-key>
+   <key-pair> public-key private-key
+   <rsa-key-pair>
+   <ec-key-pair>
+   <rsa-private-key> rsa-d rsa-p rsa-q rsa-dp rsa-dq rsa-qi
+   <rsa-public-key> rsa-n rsa-e
+   <ec-scalar> ec-crv ec-x ec-y
+   <ec-point> ec-z
+   <jwks> keys
+
+   check-key
+   key->jwk
+   jwk->key
    kty
-   the-public-jwk
-   jwk-public?
-   strip
    jkt
-   make-rsa-public-key
-   make-rsa-private-key
-   make-ec-point
-   make-ec-scalar
    generate-key
-   the-jwks
-   jwks?
-   make-jwks
-   jwks-keys
-   serve-jwks
+   serve
    get-jwks
 
    &not-a-jwk
@@ -68,7 +70,165 @@
   make-not-a-jwks
   not-a-jwks?)
 
-(define (the-jwk x)
+(define-class <private-key> ())
+
+(define-class <public-key> ())
+
+(define-class <key-pair> ()
+  (public-key #:init-keyword #:public-key #:accessor public-key)
+  (private-key #:init-keyword #:private-key #:accessor private-key))
+
+(define-class <rsa-key-pair> (<key-pair>))
+
+(define-class <ec-key-pair> (<key-pair>)
+  (crv #:init-keyword #:crv #:accessor ec-crv))
+
+(define-class <rsa-private-key> (<private-key>)
+  (d #:init-keyword #:d #:accessor rsa-d)
+  (p #:init-keyword #:p #:accessor rsa-p)
+  (q #:init-keyword #:q #:accessor rsa-q)
+  (dp #:init-keyword #:dp #:accessor rsa-dp)
+  (dq #:init-keyword #:dq #:accessor rsa-dq)
+  (qi #:init-keyword #:qi #:accessor rsa-qi))
+
+(define-class <rsa-public-key> (<public-key>)
+  (n #:init-keyword #:n #:accessor rsa-n)
+  (e #:init-keyword #:e #:accessor rsa-e))
+
+(define-class <ec-scalar> (<private-key>)
+  (crv #:init-keyword #:crv #:accessor ec-crv)
+  (z #:init-keyword #:z #:accessor ec-z))
+
+(define-class <ec-point> (<public-key>)
+  (crv #:init-keyword #:crv #:accessor ec-crv)
+  (x #:init-keyword #:x #:accessor ec-x)
+  (y #:init-keyword #:y #:accessor ec-y))
+
+(define-method (initialize-key-pair (key <key-pair>) (public <rsa-public-key>) (private <rsa-private-key>))
+  (set! (public-key key) public)
+  (set! (private-key key) private))
+
+(define-method (initialize-key-pair (key <key-pair>) (public <ec-point>) (private <ec-scalar>))
+  (set! (public-key key) public)
+  (set! (private-key key) private))
+
+(define-method (initialize (key <key-pair>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((public-key #f)
+    (private-key #f))
+   (initialize-key-pair key public-key private-key))
+  (check-key key))
+
+(define-method (initialize-rsa-key-pair (key <rsa-key-pair>) (public <rsa-public-key>) (private <rsa-private-key>))
+  #t)
+
+(define-method (initialize (key <rsa-key-pair>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((public-key #f)
+    (private-key #f))
+   (initialize-rsa-key-pair key public-key private-key))
+  (check-key key))
+
+(define-method (initialize-ec-key-pair (key <ec-key-pair>) (public <ec-point>) (private <ec-scalar>))
+  (unless (eq? (ec-crv public) (ec-crv private))
+    (raise-exception
+     (make-exception
+      (make-not-a-jwk)
+      (make-exception-with-message (G_ "the point and scalar are not on the same curve")))))
+  (set! (ec-crv key) (ec-crv public)))
+
+(define-method (initialize (key <ec-key-pair>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((public-key #f)
+    (private-key #f))
+   (initialize-ec-key-pair key public-key private-key)
+   (check-key key)))
+
+(define-method (initialize (key <rsa-private-key>) initargs)
+  (next-method)
+  (check-key key))
+
+(define-method (initialize (key <rsa-public-key>) initargs)
+  (next-method)
+  (check-key key))
+
+(define-method (initialize (key <ec-point>) initargs)
+  (next-method)
+  (check-key key))
+
+(define-method (initialize (key <ec-scalar>) initargs)
+  (next-method)
+  (check-key key))
+
+(define-method (rsa-d (key <rsa-key-pair>))
+  (rsa-d (private-key key)))
+
+(define-method (rsa-p (key <rsa-key-pair>))
+  (rsa-p (private-key key)))
+
+(define-method (rsa-q (key <rsa-key-pair>))
+  (rsa-q (private-key key)))
+
+(define-method (rsa-dp (key <rsa-key-pair>))
+  (rsa-dp (private-key key)))
+
+(define-method (rsa-dq (key <rsa-key-pair>))
+  (rsa-dq (private-key key)))
+
+(define-method (rsa-qi (key <rsa-key-pair>))
+  (rsa-qi (private-key key)))
+
+(define-method (rsa-n (key <rsa-key-pair>))
+  (rsa-n (public-key key)))
+
+(define-method (rsa-e (key <rsa-key-pair>))
+  (rsa-e (public-key key)))
+
+(define-method (ec-x (key <ec-key-pair>))
+  (ec-x (public-key key)))
+
+(define-method (ec-y (key <ec-key-pair>))
+  (ec-y (public-key key)))
+
+(define-method (ec-z (key <ec-key-pair>))
+  (ec-z (private-key key)))
+
+(define-method (equal? (x <key-pair>) (y <key-pair>))
+  (and (equal? (public-key x) (public-key y))
+       (equal? (private-key x) (private-key y))))
+
+(define-method (equal? (x <public-key>) (y <public-key>))
+  #f)
+
+(define-method (equal? (x <private-key>) (y <private-key>))
+  #f)
+
+(define-method (equal? (x <rsa-public-key>) (y <rsa-public-key>))
+  (and (equal? (rsa-n x) (rsa-n y))
+       (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))
+       (equal? (rsa-p x) (rsa-p y))
+       (equal? (rsa-q x) (rsa-q y))
+       (equal? (rsa-dp x) (rsa-dp y))
+       (equal? (rsa-dq x) (rsa-dq y))
+       (equal? (rsa-qi x) (rsa-qi y))))
+
+(define-method (equal? (x <ec-point>) (y <ec-point>))
+  (and (equal? (ec-x x) (ec-x y))
+       (equal? (ec-y x) (ec-y y))))
+
+(define-method (equal? (x <ec-scalar>) (y <ec-scalar>))
+  (equal? (ec-z x) (ec-z y)))
+
+(define (check-and-kty key)
   (with-exception-handler
       (lambda (error)
         (let ((final-message
@@ -82,150 +242,156 @@
             (make-exception-with-message final-message)
             error))))
     (lambda ()
-      (let ((kty (stubs:kty x)))
-        (unless (or (eq? kty 'EC) (eq? kty 'RSA))
-          (fail (format #f (G_ "unknown key type ~s")
-                        kty)))
-        x))))
+      (let ((kty (stubs:kty (key->jwk key))))
+        (unless kty
+          (fail (G_ "cannot compute the key type")))
+        kty))))
 
-(define (jwk? x)
-  (false-if-exception
-   (and (the-jwk x) #t)))
+(define-method (key->jwk (key <key-pair>))
+  (append (key->jwk (public-key key))
+          (key->jwk (private-key key))))
 
-(define (kty x)
-  (stubs:kty (the-jwk x)))
+(define-method (key->jwk (key <rsa-private-key>))
+  `((d . ,(rsa-d key))
+    (p  . ,(rsa-p key))
+    (q . ,(rsa-q key))
+    (dp . ,(rsa-dp key))
+    (dq . ,(rsa-dq key))
+    (qi . ,(rsa-qi key))))
 
-(define (the-public-jwk x)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "the public JWK is invalid: ~a")
-                           (exception-message error))
-                   (format #f (G_ "the public JWK is invalid")))))
-          (raise-exception
-           (make-exception
-            (make-not-a-jwk)
-            (make-exception-with-message final-message)
-            error))))
-    (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 key)
-              ((EC) ec-part)
-              ((RSA) rsa-part))))))))
-
-(define (jwk-public? key)
-  (false-if-exception
-   (and (the-public-jwk key) #t)))
-
-(define (strip key)
-  (with-exception-handler
-      (lambda (error)
-        (let ((final-message
-               (if (exception-with-message? error)
-                   (format #f (G_ "cannot extract the public part of the key: ~a")
-                           (exception-message error))
-                   (format #f (G_ "cannot extract the public part of the key")))))
-          (raise-exception
-           (make-exception
-            (make-not-a-jwk)
-            (make-exception-with-message final-message)
-            error))))
-    (lambda ()
-      (stubs:strip-key key))))
+(define-method (key->jwk (key <rsa-public-key>))
+  `((n . ,(rsa-n key))
+    (e . ,(rsa-e key))))
+
+(define-method (key->jwk (key <ec-point>))
+  `((crv . ,(symbol->string (ec-crv key)))
+    (x . ,(ec-x key))
+    (y . ,(ec-y key))))
+
+(define-method (key->jwk (key <ec-scalar>))
+  `((crv . ,(symbol->string (ec-crv key)))
+    (z . ,(ec-z key))))
+
+(define-method (check-key key)
+  (check-and-kty (key->jwk key)))
+
+(define (check-rsa-key key)
+  (unless (eq? (check-and-kty key) 'RSA)
+    (raise-exception
+     (make-exception
+      (make-not-a-jwk)
+      (make-exception-with-message
+       (format #f (G_ "it is built as an RSA key or key pair, but it is not")))))))
+
+(define (check-ec-key key)
+  (unless (eq? (check-and-kty key) 'EC)
+    (raise-exception
+     (make-exception
+      (make-not-a-jwk)
+      (make-exception-with-message
+       (format #f (G_ "it is built as an elliptic curve key or key pair, but it is not")))))))
+
+(define-method (check-key (key <rsa-key-pair>))
+  (check-rsa-key key))
+
+(define-method (check-key (key <rsa-public-key>))
+  (check-rsa-key key))
+
+(define-method (check-key (key <rsa-private-key>))
+  (check-rsa-key key))
+
+(define-method (check-key (key <ec-key-pair>))
+  (check-ec-key key))
+
+(define-method (check-key (key <ec-point>))
+  (check-ec-key key))
+
+(define-method (check-key (key <ec-scalar>))
+  (check-ec-key key))
+
+(define-method (kty (key <rsa-key-pair>)) 'RSA)
+(define-method (kty (key <rsa-public-key>)) 'RSA)
+(define-method (kty (key <rsa-private-key>)) 'RSA)
+
+(define-method (kty (key <ec-key-pair>)) 'EC)
+(define-method (kty (key <ec-point>)) 'EC)
+(define-method (kty (key <ec-scalar>)) 'EC)
+
+(define-method (public-key (key <public-key>))
+  key)
+
+(define-method (private-key (key <private-key>))
+  key)
+
+(define (jwk->key fields)
+  (let ((kty (stubs:kty fields)))
+    (case kty
+      ((RSA)
+       (let ((d (assq-ref fields 'd))
+             (p (assq-ref fields 'p))
+             (q (assq-ref fields 'q))
+             (dp (assq-ref fields 'dp))
+             (dq (assq-ref fields 'dq))
+             (qi (assq-ref fields 'qi))
+             (n (assq-ref fields 'n))
+             (e (assq-ref fields 'e)))
+         (let ((public
+                (and n e
+                     (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))))
+           (if (and public private)
+               (make <rsa-key-pair> #:public-key public #:private-key private)
+               (or public private)))))
+      ((EC)
+       (let ((crv (string->symbol (assq-ref fields 'crv)))
+             (x (assq-ref fields 'x))
+             (y (assq-ref fields 'y))
+             (z (assq-ref fields 'z)))
+         (let ((public
+                (and x y
+                     (make <ec-point> #:crv crv #:x x #:y y)))
+               (private
+                (and z
+                     (make <ec-scalar> #:crv crv #:z z))))
+           (if (and public private)
+               (make <ec-key-pair> #:public-key public #:private-key private)
+               (or public private)))))
+      (else
+       (raise-exception
+        (make-exception
+         (make-not-a-jwk)
+         (make-exception-with-message (G_ "this is neither a RSA key nor an elliptic curve key"))))))))
 
 (define (jkt x)
-  (stubs:jkt (the-public-jwk x)))
-
-(define (make-rsa-public-key n e)
-  (the-public-jwk
-   `((n . ,n)
-     (e . ,e))))
-
-(define (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 (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 (make-ec-scalar crv d)
-  (if (symbol? crv)
-      (make-ec-scalar (symbol->string crv) d)
-      (the-jwk
-       `((crv . ,crv)
-         (d . ,d)))))
-
-(define generate-key stubs:generate-key)
-
-(define (the-public-keys keys)
-  (map the-public-jwk keys))
-
-(define (the-jwks jwks)
-  (let ((keys (vector->list (assoc-ref jwks 'keys))))
-    (unless keys
-      (let ((final-message
-             (format #f (G_ "the JWKS is invalid, because it does not have keys"))))
-        (raise-exception
-         (make-exception
-          (make-not-a-jwks)
-          (make-exception-with-message final-message)))))
-    (with-exception-handler
-        (lambda (error)
-          (let ((final-message
-                 (if (exception-with-message? error)
-                     (format #f (G_ "the JWKS is invalid: ~a")
-                             (exception-message error))
-                     (format #f (G_ "the JWKS is invalid")))))
-            (raise-exception
-             (make-exception
-              (make-not-a-jwks)
-              (make-exception-with-message final-message)
-              error))))
-      (lambda ()
-        `((keys . ,(list->vector (the-public-keys keys))))))))
+  (stubs:jkt (key->jwk x)))
 
-(define (jwks? jwks)
-  (false-if-exception
-   (and (the-jwks jwks) #t)))
+(define (generate-key . args)
+  (jwk->key (apply stubs:generate-key args)))
 
-(define (make-jwks keys)
-  (if (vector? keys)
-      (make-jwks (vector->list keys))
-      (let ((pubs (list->vector (map strip keys))))
-        (the-jwks `((keys . ,pubs))))))
+(define-class <jwks> ()
+  (keys #:init-keyword #:keys #:accessor keys))
 
-(define (jwks-keys jwks)
-  (vector->list (assq-ref (the-jwks jwks) 'keys)))
+(define-method (initialize (jwks <jwks>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((keys '()))
+   (slot-set! jwks 'keys (map public-key keys))))
 
-(define (serve-jwks expiration-date jwks)
-  (values (build-response
-           #:headers `((content-type . (application/json))
-                       (expires . ,expiration-date)))
-          (stubs:scm->json-string (the-jwks jwks))))
+(define-method (serve (jwks <jwks>) expiration-date)
+  (values
+   (build-response
+    #:headers `((content-type . (application/json))
+                (expires . ,expiration-date)))
+   (stubs:scm->json-string
+    `((keys
+       . ,(list->vector
+           (map key->jwk (keys jwks))))))))
 
-(define* (get-jwks uri #:key (http-get http-get))
-  (receive (response response-body) (http-get uri)
+(define* (get-jwks uri #:key (http-request http-request))
+  (receive (response response-body) (http-request uri)
     (with-exception-handler
         (lambda (error)
           (raise-exception
@@ -252,4 +418,6 @@
             (fail (format #f (G_ "invalid content-type: ~s") content-type)))
           (unless (string? response-body)
             (set! response-body (utf8->string response-body)))
-          (the-jwks (stubs:json-string->scm response-body)))))))
+          (let ((data (stubs:json-string->scm response-body)))
+            (let ((keys (vector->list (assq-ref data 'keys))))
+              (make <jwks> #:keys (map jwk->key keys)))))))))