Define an XML-loadable meta-class

5 files changed, 162 insertions, 35 deletions

diff --git a/tests/Makefile.am b/tests/Makefile.am
index 99c834d..2f5c1d6 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -65,7 +65,8 @@ TESTS = %reldir%/load-library.scm \
   %reldir%/acl.scm \
   %reldir%/crud.scm \
   %reldir%/preconditions.scm \
-  %reldir%/xml-keys.scm
+  %reldir%/xml-keys.scm \
+  %reldir%/xml-accounts.scm
 
 EXTRA_DIST += $(TESTS) %reldir%/ChangeLog
 
diff --git a/tests/dpop-proof-no-explicit-exp.scm b/tests/dpop-proof-no-explicit-exp.scm
index 5a4ccbc..83541a2 100644
--- a/tests/dpop-proof-no-explicit-exp.scm
+++ b/tests/dpop-proof-no-explicit-exp.scm
@@ -14,22 +14,25 @@
 ;; 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 dpop-proof)
-             (webid-oidc access-token)
-             (webid-oidc jwk)
-             (webid-oidc jws)
-             (webid-oidc testing)
-             (webid-oidc errors)
-             ((webid-oidc stubs) #:prefix stubs:)
-             ((webid-oidc parameters) #:prefix p:)
-             (web uri)
-             (srfi srfi-19)
-             (web response)
-             (ice-9 receive)
-             (ice-9 optargs)
-             (oop goops))
+(define-module (tests dpop-proof-no-explicit-exp)
+  #:use-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc access-token)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc jws)
+  #:use-module (webid-oidc testing)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-19)
+  #:use-module (web response)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 optargs)
+  #:use-module (oop goops)
+  #:declarative? #t)
 
-(define-class <dpop-proof-with-exp> (<dpop-proof>))
+(define-class <dpop-proof-with-exp> (<dpop-proof>)
+  #:module-name '(tests dpop-proof-no-explicit-exp))
 
 (define-method (initialize (token <dpop-proof-with-exp>) initargs)
   (next-method)
diff --git a/tests/dpop-proof-no-explicit-iat.scm b/tests/dpop-proof-no-explicit-iat.scm
index 671dfa0..7c09195 100644
--- a/tests/dpop-proof-no-explicit-iat.scm
+++ b/tests/dpop-proof-no-explicit-iat.scm
@@ -14,22 +14,25 @@
 ;; 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 dpop-proof)
-             (webid-oidc access-token)
-             (webid-oidc jwk)
-             (webid-oidc jws)
-             (webid-oidc testing)
-             (webid-oidc errors)
-             ((webid-oidc stubs) #:prefix stubs:)
-             ((webid-oidc parameters) #:prefix p:)
-             (web uri)
-             (srfi srfi-19)
-             (web response)
-             (ice-9 receive)
-             (ice-9 match)
-             (oop goops))
+(define-module (tests dpop-proof-no-explicit-iat)
+  #:use-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc access-token)
+  #:use-module (webid-oidc jwk)
+  #:use-module (webid-oidc jws)
+  #:use-module (webid-oidc testing)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-19)
+  #:use-module (web response)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:declarative? #t)
 
-(define-class <dpop-proof-without-iat> (<dpop-proof>))
+(define-class <dpop-proof-without-iat> (<dpop-proof>)
+  #:module-name '(tests dpop-proof-no-explicit-iat))
 
 (define malicious-jwt-created? #f)
 
diff --git a/tests/xml-accounts.scm b/tests/xml-accounts.scm
new file mode 100644
index 0000000..3a30dac
--- /dev/null
+++ b/tests/xml-accounts.scm
@@ -0,0 +1,116 @@
+;; 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 client accounts)
+             (webid-oidc jwk)
+             (webid-oidc oidc-id-token)
+             (sxml simple)
+             (webid-oidc testing)
+             (webid-oidc serializable)
+             (web uri)
+             (oop goops))
+
+(define (xml->account xml)
+  (call-with-input-string xml read/xml))
+
+(with-test-environment
+ "xml-accounts"
+ (lambda ()
+   (let ((account-xml
+          "<?xml version=\"1.0\" encoding=\"utf-8\"?>
+<account xmlns=\"webid-oidc/client/accounts\"
+     subject=\"https://example.com/profile/card#me\"
+     issuer=\"https://example.com\"
+     access-token=\"xxx\"
+     refresh-token=\"xxx\">
+    <id-token>
+        <id-token xmlns=\"webid-oidc/oidc-id-token\"
+             alg=\"RS256\"
+             webid=\"https://example.com/profile/card#me\"
+             iss=\"https://example.com\"
+             sub=\"toto\"
+             aud=\"https://client.example.com/app-id\"
+             iat=\"0\"
+             exp=\"3600\"
+             nonce=\"xxxxx\" />
+    </id-token>
+    <key-pair>
+        <rsa-key-pair xmlns=\"webid-oidc/jwk\">
+            <public-key>
+                <rsa-public-key
+                     n=\"zopuG9oxFDbs6dntfGBBm6F1tU4Cy80lWpMOL3Je1ks9RHixn8_vlswdW-YM_jUdfhdH4VdQ5ergV2flOtTZ3agVGxMZWtdS8WxKNkmeyr1mVchRB7Hzl1kLYWClkBeoQ2Bi3vDCxTsdz9q3x7610wnRbcAHhtxq_Wm4vlYqXm7MJ5eMXzAdkNaBMgjt38fbOssH8vXqq57nvIZ2kyjAW_cvPixEQR3w6Py_nBzElJDgDO59x9SsRbVn_5qpqPK9vi4RPpKmIVpT3ww_ChJjZZHRYWbKmVyX15xfSRK0zQBtbbYVxqwZyUx8lkxoNKSXkcwcPdumqrYekzMx8eiaFQ\"
+                     e=\"AQAB\" />
+            </public-key>
+            <private-key>
+                <rsa-private-key
+                     d=\"HGhh2KbcFUGwuEFnLrI2k-dTP0qpi8p9lsWfL9t1O9hBZweKtsZs17rfVuJ_av93PP6Kvm26DMWPcbYyizL3fEtAC-dGl34CRH52fp0FoDEIwEe7DWnmbSysKgqW-wil9g5tyugmgeYtpYcZu_l5HLu--G9vGZd7h7tg050aWr52-sacRkiKtgiLiw2Ih994eJcosHRVvmjsjUsq43L_nbW5js82bgQ0SilG_JwUeEmLG6kcFt0PDKuyGCS8Wj-ctp51i9u0jwTHXENrF7uzevaXFqDIObRQg_jX15_ma95qAXHT3cFAIKn-FE0HF3BsWsPo3NwUBb9E29psCxsXyQ\"
+                     p=\"0HCTOPqbglzNRQZ0qwN5axRIK6pRAxY2tSKUsTVIyZhVQbDQ2AWiMt2-uk7XY_IP9AtnGEnSONT2BigVph0sLOUwJA1XdHDxOcoIGUUhAAdgD7gHtiX1-4Y5PPUXGDuJ2XgMG0VCWgDbiY-H7St4l8Lhne8AEmtZShAWW6nRZu8\"
+                     q=\"_aruFkAI2UUY7IwcBrnFif4xfFvQS2r1Q0tlshgDbxq5-bE7sWFoenDe522Paiq1_aMBsfJN8PovB8LDiYKwRc68CIEdMQsyVd0LqdrJ4Jgg_7XB8gQOcy-qexgQzADTR642sWpDeAvcKujqcMxouZGtcYGNy0rMtcBOp29ALzs\"
+                     dp=\"s8YkdCRRM6JuuHXU8hpRAnW_uUlwDcV-8cMdk6ltWdI01i92MJrLRivScEXHp8AC2m1rQZuJ4NJsTusLoPXQP_h8CNwo7ZjrtPf2_DSPPcMeqvACVqtu-LzPaS_J93CCeDn91xdpHs9WidJtXbT8kYfXp6uW2EwV-rbdUbmpjak\"
+                     dq=\"g5u1XxHmBWPWJJQkzlB_7rJVVmIEVbyudzWdE6Nl1LUXHDcZ81PIcw4wd_3d1IVIWsnBzWMbkRUcZXhlHukRL4atA_SJArL-cJH4xS1gZAhJxqG0eC4mmRh36Nl5jX44IA6BDddGHfh5SEIDsHY9N1oflK5UtM6gGwQlSrVrpZU\"
+                     qi=\"ebz0a-3PHrZx4U1npQCGajUDWqJgvvbqx-cGVK8k3f6LB25l2CWEal5WjoSWw4mbN8tUcOx8Q8DwB2lR90eY_gvMV1gg-zuiC8B2_XPHcn84Mmr-sJRcqoesECsABcosn0EH8IrKpuiZniGcNXh1kC5UlmyvPjOlEJhXuNPwk38\" />
+            </private-key>
+        </rsa-key-pair>
+    </key-pair>
+</account>
+")
+         (account (make <account>
+                    #:subject (string->uri "https://example.com/profile/card#me")
+                    #:issuer (string->uri "https://example.com")
+                    #:access-token "xxx"
+                    #:refresh-token "xxx"
+                    #:id-token
+                    (make <id-token>
+                      #:alg 'RS256
+                      #:webid (string->uri "https://example.com/profile/card#me")
+                      #:iss (string->uri "https://example.com")
+                      #:sub "toto"
+                      #:aud (string->uri "https://client.example.com/app-id")
+                      #:iat 0
+                      #:exp 3600
+                      #:nonce "xxxxx")
+                    #:key-pair
+                    (make <rsa-key-pair>
+                      #:public-key
+                      (make <rsa-public-key>
+                        #:n "zopuG9oxFDbs6dntfGBBm6F1tU4Cy80lWpMOL3Je1ks9RHixn8_vlswdW-YM_jUdfhdH4VdQ5ergV2flOtTZ3agVGxMZWtdS8WxKNkmeyr1mVchRB7Hzl1kLYWClkBeoQ2Bi3vDCxTsdz9q3x7610wnRbcAHhtxq_Wm4vlYqXm7MJ5eMXzAdkNaBMgjt38fbOssH8vXqq57nvIZ2kyjAW_cvPixEQR3w6Py_nBzElJDgDO59x9SsRbVn_5qpqPK9vi4RPpKmIVpT3ww_ChJjZZHRYWbKmVyX15xfSRK0zQBtbbYVxqwZyUx8lkxoNKSXkcwcPdumqrYekzMx8eiaFQ"
+                        #:e "AQAB")
+                      #:private-key
+                      (make <rsa-private-key>
+                        #:d "HGhh2KbcFUGwuEFnLrI2k-dTP0qpi8p9lsWfL9t1O9hBZweKtsZs17rfVuJ_av93PP6Kvm26DMWPcbYyizL3fEtAC-dGl34CRH52fp0FoDEIwEe7DWnmbSysKgqW-wil9g5tyugmgeYtpYcZu_l5HLu--G9vGZd7h7tg050aWr52-sacRkiKtgiLiw2Ih994eJcosHRVvmjsjUsq43L_nbW5js82bgQ0SilG_JwUeEmLG6kcFt0PDKuyGCS8Wj-ctp51i9u0jwTHXENrF7uzevaXFqDIObRQg_jX15_ma95qAXHT3cFAIKn-FE0HF3BsWsPo3NwUBb9E29psCxsXyQ"
+                        #:p "0HCTOPqbglzNRQZ0qwN5axRIK6pRAxY2tSKUsTVIyZhVQbDQ2AWiMt2-uk7XY_IP9AtnGEnSONT2BigVph0sLOUwJA1XdHDxOcoIGUUhAAdgD7gHtiX1-4Y5PPUXGDuJ2XgMG0VCWgDbiY-H7St4l8Lhne8AEmtZShAWW6nRZu8"
+                        #:q "_aruFkAI2UUY7IwcBrnFif4xfFvQS2r1Q0tlshgDbxq5-bE7sWFoenDe522Paiq1_aMBsfJN8PovB8LDiYKwRc68CIEdMQsyVd0LqdrJ4Jgg_7XB8gQOcy-qexgQzADTR642sWpDeAvcKujqcMxouZGtcYGNy0rMtcBOp29ALzs"
+                        #:dp "s8YkdCRRM6JuuHXU8hpRAnW_uUlwDcV-8cMdk6ltWdI01i92MJrLRivScEXHp8AC2m1rQZuJ4NJsTusLoPXQP_h8CNwo7ZjrtPf2_DSPPcMeqvACVqtu-LzPaS_J93CCeDn91xdpHs9WidJtXbT8kYfXp6uW2EwV-rbdUbmpjak"
+                        #:dq "g5u1XxHmBWPWJJQkzlB_7rJVVmIEVbyudzWdE6Nl1LUXHDcZ81PIcw4wd_3d1IVIWsnBzWMbkRUcZXhlHukRL4atA_SJArL-cJH4xS1gZAhJxqG0eC4mmRh36Nl5jX44IA6BDddGHfh5SEIDsHY9N1oflK5UtM6gGwQlSrVrpZU"
+                        #:qi "ebz0a-3PHrZx4U1npQCGajUDWqJgvvbqx-cGVK8k3f6LB25l2CWEal5WjoSWw4mbN8tUcOx8Q8DwB2lR90eY_gvMV1gg-zuiC8B2_XPHcn84Mmr-sJRcqoesECsABcosn0EH8IrKpuiZniGcNXh1kC5UlmyvPjOlEJhXuNPwk38")))))
+     (let ((parsed-once (xml->account account-xml))
+           (printed-once (call-with-output-string
+                           (lambda (port)
+                             (sxml->xml (->sxml account) port)))))
+       (let ((parsed-twice (xml->account printed-once))
+             (printed-twice (call-with-output-string
+                              (lambda (port)
+                                (sxml->xml (->sxml parsed-once) port)))))
+         (let ((parsed-thrice (xml->account printed-twice))
+               (printed-thrice (call-with-output-string
+                                 (lambda (port)
+                                   (sxml->xml (->sxml parsed-twice) port)))))
+           (unless (and (equal? parsed-once account)
+                        (equal? parsed-twice parsed-once)
+                        (equal? parsed-thrice parsed-twice)
+                        (equal? printed-twice printed-once)
+                        (equal? printed-thrice printed-twice))
+             (exit 1))))))))
diff --git a/tests/xml-keys.scm b/tests/xml-keys.scm
index 0e2baeb..691af4a 100644
--- a/tests/xml-keys.scm
+++ b/tests/xml-keys.scm
@@ -17,14 +17,18 @@
 (use-modules (webid-oidc jwk)
              (sxml simple)
              (webid-oidc testing)
+             (webid-oidc serializable)
              (oop goops))
 
+(define (xml->key xml)
+  (call-with-input-string xml read/xml))
+
 (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\"
+<ec-point xmlns=\"webid-oidc/jwk\"
      kty=\"EC\"
      x=\"l8tFrhx-34tV3hRICRDY9zCkDlpBhF42UQUfWVAWBFs\"
      y=\"9VE4jf_Ok_o64zbTTlcuNJajHmt6v9TDVrU0CdvGRDA\"
@@ -33,15 +37,15 @@
                 #:crv 'P-256
                 #:x "l8tFrhx-34tV3hRICRDY9zCkDlpBhF42UQUfWVAWBFs"
                 #:y "9VE4jf_Ok_o64zbTTlcuNJajHmt6v9TDVrU0CdvGRDA")))
-     (let ((parsed-once (sxml->key (xml->sxml key-xml)))
+     (let ((parsed-once (xml->key key-xml))
            (printed-once (call-with-output-string
                           (lambda (port)
                             (sxml->xml (->sxml key) port)))))
-       (let ((parsed-twice (sxml->key (xml->sxml printed-once)))
+       (let ((parsed-twice (xml->key 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)))
+         (let ((parsed-thrice (xml->key printed-twice))
                (printed-thrice (call-with-output-string
                                  (lambda (port)
                                    (sxml->xml (->sxml parsed-twice) port)))))