Generate an RSA key pair0.0.3

6 files changed, 291 insertions, 9 deletions

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>
+            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")))))
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 <EMAIL@ADDRESS>\n"
 "Language-Team: LANGUAGE <LL@li.org>\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 <vivien@planete-kraus.eu>\n"
 "Language-Team: French <traduc@traduc.org>\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 <jwk> #: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 <jwk> #: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 <jwk> #: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 <jwk> #: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 <jwk> #: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 <jwk> #:n-size 8))
+  (test-error &invalid-key-parameters (make <jwk> #:n-size 16))
+  (test-error &invalid-key-parameters (make <jwk> #:n-size 64))
+  (test-error &invalid-key-parameters (make <jwk> #:n-size "garbage"))
+  (test-error &invalid-key-parameters (make <jwk> #:n-size 2048 #:e "garbage"))
+  (test-error &invalid-key-parameters (make <jwk>)))