JWK: serialize and deserialize to and from SXML

6 files changed, 150 insertions, 31 deletions

diff --git a/doc/disfluid.texi b/doc/disfluid.texi
index 6f76838..596566c 100644
--- a/doc/disfluid.texi
+++ b/doc/disfluid.texi
@@ -620,7 +620,8 @@ Key parameter getters.
 Return all the public keys used by @var{jwks}.
 @end deftypefn
 
-@deftypefn {Generic method} <undefined> check-key (@var{key} @code{<key>})
+@deftypefn {Generic method} <undefined> check-key (@var{key} @code{<public-key>})
+@deftypefnx {Generic method} <undefined> check-key (@var{key} @code{<private-key>})
 @deftypefnx {Generic method} <undefined> check-key (@var{key} @code{<key-pair>})
 Check that the @var{key} parameters are consistent.
 @end deftypefn
@@ -629,7 +630,8 @@ When exchanging keys, maybe you will have them in the form of a JWK:
 an alist from symbols to strings, as a representation for a JSON
 object.
 
-@deftypefn {Generic method} <list> key->jwk (@var{key} @code{<key>})
+@deftypefn {Generic method} <list> key->jwk (@var{key} @code{<public-key>})
+@deftypefnx {Generic method} <list> key->jwk (@var{key} @code{<private-key>})
 @deftypefnx {Generic method} <list> key->jwk (@var{key} @code{<key-pair>})
 Return an alist with known parameter names for JSON.
 @end deftypefn
@@ -638,6 +640,26 @@ Return an alist with known parameter names for JSON.
 Parse @var{jwk} as a key or a key pair.
 @end deffn
 
+It is also possible to serialize and deserialize the key to and from
+SXML.
+
+@deftypefn {Generic method} <list> ->sxml (@var{key} @code{<public-key>})
+@deftypefnx {Generic method} <list> ->sxml (@var{key} @code{<private-key>})
+@deftypefnx {Generic method} <list> ->sxml (@var{key} @code{<key-pair>})
+Convert @var{key} to an SXML representation that can be parsed back
+with @code{sxml->key}.
+@end deftypefn
+
+@deffn function sxml->key @var{sxml}
+Parse the @var{sxml} fragment back to a key or a key pair. For this to
+work, you need to not touch the
+@url{https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography}
+prefix. So, if you pass a @code{jwk} element, it should be
+@code{https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography:jwk},
+or @code{jwk} with an explicit @code{xmlns} attribute containing
+@url{https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography}.
+@end deffn
+
 @deftypefn {Generic method} <symbol> kty (@var{key} @code{<rsa-key-pair>})
 @deftypefnx {Generic method} <symbol> kty (@var{key} @code{<rsa-public-key>})
 @deftypefnx {Generic method} <symbol> kty (@var{key} @code{<rsa-private-key>})
diff --git a/po/disfluid.pot b/po/disfluid.pot
index cd8eb7d..6f2cad2 100644
--- a/po/disfluid.pot
+++ b/po/disfluid.pot
@@ -8,7 +8,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: disfluid SNAPSHOT\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-09-17 18:39+0200\n"
+"POT-Creation-Date: 2021-09-17 23:19+0200\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"
@@ -1040,59 +1040,59 @@ msgstr ""
 msgid "a replay has been detected with JTI ~s"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:144
+#: src/scm/webid-oidc/jwk.scm:147
 msgid "the point and scalar are not on the same curve"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:256
+#: src/scm/webid-oidc/jwk.scm:259
 #, scheme-format
 msgid "the JWK is invalid: ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:258
+#: src/scm/webid-oidc/jwk.scm:261
 msgid "the JWK is invalid"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:267
+#: src/scm/webid-oidc/jwk.scm:270
 msgid "cannot compute the key type"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:328
+#: src/scm/webid-oidc/jwk.scm:331
 msgid "it is built as an RSA key or key pair, but it is not"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:336
+#: src/scm/webid-oidc/jwk.scm:339
 msgid "it is built as an elliptic curve key or key pair, but it is not"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:378
+#: src/scm/webid-oidc/jwk.scm:381
 #, scheme-format
 msgid "the key advertises a key type of ~s, but actually it is ~s"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:427
+#: src/scm/webid-oidc/jwk.scm:430
 msgid "this is neither a RSA key nor an elliptic curve key"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:464
+#: src/scm/webid-oidc/jwk.scm:507
 #, scheme-format
 msgid "cannot fetch a JWKS: ~a"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:466
+#: src/scm/webid-oidc/jwk.scm:509
 msgid "cannot fetch a JWKS"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:470
