Define an XML-loadable meta-class

1 files changed, 22 insertions, 51 deletions

diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
index 04e50f2..661db1c 100644
--- a/src/scm/webid-oidc/jwk.scm
+++ b/src/scm/webid-oidc/jwk.scm
@@ -19,6 +19,7 @@
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (webid-oidc errors)
   #:use-module (webid-oidc web-i18n)
+  #:use-module (webid-oidc serializable)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 optargs)
   #:use-module (ice-9 exceptions)
@@ -51,8 +52,6 @@
    generate-key
    serve
    get-jwks
-   ->sxml
-   sxml->key
 
    &not-a-jwk
    make-not-a-jwk
@@ -76,18 +75,26 @@
   not-a-jwks?)
 
 (define-class <private-key> ()
-  (alg #:init-keyword #:alg #:accessor alg))
+  (alg #:init-keyword #:alg #:accessor alg)
+  #:metaclass <plugin-class>
+  #:module-name '(webid-oidc jwk))
 
-(define-class <public-key> ())
+(define-class <public-key> ()
+  #:metaclass <plugin-class>
+  #:module-name '(webid-oidc jwk))
 
 (define-class <key-pair> ()
   (public-key #:init-keyword #:public-key #:accessor public-key)
-  (private-key #:init-keyword #:private-key #:accessor private-key))
+  (private-key #:init-keyword #:private-key #:accessor private-key)
+  #:metaclass <plugin-class>
+  #:module-name '(webid-oidc jwk))
 
-(define-class <rsa-key-pair> (<key-pair>))
+(define-class <rsa-key-pair> (<key-pair>)
+  #:module-name '(webid-oidc jwk))
 
 (define-class <ec-key-pair> (<key-pair>)
-  (crv #:init-keyword #:crv #:accessor ec-crv))
+  (crv #:init-keyword #:crv #:accessor ec-crv)
+  #:module-name '(webid-oidc jwk))
 
 (define-class <rsa-private-key> (<private-key>)
   (d #:init-keyword #:d #:accessor rsa-d)
@@ -95,20 +102,24 @@
   (q #:init-keyword #:q #:accessor rsa-q)
   (dp #:init-keyword #:dp #:accessor rsa-dp)
   (dq #:init-keyword #:dq #:accessor rsa-dq)
-  (qi #:init-keyword #:qi #:accessor rsa-qi))
+  (qi #:init-keyword #:qi #:accessor rsa-qi)
+  #:module-name '(webid-oidc jwk))
 
 (define-class <rsa-public-key> (<public-key>)
   (n #:init-keyword #:n #:accessor rsa-n)
-  (e #:init-keyword #:e #:accessor rsa-e))
+  (e #:init-keyword #:e #:accessor rsa-e)
+  #:module-name '(webid-oidc jwk))
 
 (define-class <ec-scalar> (<private-key>)
   (crv #:init-keyword #:crv #:accessor ec-crv)
-  (z #:init-keyword #:z #:accessor ec-z))
+  (z #:init-keyword #:z #:accessor ec-z)
+  #:module-name '(webid-oidc jwk))
 
 (define-class <ec-point> (<public-key>)
   (crv #:init-keyword #:crv #:accessor ec-crv)
   (x #:init-keyword #:x #:accessor ec-x)
-  (y #:init-keyword #:y #:accessor ec-y))
+  (y #:init-keyword #:y #:accessor ec-y)
+  #:module-name '(webid-oidc jwk))
 
 (define-method (initialize-key-pair (key <key-pair>) (public <rsa-public-key>) (private <rsa-private-key>))
   (set! (public-key key) public)
@@ -439,46 +450,6 @@
 (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))