Generate an RSA key pair0.0.4

7 files changed, 401 insertions, 18 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/doc/disfluid.texi b/doc/disfluid.texi
index 9c152f6..862280d 100644
--- a/doc/disfluid.texi
+++ b/doc/disfluid.texi
@@ -4,7 +4,7 @@
 @c %**start of header
 @setfilename disfluid.info
 @documentencoding UTF-8
-@settitle Disfluid Reference Manual
+@settitle Demanding Interoperability to Strengthen the Free (Libre) Web: Introducing Disfluid
 @c %**end of header
 
 @include version.texi
@@ -12,21 +12,23 @@
 @copying
 Copyright @copyright{} 2022 Vivien Kraus
 
+@quotation
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
 any later version published by the Free Software Foundation; with no
 Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.  A
 copy of the license is included in the section entitled ``GNU Free
 Documentation License''.
+@end quotation
 @end copying
 
 @dircategory The Algorithmic Language Scheme
 @direntry
-* Disfluid: (disfluid).   
+* Disfluid: (disfluid)Decentralized Authentication on the Web
 @end direntry
 
 @titlepage
-@title The Disfluid Manual
+@title Interoperability to Strengthen the Free (Libre) Web: Introducing Disfluid
 @author Vivien Kraus
 
 @page
@@ -43,18 +45,117 @@ Edition @value{EDITION} @*
 @node Top
 @top Disfluid
 
-This document describes Disfluid version @value{VERSION}.
+Disfluid is an independent implementation of a web stack focusing on
+interoperability. In this implementation, the users control what
+programs run in their computers. They also choose who to trust for
+online data storage and processing, without needing any permission, or
+can self-host their data.
+
+The software is available at
+@url{https://labo.planete-kraus.eu/disfluid.git}.
 
 @menu
-* Introduction::                Why Disfluid?
+* Decentralized Authentication on the Web:: What is Disfluid?
+* Cryptography elements in Disfluid::
 @end menu
 
 @c *********************************************************************
-@node Introduction
-@chapter Introduction
 
-INTRODUCTION HERE
+@node Decentralized Authentication on the Web
+@chapter Decentralized Authentication on the Web
+
+Authentication on the web is currently handled in the following way:
+anyone can install a server that will authenticate users on the
+web. The problem is interoperability. If a client (an application)
+wants to authenticate a user, it has to be approved by the
+authentication server. In other words, if @var{useful-program} wants
+to authenticate @var{MegaCorp} users, then @var{useful-program} has to
+register to @var{MegaCorp} first, and get approved. This goes against
+the principle of permission-less innovation, which is at the heart of
+the web.
+
+In the decentralized authentication web, the best attempt so far is
+that of ActivityPub. All servers are interoperable with respect to
+authentication: if user A emits an activity, it is forwarded by A's
+server to its recipients, and A's server is responsible for A's
+identity.
+
+The problem with that approach is that the data is tied to the
+application. It is not possible to use another application to process
+the data differently, or to use multiple data sources, in an
+interoperable way (without the ActivityPub server knowing). This means
+that on Activitypub, microblogging applications will not present
+different activities correctly. This also means that it is difficult
+to write a free replacement to a non-free application program, because
+it would need to manage the data.
+
+In the Solid ecosystem, there is a clear distinction between servers
+and applications. An application is free to read data from all places
+at the same time, using a permission-less authentication system. Since
+the applications do not need to store data, the cost of having users
+is neglectible, so users do not need prior approval before using them
+(making captchas and the like a thing of the past). Servers do not
+have a say in which applications the user uses.
+
+The authentication used is a slight modification of the
+well-established OpenID Connect. It is intended to work in a web
+browser, but this package demonstrates that it also works without a
+web browser.
+
+@node Cryptography elements in Disfluid
+@chapter Cryptography elements in Disfluid
+Disfluid works with the JWA algorithms (RFC 7518) for signatures.
+
+@menu
+* Key management::
+@end menu
 
-This documentation is a stub.
+@node Key management
+@section Key management
+
+The @emph{(disfluid jwk)} module provides tools to manage keys,
+according to the conventions presented in RFC 7517.
+
+@deftp {Class} <jwk> @var{kid} @var{key}
+A class composed of a @var{key} (managed by gcrypt) and some
+meta-data. For now, only the @dfn{key identifier} @var{kid}: a string
+uniquely identifying a key or a key pair. A default value is always
+provided.
+
+You can construct a new key with the following keyword arguments:
+@table @code
+@item #:n-size
+This argument is used to generate a new RSA key pair. It is the number
+of bits for the RSA key. Pass less than 1024 to raise an error.
+@item #:e
+This argument is used to generate a new RSA key pair, but it is
+optional. Pass a value of 0 (the default) to let gcrypt pick a
+suitable value. Pass 1 to set it to 65537. As with gcrypt, 2 is a
+reserved value. Other than that, the value passed is used. If this is
+a string, it is decoded from base64url first.
+@item #:kid
+Override the key identifier. By default, a new value is computed.
+@end table
+@end deftp
+
+@deftypefn {Generic method} @code{SRFI-180 alist} jwk->json (@var{key} @code{<jwk>})
+@deftypefnx {Generic method} @code{SRFI-180 alist} jwk-public->json (@var{key} @code{<jwk>})
+Extract and encode the key parameters of @var{key} into an
+alist. @code{jwk->json} also encodes the private key, while
+@code{jwk-public->json} only encodes the public key. Using
+@code{jwk->json} is not recommended if you don’t need the private key,
+because it leaks the private key to the guile garbage collection.
+@end deftypefn
+
+@deftypefn {Generic method} @code{<string>} jkt (@var{key} @code{<jwk>})
+Compute the JWK Thumbprint (RFC 7638) of @var{key}.
+@end deftypefn
+
+@deftp {Exception type} &invalid-key-parameters
+An exception of this type is raised when the parameters cannot be used
+to build a valid cryptographic key. It can also be raised when
+generating a new key pair, if the key generation parameters are not
+valid, or too unsafe.
+@end deftp
 
 @bye
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>)))