+#: src/scm/webid-oidc/jwk.scm:513
 #, scheme-format
 msgid "the request failed with ~s ~s"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:475
+#: src/scm/webid-oidc/jwk.scm:518
 msgid "missing content-type"
 msgstr ""
 
-#: src/scm/webid-oidc/jwk.scm:480
+#: src/scm/webid-oidc/jwk.scm:523
 #, scheme-format
 msgid "invalid content-type: ~s"
 msgstr ""
diff --git a/po/fr.po b/po/fr.po
index 15b615d..fa1a500 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -2,7 +2,7 @@ msgid ""
 msgstr ""
 "Project-Id-Version: webid-oidc 0.0.0\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
-"POT-Creation-Date: 2021-09-17 18:39+0200\n"
+"POT-Creation-Date: 2021-09-17 23:19+0200\n"
 "PO-Revision-Date: 2021-09-17 18:38+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
@@ -1123,63 +1123,63 @@ msgstr "Non Trouvé"
 msgid "a replay has been detected with JTI ~s"
 msgstr "une redite a été détectée avec le JTI ~s"
 
-#: src/scm/webid-oidc/jwk.scm:144
+#: src/scm/webid-oidc/jwk.scm:147
 msgid "the point and scalar are not on the same curve"
 msgstr "le point et le scalaire ne sont pas sur la même courbe elliptique"
 
-#: src/scm/webid-oidc/jwk.scm:256
+#: src/scm/webid-oidc/jwk.scm:259
 #, scheme-format
 msgid "the JWK is invalid: ~a"
 msgstr "le JWK est invalide : ~a"
 
-#: src/scm/webid-oidc/jwk.scm:258
+#: src/scm/webid-oidc/jwk.scm:261
 msgid "the JWK is invalid"
 msgstr "le JWK est invalide"
 
-#: src/scm/webid-oidc/jwk.scm:267
+#: src/scm/webid-oidc/jwk.scm:270
 msgid "cannot compute the key type"
 msgstr "impossible de calculer le type de clé"
 
-#: src/scm/webid-oidc/jwk.scm:328
+#: src/scm/webid-oidc/jwk.scm:331
 msgid "it is built as an RSA key or key pair, but it is not"
 msgstr ""
 "elle est construite comme une clé ou paire de clés RSA, mais ce n’en est pas "
 "une"
 
-#: src/scm/webid-oidc/jwk.scm:336
+#: src/scm/webid-oidc/jwk.scm:339
 msgid "it is built as an elliptic curve key or key pair, but it is not"
 msgstr ""
 "elle est construite comme une clé ou paire de clés sur une courbe "
 "elliptique, mais ce n’en est pas une"
 
-#: src/scm/webid-oidc/jwk.scm:378
+#: src/scm/webid-oidc/jwk.scm:381
 #, scheme-format
 msgid "the key advertises a key type of ~s, but actually it is ~s"
 msgstr "la clé publie un type de clé ~s, mais c’est en fait ~s"
 
-#: src/scm/webid-oidc/jwk.scm:427
+#: src/scm/webid-oidc/jwk.scm:430
 msgid "this is neither a RSA key nor an elliptic curve key"
 msgstr "ce n’est ni une clé RSA ni une clé sur une courbe elliptique"
 
-#: src/scm/webid-oidc/jwk.scm:464
+#: src/scm/webid-oidc/jwk.scm:507
 #, scheme-format
 msgid "cannot fetch a JWKS: ~a"
 msgstr "impossible de télécharger un JWKS : ~a"
 
-#: src/scm/webid-oidc/jwk.scm:466
+#: src/scm/webid-oidc/jwk.scm:509
 msgid "cannot fetch a JWKS"
 msgstr "impossible de télécharger un JWKS"
 
-#: src/scm/webid-oidc/jwk.scm:470
+#: src/scm/webid-oidc/jwk.scm:513
 #, scheme-format
 msgid "the request failed with ~s ~s"
 msgstr "la requête a échoué avec ~s ~s"
 
-#: src/scm/webid-oidc/jwk.scm:475
+#: src/scm/webid-oidc/jwk.scm:518
 msgid "missing content-type"
 msgstr "type de contenu manquant"
 
-#: src/scm/webid-oidc/jwk.scm:480
+#: src/scm/webid-oidc/jwk.scm:523
 #, scheme-format
 msgid "invalid content-type: ~s"
 msgstr "type de contenu invalide : ~s"
diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
index f06818d..f1078aa 100644
--- a/src/scm/webid-oidc/jwk.scm
+++ b/src/scm/webid-oidc/jwk.scm
@@ -28,6 +28,7 @@
   #:use-module (web client)
   #:use-module (rnrs bytevectors)
   #:use-module (oop goops)
