diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-16 23:03:12 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-21 22:25:03 +0200 |
commit | fa486f2e136a898d1b1548ec90757a78c65a0b70 (patch) | |
tree | 7601f939c6859547cc2df38e587c5d9473bae76d /src/scm/webid-oidc/jwk.scm | |
parent | 86bd90866fdc2ab5234c6e09e39bfa972f7fa395 (diff) |
JWK: document it, and use GOOPS
Diffstat (limited to 'src/scm/webid-oidc/jwk.scm')
-rw-r--r-- | src/scm/webid-oidc/jwk.scm | 468 |
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 ¬-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))))))))) |