Define an XML-loadable meta-class

1 files changed, 18 insertions, 40 deletions

diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm
index e0eba54..7e6b15d 100644
--- a/src/scm/webid-oidc/jws.scm
+++ b/src/scm/webid-oidc/jws.scm
@@ -20,6 +20,7 @@
   #:use-module (webid-oidc web-i18n)
   #:use-module (webid-oidc jti)
   #:use-module (webid-oidc oidc-configuration)
+  #:use-module (webid-oidc serializable)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module (rnrs bytevectors)
@@ -84,9 +85,6 @@
    encode
    issue
 
-   ->sxml
-   sxml->token
-
    ))
 
 (define-exception-type
@@ -96,7 +94,9 @@
   invalid-jws?)
 
 (define-class <token> ()
-  (alg #:init-keyword #:alg #:accessor alg))
+  (alg #:init-keyword #:alg #:accessor alg)
+  #:metaclass <plugin-class>
+  #:module-name '(webid-oidc jws))
 
 (define (key-alg key)
   (alg key))
@@ -151,9 +151,13 @@
 (define-method (no-applicable-method (generic <generic-with-default>) args)
   (apply values (slot-ref generic 'neutral)))
 
+(define (date->sxml date)
+  (number->string (time-second (date->time-utc date))))
+
 (define-class <time-bound-token> (<token>)
-  (iat #:init-keyword #:iat #:accessor iat)
-  (exp #:init-keyword #:exp #:accessor exp))
+  (iat #:init-keyword #:iat #:accessor iat #:->sxml date->sxml)
+  (exp #:init-keyword #:exp #:accessor exp #:->sxml date->sxml)
+  #:module-name '(webid-oidc jws))
 
 (define default-validity
   (make <generic-with-default>
@@ -180,6 +184,8 @@
                        (jwt-header jwt-header)
                        (jwt-payload jwt-payload))
      (cond
+      ((string? iat)
+       (do-initialize (string->number iat) exp validity jwt-header jwt-payload))
       ((integer? iat)
        (do-initialize (make-time time-utc 0 iat) exp validity jwt-header jwt-payload))
       ((time? iat)
@@ -191,6 +197,8 @@
                       validity
                       jwt-header
                       jwt-payload))
+      ((string? exp)
+       (do-initialize iat (string->number exp) validity jwt-header jwt-payload))
       ((integer? exp)
        (do-initialize iat (make-time time-utc 0 exp) validity jwt-header jwt-payload))
       ((time? exp)
@@ -221,7 +229,8 @@
           (G_ "when making a time-bound token, either its required fields (#:iat, and either #:exp or #:validity) or (#:jwt-header and #:jwt-payload) should be passed")))))))))
 
 (define-class <oidc-token> (<token>)
-  (iss #:init-keyword #:iss #:accessor iss))
+  (iss #:init-keyword #:iss #:accessor iss #:->sxml uri->string)
+  #:module-name '(webid-oidc jws))
 
 (define-method (default-validity (token <oidc-token>))
   (let ((next (next-method))
@@ -260,7 +269,8 @@
           (G_ "when making an OIDC token, either its required #:iss field or (#:jwt-header and #:jwt-payload) should be passed")))))))))
 
 (define-class <single-use-token> (<time-bound-token>)
-  (nonce #:init-keyword #:nonce #:accessor nonce))
+  (nonce #:init-keyword #:nonce #:accessor nonce)
+  #:module-name '(webid-oidc jws))
 
 (define-method (default-validity (token <single-use-token>))
   (let ((next (next-method))
@@ -591,35 +601,3 @@
 
 (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))))))