diff options
Diffstat (limited to 'src/scm/webid-oidc')
-rw-r--r-- | src/scm/webid-oidc/Makefile.am | 6 | ||||
-rw-r--r-- | src/scm/webid-oidc/errors.scm | 51 | ||||
-rw-r--r-- | src/scm/webid-oidc/jwk.scm | 112 |
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 ¬-a-jwk) value cause))) +(define-public ¬-a-public-jwk + (make-exception-type + '¬-a-public-jwk + &external-error + '(value cause))) + +(define-public (raise-not-a-public-jwk value cause) + (raise-exception + ((record-constructor ¬-a-public-jwk) value cause))) + +(define-public ¬-a-private-jwk + (make-exception-type + '¬-a-private-jwk + &external-error + '(value cause))) + +(define-public (raise-not-a-private-jwk value cause) + (raise-exception + ((record-constructor ¬-a-private-jwk) value cause))) + +(define-public ¬-a-jwks + (make-exception-type + '¬-a-jwks + &external-error + '(value cause))) + +(define-public (raise-not-a-jwks value cause) + (raise-exception + ((record-constructor ¬-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))))) + ((¬-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))))) + ((¬-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))))) + ((¬-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))) |