From bf046889ea0a24d897175621347d4e571fb2609e Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Sat, 29 Jan 2022 12:55:08 +0100 Subject: Generate an RSA key pair --- disfluid/build/bootstrap.scm | 3 +- disfluid/jwk.scm | 186 +++++++++++++++++++++++++++++++++++++++++++ guix.scm | 1 + po/disfluid.pot | 26 +++++- po/fr.po | 26 +++++- tests/jwk.scm | 58 ++++++++++++++ 6 files changed, 291 insertions(+), 9 deletions(-) create mode 100644 disfluid/jwk.scm create mode 100644 tests/jwk.scm diff --git a/disfluid/build/bootstrap.scm b/disfluid/build/bootstrap.scm index b4ee375..33fbb1c 100644 --- a/disfluid/build/bootstrap.scm +++ b/disfluid/build/bootstrap.scm @@ -53,7 +53,8 @@ (description "This package provides a Solid implementation, client and server.") (home-page "https://disfluid.planete-kraus.eu") (license gpl3+) - (dependencies `()) + (dependencies `(("guile-gcrypt" (gcrypt pk-crypto) ,guile-gcrypt) + ("guile-json" (json) ,guile-json-4))) (files (libraries ((scheme-file "disfluid") (directory "disfluid" ()))) 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->json + jwk-public->json + + jkt + + &invalid-key-parameters)) + +(define-exception-type + &invalid-key-parameters + &error + make-invalid-key-parameters + invalid-key-parameters?) + +(define-class () + kid + key) + +(define-method (initialize (key ) 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 )) + (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 )) + (slot-ref key 'kid)) + +(define-method (public-rsa-parameter (key ) 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 )) + (public-rsa-parameter key 'n)) + +(define-method (e (key )) + (public-rsa-parameter key 'e)) + +(define-method (private-rsa-parameters (key )) + (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 )) + (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 )) + ;; 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"))))) diff --git a/guix.scm b/guix.scm index 1034b68..1246039 100644 --- a/guix.scm +++ b/guix.scm @@ -7,6 +7,7 @@ (gnu packages compression) (gnu packages emacs) (gnu packages gettext) + (gnu packages gnupg) (gnu packages guile) (gnu packages guile-xyz) (gnu packages version-control)) diff --git a/po/disfluid.pot b/po/disfluid.pot index 441b9d8..f2ac7ad 100644 --- a/po/disfluid.pot +++ b/po/disfluid.pot @@ -6,9 +6,9 @@ #, fuzzy msgid "" msgstr "" -"Project-Id-Version: disfluid SNAPSHOT\n" +"Project-Id-Version: disfluid 0.0.2-1-g470ac86\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2022-01-15 22:58+0100\n" +"POT-Creation-Date: 2022-01-29 16:42+0100\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" @@ -17,12 +17,12 @@ msgstr "" "Content-Type: text/plain; charset=CHARSET\n" "Content-Transfer-Encoding: 8bit\n" -#: disfluid/build/bootstrap.scm:187 +#: disfluid/build/bootstrap.scm:190 #, scheme-format msgid "Warning: ~a: ~a~%" msgstr "" -#: disfluid/build/bootstrap.scm:223 +#: disfluid/build/bootstrap.scm:227 msgid "Cannot find guile, using /usr/local/bin/guile." msgstr "" @@ -75,3 +75,21 @@ msgstr "" #: disfluid/build/post-commit-hook.scm:112 msgid "cannot clean up the last commit files" msgstr "" + +#: disfluid/jwk.scm:45 +#, scheme-format +msgid "the value of e could not be decoded from base64-url (~s)" +msgstr "" + +#: disfluid/jwk.scm:69 +#, scheme-format +msgid "a key with n-size=~s (e=~s) could not be built" +msgstr "" + +#: disfluid/jwk.scm:81 +msgid "the key size is too small" +msgstr "" + +#: disfluid/jwk.scm:97 +msgid "the key initialization requires at least #:n-size to generate it" +msgstr "" diff --git a/po/fr.po b/po/fr.po index 3e1e180..7347649 100644 --- a/po/fr.po +++ b/po/fr.po @@ -8,8 +8,8 @@ msgid "" msgstr "" "Project-Id-Version: disfluid SNAPSHOT\n" "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n" -"POT-Creation-Date: 2022-01-15 22:58+0100\n" -"PO-Revision-Date: 2022-01-16 16:53+0100\n" +"POT-Creation-Date: 2022-01-29 16:42+0100\n" +"PO-Revision-Date: 2022-01-29 16:44+0100\n" "Last-Translator: Vivien \n" "Language-Team: French \n" "Language: fr\n" @@ -18,12 +18,12 @@ msgstr "" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=2; plural=(n > 1);\n" -#: disfluid/build/bootstrap.scm:187 +#: disfluid/build/bootstrap.scm:190 #, scheme-format msgid "Warning: ~a: ~a~%" msgstr "Attention : ~a : ~a~%" -#: disfluid/build/bootstrap.scm:223 +#: disfluid/build/bootstrap.scm:227 msgid "Cannot find guile, using /usr/local/bin/guile." msgstr "Impossible de trouver guile, j’utilise /usr/local/bin/guile." @@ -76,3 +76,21 @@ msgstr "impossible de pousser la nouvelle version" #: disfluid/build/post-commit-hook.scm:112 msgid "cannot clean up the last commit files" msgstr "impossible de nettoyer les fichiers du dernier commit" + +#: disfluid/jwk.scm:45 +#, scheme-format +msgid "the value of e could not be decoded from base64-url (~s)" +msgstr "la valeur de e n’a pas pu être décodée en base64-url (~s)" + +#: disfluid/jwk.scm:69 +#, scheme-format +msgid "a key with n-size=~s (e=~s) could not be built" +msgstr "impossible de construire une clé avec n-size = ~s (e = ~s)" + +#: disfluid/jwk.scm:81 +msgid "the key size is too small" +msgstr "la taille de la clé est trop petite" + +#: disfluid/jwk.scm:97 +msgid "the key initialization requires at least #:n-size to generate it" +msgstr "l’initialisation de la clé requiert au moins #:n-size pour la générer" diff --git a/tests/jwk.scm b/tests/jwk.scm new file mode 100644 index 0000000..6750456 --- /dev/null +++ b/tests/jwk.scm @@ -0,0 +1,58 @@ +(define-module (tests jwk) + #:use-module (disfluid jwk) + #:use-module (oop goops) + #:use-module (srfi srfi-64) + #:declarative? #t) + +(test-group "Generating a key: RSA" + (let* ((key (make #:n-size 2048)) + (public (jwk-public->json key)) + (pair (jwk->json key))) + (test-group "Generating an RSA key: public and private parts" + (test-equal "RSA" (assq-ref pair 'kty)) + (test-equal (jkt key) (assq-ref pair 'kid)) + (test-assert (not (string-suffix? "=" (assq-ref pair 'kid)))) + (test-assert (string? (assq-ref pair 'n))) + (test-assert (string? (assq-ref pair 'e))) + (test-assert (string? (assq-ref pair 'd))) + (test-assert (string? (assq-ref pair 'p))) + (test-assert (string? (assq-ref pair 'q))) + ;; Fixme: find a way to compute dp and dq + (test-assert (not (assq-ref pair 'dp))) + (test-assert (not (assq-ref pair 'dq))) + (test-assert (string? (assq-ref pair 'qi)))) + (test-group "Generating an RSA key: public part" + (test-equal "RSA" (assq-ref public 'kty)) + (test-assert (string? (assq-ref public 'kid))) + (test-assert (string? (assq-ref public 'n))) + (test-assert (string? (assq-ref public 'e))) + (test-assert (not (assq-ref public 'd))) + (test-assert (not (assq-ref public 'p))) + (test-assert (not (assq-ref public 'q))) + (test-assert (not (assq-ref public 'dp))) + (test-assert (not (assq-ref public 'dq))) + (test-assert (not (assq-ref public 'qi)))) + (test-group "Generating a key: RSA with e=0" + (let ((key (jwk-public->json (make #:n-size 2048 #:e 0)))) + (test-equal "RSA" (assq-ref key 'kty)) + (test-assert (not (equal? (assq-ref key 'e) "AA"))))) + (test-group "Generating a key: RSA with e=1" + (let ((key (jwk-public->json (make #:n-size 2048 #:e 1)))) + (test-equal "RSA" (assq-ref key 'kty)) + (test-assert (not (equal? (assq-ref key 'e) "AQ"))))) + (test-group "Generating a key: RSA with e=3" + (let ((key (jwk-public->json (make #:n-size 2048 #:e 3)))) + (test-equal "RSA" (assq-ref key 'kty)) + (test-equal "Aw" (assq-ref key 'e)))) + (test-group "Generating a key: RSA with e=AQAB" + (let ((key (jwk-public->json (make #:n-size 2048 #:e "AQAB")))) + (test-equal "RSA" (assq-ref key 'kty)) + (test-equal "AQAB" (assq-ref key 'e)))))) + +(test-group "Generating a key with incorrect parameters: RSA" + (test-error &invalid-key-parameters (make #:n-size 8)) + (test-error &invalid-key-parameters (make #:n-size 16)) + (test-error &invalid-key-parameters (make #:n-size 64)) + (test-error &invalid-key-parameters (make #:n-size "garbage")) + (test-error &invalid-key-parameters (make #:n-size 2048 #:e "garbage")) + (test-error &invalid-key-parameters (make ))) -- cgit v1.2.3