+  #:use-module (sxml match)
   #:declarative? #t
   #:export
   (
@@ -50,6 +51,8 @@
    generate-key
    serve
    get-jwks
+   ->sxml
+   sxml->key
 
    &not-a-jwk
    make-not-a-jwk
@@ -432,6 +435,46 @@
 (define (generate-key . args)
   (jwk->key (apply stubs:generate-key args)))
 
+(define (key->sxml key)
+  `(jwk
+    (@ (xmlns "https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography")
+       ,@(map (match-lambda ((key . value) `(,key ,value))) (key->jwk key)))))
+
+(define-method (->sxml (key <key-pair>))
+  (key->sxml key))
+
+(define-method (->sxml (key <private-key>))
+  (key->sxml key))
+
+(define-method (->sxml (key <public-key>))
+  (key->sxml key))
+
+(define (sxml->key sxml)
+  (define (attributes->key attributes)
+    (jwk->key
+     (map (match-lambda ((key value) `(,key . ,value))) attributes)))
+  (let analyze ((tree sxml))
+    (sxml-match
+     tree
+     ((*TOP*
+       (*PI* . ,pi)
+       . ,rest)
+      (analyze `(*TOP* . ,rest)))
+     ((*TOP*
+       (jwk (@ (xmlns "https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography:jwk") . ,attributes)))
+      (analyze `(*TOP* (https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography:jwk (@ . ,attributes)))))
+     ((*TOP*
+       (https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography:jwk (@ . ,attributes)))
+      (attributes->key attributes))
+     ((jwk . ,rest)
+      (analyze
+       `(*TOP*
+         (jwk . ,rest))))
+     ((https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography:jwk . ,rest)
+      (analyze
+       `(*TOP*
+         (https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography:jwk . ,rest)))))))
+
 (define-class <jwks> ()
   (keys #:init-keyword #:keys #:accessor keys))
 
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 02512d8..251b6b0 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -63,7 +63,8 @@ TESTS = %reldir%/load-library.scm \
   %reldir%/http-link.scm \
   %reldir%/acl.scm \
   %reldir%/crud.scm \
-  %reldir%/preconditions.scm
+  %reldir%/preconditions.scm \
+  %reldir%/xml-keys.scm
 
 EXTRA_DIST += $(TESTS) %reldir%/ChangeLog
 
diff --git a/tests/xml-keys.scm b/tests/xml-keys.scm
new file mode 100644
index 0000000..0e2baeb
--- /dev/null
+++ b/tests/xml-keys.scm
@@ -0,0 +1,53 @@
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 2021  Vivien Kraus
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+(use-modules (webid-oidc jwk)
+             (sxml simple)
+             (webid-oidc testing)
+             (oop goops))
+
+(with-test-environment
+ "xml-keys"
+ (lambda ()
+   (let ((key-xml
+          "<?xml version=\"1.0\" encoding=\"utf-8\"?>
+<jwk xmlns=\"https://disfluid.planete-kraus.eu/Public_002dkey-cryptography.html#Public_002dkey-cryptography\"
+     kty=\"EC\"
+     x=\"l8tFrhx-34tV3hRICRDY9zCkDlpBhF42UQUfWVAWBFs\"
+     y=\"9VE4jf_Ok_o64zbTTlcuNJajHmt6v9TDVrU0CdvGRDA\"
+     crv=\"P-256\" />")
+         (key (make <ec-point>
+                #:crv 'P-256
+                #:x "l8tFrhx-34tV3hRICRDY9zCkDlpBhF42UQUfWVAWBFs"
+                #:y "9VE4jf_Ok_o64zbTTlcuNJajHmt6v9TDVrU0CdvGRDA")))
+     (let ((parsed-once (sxml->key (xml->sxml key-xml)))
+           (printed-once (call-with-output-string
+                          (lambda (port)
+                            (sxml->xml (->sxml key) port)))))
+       (let ((parsed-twice (sxml->key (xml->sxml printed-once)))
+             (printed-twice (call-with-output-string
+                              (lambda (port)
+                                (sxml->xml (->sxml parsed-once) port)))))
+         (let ((parsed-thrice (sxml->key (xml->sxml printed-twice)))
+               (printed-thrice (call-with-output-string
+                                 (lambda (port)
+                                   (sxml->xml (->sxml parsed-twice) port)))))
+           (unless (and (equal? parsed-once key)
+                        (equal? parsed-twice parsed-once)
+                        (equal? parsed-thrice parsed-twice)
+                        (equal? printed-twice printed-once)
+                        (equal? printed-thrice printed-twice))
+             (exit 1))))))))