Serialize and deserialize tokens to and from SXML

1 files changed, 36 insertions, 0 deletions

diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm
index af83c90..22dabdd 100644
--- a/src/scm/webid-oidc/jws.scm
+++ b/src/scm/webid-oidc/jws.scm
@@ -29,6 +29,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 optargs)
   #:use-module (web uri)
+  #:use-module (sxml match)
   #:use-module (oop goops)
   #:declarative? #t
   #:re-export
@@ -83,6 +84,9 @@
    encode
    issue
 
+   ->sxml
+   sxml->token
+
    ))
 
 (define-exception-type
@@ -600,3 +604,35 @@
 
 (define* (issue token-class issuer-key . args)
   (encode (apply make token-class #:signing-key issuer-key args) issuer-key))
+
+(define-method (->sxml (token <token>))
+  (receive (header payload) (token->jwt token)
+    `(token
+      (@ (xmlns "https://disfluid.planete-kraus.eu/Tokens.html#Tokens")
+         (header ,(stubs:scm->json-string header))
+         (payload ,(stubs:scm->json-string payload))))))
+
+(define (sxml->token token-class fragment)
+  (let analyze ((tree fragment))
+    (sxml-match
+     tree
+     ((*TOP*
+       (token (@ (xmlns "https://disfluid.planete-kraus.eu/Tokens.html#Tokens")
+                 (header ,header)
+                 (payload ,payload)))
+       . ,rest)
+      (analyze `(*TOP*
+                 (https://disfluid.planete-kraus.eu/Tokens.html#Tokens:token
+                  (@ (header ,header)
+                     (payload ,payload))))))
+     ((*TOP*
+       (https://disfluid.planete-kraus.eu/Tokens.html#Tokens:token
+        (@ (header ,header)
+           (payload ,payload))))
+      (make token-class #:jwk-header header #:jwk-payload payload))
+     ((*TOP* ,whatever . ,rest)
+      (analyze `(*TOP* ,@rest)))
+     ((*TOP*)
+      (fail (G_ "cannot parse a token")))
+     (,_
+      (analyze `(*TOP* ,tree))))))