diff options
Diffstat (limited to 'disfluid/jwk.scm')
| -rw-r--r-- | disfluid/jwk.scm | 186 |
1 files changed, 186 insertions, 0 deletions
diff --git a/disfluid/jwk.scm b/disfluid/jwk.scm new file mode 100644 index 0000000..6791e74 --- /dev/null +++ b/disfluid/jwk.scm @@ -0,0 +1,186 @@ +(define-module (disfluid jwk) + #:use-module (disfluid i18n) + #:use-module (json) + #:use-module (gcrypt pk-crypto) + #:use-module (gcrypt base64) + #:use-module (gcrypt hash) + #:use-module (oop goops) + #:use-module (ice-9 optargs) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 receive) + #:use-module (rnrs bytevectors) + #:declarative? #t + #:export (<jwk> + jwk->json + jwk-public->json + + jkt + + &invalid-key-parameters)) + +(define-exception-type + &invalid-key-parameters + &error + make-invalid-key-parameters + invalid-key-parameters?) + +(define-class <jwk> () + kid + key) + +(define-method (initialize (key <jwk>) initargs) + (let-keywords + initargs #t + ((n-size #f) + (e 0) + (canonical-sexp #f) + (kid #f)) + (when (string? e) + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-invalid-key-parameters) + (make-exception-with-message + (format #f (G_ "the value of e could not be decoded from base64-url (~s)") + e)) + exn))) + (lambda () + (let ((as-data (base64-decode e base64url-alphabet))) + (set! e + (car (bytevector->uint-list + as-data + (endianness little) + (bytevector-length as-data)))))))) + (cond + (canonical-sexp + (slot-set! key 'key canonical-sexp) + (unless kid + (set! kid (jkt key))) + (slot-set! key 'kid kid)) + (n-size + (begin + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + (make-invalid-key-parameters) + (make-exception-with-message + (format #f (G_ "a key with n-size=~s (e=~s) could not be built") + n-size e)) + exn))) + (lambda () + ;; generate-key will abort complaining that n is less than + ;; 16 for n up to 64 (!) To avoid much trouble and unsafe + ;; keys, I’ll just require them to be at least 1024 bits + (unless (>= n-size 1024) + (raise-exception + (make-exception + (make-error) + (make-exception-with-message + (format #f (G_ "the key size is too small")))))) + (let ((parameters + (let ((n-size (number->string n-size)) + (e (number->string e))) + (string->canonical-sexp + (format #f "(genkey (rsa (nbits ~a:~a) (rsa-use-e ~a:~a)))" + (string-length n-size) n-size + (string-length e) e))))) + (let ((key-pair (generate-key parameters))) + (slot-set! key 'key key-pair))))) + (slot-set! key 'kid (jkt key)))) + (else + (raise-exception + (make-exception + (make-invalid-key-parameters) + (make-exception-with-message + (G_ "the key initialization requires at least #:n-size to generate it")))))))) + +(define (encode bv) + (base64-encode bv 0 (bytevector-length bv) #f #t base64url-alphabet)) + +(define-method (jkt (key <jwk>)) + (let* ((required-fields + (let* ((sexp (slot-ref key 'key)) + (public-sexp (or (find-sexp-token sexp 'public-key) + (find-sexp-token sexp 'private-key)))) + (let ((rsa (find-sexp-token public-sexp 'rsa))) + (cond + (rsa + (let ((e (cadr (canonical-sexp->sexp (find-sexp-token rsa 'e)))) + (n (cadr (canonical-sexp->sexp (find-sexp-token rsa 'n))))) + `((kty . "rsa") + (e . ,(encode e)) + (n . ,(encode n))))) + (else + (error "jkt: not implemented for this key type.")))))) + (as-string (scm->json-string required-fields)) + (as-data (string->utf8 as-string)) + (hash (sha256 as-data)) + (encoded (encode hash))) + encoded)) + +(define-method (kid (key <jwk>)) + (slot-ref key 'kid)) + +(define-method (public-rsa-parameter (key <jwk>) name) + (let* ((sexp (slot-ref key 'key)) + (public-sexp (or (find-sexp-token sexp 'public-key) + (find-sexp-token sexp 'private-key))) + (public-rsa (find-sexp-token sexp 'rsa))) + (and public-rsa + (let ((as-data (cadr (canonical-sexp->sexp (find-sexp-token public-rsa name))))) + (encode as-data))))) + +(define-method (n (key <jwk>)) + (public-rsa-parameter key 'n)) + +(define-method (e (key <jwk>)) + (public-rsa-parameter key 'e)) + +(define-method (private-rsa-parameters (key <jwk>)) + (let* ((sexp (slot-ref key 'key)) + (private-sexp (find-sexp-token sexp 'private-key))) + (if private-sexp + (let ((rsa (find-sexp-token private-sexp 'rsa))) + (if rsa + (let ((d (canonical-sexp-nth-data (find-sexp-token rsa 'd) 1)) + ;; What libgcrypt calls p is in fact q and vice + ;; versa + (p (canonical-sexp-nth-data (find-sexp-token rsa 'q) 1)) + (q (canonical-sexp-nth-data (find-sexp-token rsa 'p) 1)) + ;; If this is the case, then u is what we want + ;; as q^{-1} mod p + (qi (canonical-sexp-nth-data (find-sexp-token rsa 'u) 1))) + ;; FIXME: gcrypt does not remember the dP and dQ + ;; parameters. + (values (encode d) (encode p) (encode q) (encode qi))) + (values #f #f #f #f))) + (values #f #f #f #f)))) + +(define-method (jwk-public->json (key <jwk>)) + (let ((kid (slot-ref key 'kid)) + (n (n key)) + (e (e key))) + (cond + ((and n e) + `((kid . ,kid) + (kty . "RSA") + (n . ,n) + (e . ,e))) + (else + (error "unsupported conversion to json"))))) + +(define-method (jwk->json (key <jwk>)) + ;; Make sure to only call this function if it doesn’t have a private + ;; key + (receive (d p q qi) (private-rsa-parameters key) + (cond + ((and d p q qi) + `(,@(jwk-public->json key) + (d . ,d) + (p . ,p) + (q . ,q) + (qi . ,qi))) + (else + (error "unsupported conversion to json"))))) |