diff options
Diffstat (limited to 'src/scm')
| -rw-r--r-- | src/scm/webid-oidc/Makefile.am | 6 | ||||
| -rw-r--r-- | src/scm/webid-oidc/access-token.scm | 8 | ||||
| -rw-r--r-- | src/scm/webid-oidc/authorization-code.scm | 6 | ||||
| -rw-r--r-- | src/scm/webid-oidc/client.scm | 2 | ||||
| -rw-r--r-- | src/scm/webid-oidc/client/accounts.scm | 70 | ||||
| -rw-r--r-- | src/scm/webid-oidc/client/client.scm | 25 | ||||
| -rw-r--r-- | src/scm/webid-oidc/dpop-proof.scm | 6 | ||||
| -rw-r--r-- | src/scm/webid-oidc/jwk.scm | 73 | ||||
| -rw-r--r-- | src/scm/webid-oidc/jws.scm | 58 | ||||
| -rw-r--r-- | src/scm/webid-oidc/oidc-configuration.scm | 9 | ||||
| -rw-r--r-- | src/scm/webid-oidc/oidc-id-token.scm | 14 | ||||
| -rw-r--r-- | src/scm/webid-oidc/serializable.scm | 207 |
12 files changed, 295 insertions, 189 deletions
diff --git a/src/scm/webid-oidc/Makefile.am b/src/scm/webid-oidc/Makefile.am index 5ffac04..92429f7 100644 --- a/src/scm/webid-oidc/Makefile.am +++ b/src/scm/webid-oidc/Makefile.am @@ -49,7 +49,8 @@ dist_webidoidcmod_DATA += \ %reldir%/catalog.scm \ %reldir%/parameters.scm \ %reldir%/simulation.scm \ - %reldir%/web-i18n.scm + %reldir%/web-i18n.scm \ + %reldir%/serializable.scm webidoidcgo_DATA += \ %reldir%/errors.go \ @@ -86,7 +87,8 @@ webidoidcgo_DATA += \ %reldir%/catalog.go \ %reldir%/parameters.go \ %reldir%/simulation.go \ - %reldir%/web-i18n.go + %reldir%/web-i18n.go \ + %reldir%/serializable.go EXTRA_DIST += %reldir%/ChangeLog diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm index d40e0da..9bd5ff7 100644 --- a/src/scm/webid-oidc/access-token.scm +++ b/src/scm/webid-oidc/access-token.scm @@ -19,6 +19,7 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc jwk) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc serializable) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) @@ -55,10 +56,11 @@ invalid-access-token?) (define-class <access-token> (<time-bound-token> <oidc-token>) - (webid #:init-keyword #:webid #:accessor webid) + (webid #:init-keyword #:webid #:accessor webid #:->sxml uri->string) (aud #:init-keyword #:aud #:accessor aud) - (client-id #:init-keyword #:client-id #:accessor client-id) - (cnf/jkt #:init-keyword #:cnf/jkt #:accessor cnf/jkt)) + (client-id #:init-keyword #:client-id #:accessor client-id #:->sxml uri->string) + (cnf/jkt #:init-keyword #:cnf/jkt #:accessor cnf/jkt) + #:module-name '(webid-oidc access-token)) (define-method (initialize (token <access-token>) initargs) (with-exception-handler diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm index 13b7ac4..7abf68b 100644 --- a/src/scm/webid-oidc/authorization-code.scm +++ b/src/scm/webid-oidc/authorization-code.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jws) #:use-module (webid-oidc jwk) #:use-module (webid-oidc jti) + #:use-module (webid-oidc serializable) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) #:use-module (srfi srfi-19) @@ -55,8 +56,9 @@ invalid-authorization-code?) (define-class <authorization-code> (<single-use-token>) - (webid #:init-keyword #:webid #:accessor webid) - (client-id #:init-keyword #:client-id #:accessor client-id)) + (webid #:init-keyword #:webid #:accessor webid #:->sxml uri->string) + (client-id #:init-keyword #:client-id #:accessor client-id #:->sxml uri->string) + #:module-name '(webid-oidc authorization-code)) (define-method (initialize (token <authorization-code>) initargs) (with-exception-handler diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index 7eb8fe3..ab40a7c 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -53,8 +53,6 @@ (client:client . client) (account:authorization-process . authorization-process) (account:authorization-state . authorization-state) - - (client:->sexp . ->sexp) ) #:export ( diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index 31d105d..9546263 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -28,6 +28,7 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc web-i18n) #:use-module (webid-oidc jws) + #:use-module (webid-oidc serializable) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc oidc-id-token) #:prefix id:) @@ -80,8 +81,6 @@ invalidate-access-token invalidate-refresh-token refresh - - ->sexp ) #:declarative? #t) @@ -128,12 +127,14 @@ (make-parameter #f)) (define-class <account> () - (subject #:init-keyword #:subject #:getter subject) - (issuer #:init-keyword #:issuer #:getter issuer) + (subject #:init-keyword #:subject #:getter subject #:->sxml uri->string) + (issuer #:init-keyword #:issuer #:getter issuer #:->sxml uri->string) (id-token #:init-keyword #:id-token #:getter id-token #:init-value #f) (access-token #:init-keyword #:access-token #:getter access-token #:init-value #f) (refresh-token #:init-keyword #:refresh-token #:getter refresh-token #:init-value #f) - (key-pair #:init-keyword #:key-pair #:getter key-pair)) + (key-pair #:init-keyword #:key-pair #:getter key-pair) + #:metaclass <plugin-class> + #:module-name '(webid-oidc client accounts)) (define-method (equal? (a <account>) (b <account>)) (and (equal? (subject a) (subject b)) @@ -143,41 +144,6 @@ (equal? (refresh-token a) (refresh-token b)) (equal? (key-pair a) (key-pair b)))) -(define-method (->sexp (account <account>)) - `(begin - (use-modules (oop goops) (webid-oidc client accounts) (webid-oidc jwk) (webid-oidc jws) (webid-oidc oidc-id-token)) - (make <account> - #:subject ,(uri->string (subject account)) - #:issuer ,(uri->string (issuer account)) - ,@(let ((id-token (id-token account))) - (if id-token - (receive (header payload) (token->jwk id-token) - `(#:id-token (make <id-token> - #:jws-header (quote ,header) - #:jws-payload (quote ,payload)))) - '())) - ,@(let ((access-token (access-token account))) - (if access-token - `(#:access-token ,access-token) - '())) - ,@(let ((refresh-token (refresh-token account))) - (if refresh-token - `(#:refresh-token ,refresh-token) - '())) - #:key-pair (jwk->key (quote ,(key->jwk (key-pair account))))))) - -(define-method (write (account <account>) port) - (let ((code (->sexp account))) - (pretty-print code port))) - -(define-method (display (account <account>) port) - (format port "#<<account> subject=~a issuer=~a id-token?=~a access-token?=~a refresh-token?=~a>" - (uri->string (subject account)) - (uri->string (issuer account)) - (and (id-token account) #t) - (and (access-token account) #t) - (and (refresh-token account) #t))) - (define-exception-type &login-failed &external-error @@ -403,28 +369,8 @@ (define-class <protected-account> (<account>) (username #:init-keyword #:username #:getter username) - (encrypted-password #:init-keyword #:encrypted-password #:getter encrypted-password)) - -(define-method (->sexp (account <protected-account>)) - (match (next-method) - (('begin - '(use-modules (oop goops) (webid-oidc client accounts)) - ('make '<account> initializers ...)) - `(begin - (use-modules (oop goops) (webid-oidc client accounts)) - (make <protected-account> - #:username ,(username account) - #:encrypted-password ,(encrypted-password account) - ,@initializers))))) - -(define-method (display (account <protected-account>) port) - (format port "#<<protected-account> subject=~a issuer=~a username=~a id-token?=~a access-token?=~a refresh-token?=~a>" - (uri->string (subject account)) - (uri->string (issuer account)) - (username account) - (and (id-token account) #t) - (and (access-token account) #t) - (and (refresh-token account) #t))) + (encrypted-password #:init-keyword #:encrypted-password #:getter encrypted-password) + #:module-name '(webid-oidc client accounts)) (define-method (check-credentials (account <protected-account>) (username <string>) (password <string>)) (let ((c (crypt password (encrypted-password account)))) diff --git a/src/scm/webid-oidc/client/client.scm b/src/scm/webid-oidc/client/client.scm index 3d02630..7c54cad 100644 --- a/src/scm/webid-oidc/client/client.scm +++ b/src/scm/webid-oidc/client/client.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc oidc-id-token) #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc serializable) #:use-module ((webid-oidc jwk) #:prefix jwk:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) @@ -51,33 +52,17 @@ client-redirect-uri client - - ->sexp ) #:declarative? #t) (define <jwk:key-pair> jwk:<key-pair>) (define-class <client> () - (client-id #:init-keyword #:client-id #:getter client-id) + (client-id #:init-keyword #:client-id #:getter client-id #:->sxml uri->string) (key-pair #:init-keyword #:key-pair #:getter client-key-pair) - (redirect-uri #:init-keyword #:redirect-uri #:getter client-redirect-uri)) - -(define-method (->sexp (client <client>)) - `(begin - (use-modules (oop goops) (webid-oidc client) (webid-oidc jwk)) - (make <client> - #:client-id ,(uri->string (client-id client)) - #:key-pair (jwk->key (quote ,(key->jwk (client-key-pair client)))) - #:redirect-uri ,(uri->string (client-redirect-uri client))))) - -(define-method (write (client <client>) port) - (pretty-print (->sexp client) port)) - -(define-method (display (client <client>) port) - (format port "#<<client> client-id=~a redirect-uri=~a>" - (uri->string (client-id client)) - (uri->string (client-redirect-uri client)))) + (redirect-uri #:init-keyword #:redirect-uri #:getter client-redirect-uri #:->sxml uri->string) + #:metaclass <plugin-class> + #:module-name '(webid-oidc client client)) (define-method (initialize (client <client>) initargs) (next-method) diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm index c492436..f8d97c3 100644 --- a/src/scm/webid-oidc/dpop-proof.scm +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -19,6 +19,7 @@ #:use-module (webid-oidc errors) #:use-module (webid-oidc jwk) #:use-module (webid-oidc jti) + #:use-module (webid-oidc serializable) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (webid-oidc web-i18n) @@ -132,8 +133,9 @@ (typ #:init-keyword #:typ #:accessor typ) (jwk #:init-keyword #:jwk #:accessor jwk) (htm #:init-keyword #:htm #:accessor htm) - (htu #:init-keyword #:htu #:accessor htu) - (ath #:init-keyword #:ath #:accessor ath)) + (htu #:init-keyword #:htu #:accessor htu #:->sxml uri->string) + (ath #:init-keyword #:ath #:accessor ath) + #:module-name '(webid-oidc dpop-proof)) (define-method (default-validity (proof <dpop-proof>)) (p:dpop-proof-validity)) 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 ¬-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)) 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)))))) diff --git a/src/scm/webid-oidc/oidc-configuration.scm b/src/scm/webid-oidc/oidc-configuration.scm index d0d1e20..094bf8a 100644 --- a/src/scm/webid-oidc/oidc-configuration.scm +++ b/src/scm/webid-oidc/oidc-configuration.scm @@ -18,6 +18,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc errors) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc serializable) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) @@ -53,9 +54,11 @@ invalid-oidc-configuration?) (define-class <oidc-configuration> () - (jwks-uri #:init-keyword #:jwks-uri #:accessor jwks-uri) - (authorization-endpoint #:init-keyword #:authorization-endpoint #:accessor authorization-endpoint) - (token-endpoint #:init-keyword #:token-endpoint #:accessor token-endpoint)) + (jwks-uri #:init-keyword #:jwks-uri #:accessor jwks-uri #:->jwks uri->string) + (authorization-endpoint #:init-keyword #:authorization-endpoint #:accessor authorization-endpoint #:->jwks uri->string) + (token-endpoint #:init-keyword #:token-endpoint #:accessor token-endpoint #:->jwks uri->string) + #:metaclass <plugin-class> + #:module-name '(webid-oidc oidc-configuration)) (define-method (initialize (cfg <oidc-configuration>) initargs) (next-method) diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm index 19e22d7..17a3299 100644 --- a/src/scm/webid-oidc/oidc-id-token.scm +++ b/src/scm/webid-oidc/oidc-id-token.scm @@ -20,6 +20,7 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc jti) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc serializable) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (web uri) @@ -55,9 +56,18 @@ invalid-id-token?) (define-class <id-token> (<single-use-token> <oidc-token>) - (webid #:init-keyword #:webid #:accessor webid) + (webid #:init-keyword #:webid #:accessor webid #:->sxml uri->string) (sub #:init-keyword #:sub #:accessor sub) - (aud #:init-keyword #:aud #:accessor aud)) + (aud #:init-keyword #:aud #:accessor aud #:->sxml uri->string) + #:metaclass <plugin-class> + #:module-name '(webid-oidc oidc-id-token)) + +(define-method (equal? (x <id-token>) (y <id-token>)) + (and (equal? (alg x) (alg y)) + (equal? (iat x) (iat y)) + (equal? ((@ (webid-oidc jws) exp) x) ((@ (webid-oidc jws) exp) y)) + (equal? (nonce x) (nonce y)) + (equal? (iss x) (iss y)))) (define-method (initialize (token <id-token>) initargs) (with-exception-handler diff --git a/src/scm/webid-oidc/serializable.scm b/src/scm/webid-oidc/serializable.scm new file mode 100644 index 0000000..f05206c --- /dev/null +++ b/src/scm/webid-oidc/serializable.scm @@ -0,0 +1,207 @@ +;; 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/>. + +(define-module (webid-oidc serializable) + #:use-module (oop goops) + #:use-module (ice-9 optargs) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc errors) + #:use-module (sxml ssax) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #:declarative? #t + #:export + ( + <plugin-class> module-name direct-name + read/xml + ->sxml + )) + +(define-class <plugin-class> (<class>) + (module-name #:init-keyword #:module-name #:getter module-name) + (direct-name #:getter direct-name)) + +(define (check-class-name name) + (let ((chars (string->list (symbol->string name)))) + (match chars + ((#\< next-chars ...) + (let ((rev (reverse next-chars))) + (match rev + ((#\> middle-chars ...) + (string->symbol (list->string (reverse middle-chars)))) + (else #f)))) + (else #f)))) + +(define-method (initialize (class <plugin-class>) initargs) + (next-method) + (let-keywords + initargs #t + ((module-name #f) + (name #f)) + (unless (and name module-name) + (fail (G_ "a plugin class should have an explicit #:name and #:module-name"))) + (unless (symbol? name) + (scm-error 'wrong-type-arg "make" + (G_ "#:name should be a symbol") + '() + (list name))) + (let check-module-name ((module-name module-name)) + (match module-name + (() #t) + (((? symbol? hd) tl ...) + (check-module-name tl)) + (else + (scm-error 'wrong-type-arg "make" + (G_ "#:module-name should be a list of symbols") + '() + (list module-name))))) + (let ((direct-name (check-class-name name))) + (unless direct-name + (fail (G_ "plugin class names should be surrounded by <angle brackets>"))) + (slot-set! class 'direct-name direct-name)) + (slot-set! class 'module-name module-name))) + +(define-class <parser-state> ()) + +(define-class <parser-reading-element> (<parser-state>) + (namespace #:init-keyword #:namespace #:accessor namespace) + (init-class #:init-keyword #:init-class #:accessor init-class) + (init-args-reverse #:init-keyword #:init-args-reverse #:accessor init-args-reverse)) + +(define-class <parser-reading-extended-attribute> (<parser-state>) + (attribute-name #:init-keyword #:attribute-name #:accessor attribute-name) + (attribute-value #:init-keyword #:attribute-value #:accessor attribute-value #:init-value #f)) + +(define-class <parser-root> (<parser-reading-extended-attribute>)) + +(define-method (new-level-seed elem-gi attributes namespaces expected-content (state <parser-reading-extended-attribute>)) + (match elem-gi + ((namespace . local-name) + (let ((namespace-parsed + (map string->symbol + (split-and-decode-uri-path (symbol->string namespace)))) + (local-name + (string->symbol + (string-append "<" (symbol->string local-name) ">")))) + (let ((class + (module-ref (resolve-interface namespace-parsed) local-name)) + (initargs (reverse attributes))) + (make <parser-reading-element> + #:namespace namespace + #:init-class class + #:init-args-reverse initargs)))) + (else state))) + +(define-method (new-level-seed elem-gi attributes namespaces expected-content (state <parser-reading-element>)) + (match elem-gi + (((? (cute eq? <> (namespace state))) . local-name) + (make <parser-reading-extended-attribute> + #:attribute-name local-name)) + (else state))) + +(define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-element>) (seed <parser-reading-extended-attribute>)) + (let ((ret (shallow-clone parent-seed))) + (set! (init-args-reverse ret) + `((,(attribute-name seed) . ,(attribute-value seed)) + ,@(init-args-reverse ret))) + ret)) + +(define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-extended-attribute>) (seed <parser-reading-element>)) + (let* ((class (init-class seed)) + (with-slots + (filter-map + (match-lambda + ((name . value) + (let ((slot (class-slot-definition class name))) + (and slot `(,slot . ,value))))) + (reverse (init-args-reverse seed)))) + (initializable/non-initializable + (receive (initializable non-initializable) + (partition (match-lambda + ((slot . value) + (slot-definition-init-keyword slot))) + with-slots) + (let collect-initializable ((initializable initializable) + (collected '())) + (match initializable + (() + `(,(reverse collected) + . ,(map (match-lambda + ((slot . value) + (lambda (x) + (slot-set! x (slot-definition-name slot) value)))) + non-initializable))) + (((slot . value) initializable ...) + (collect-initializable + initializable + `(,value ,(slot-definition-init-keyword slot) ,@collected))))))) + (initializable (car initializable/non-initializable)) + (non-initializable (cdr initializable/non-initializable))) + (let ((object (apply make class initializable))) + (for-each (lambda (finish!) (finish! object)) non-initializable) + (let ((ret (shallow-clone parent-seed))) + (set! (attribute-value ret) object) + ret)))) + +(define-method (char-data-handler string1 string2 (seed <parser-reading-extended-attribute>)) + (match (attribute-value seed) + ((or (? not (= (const "") existing)) + (? string? existing)) + (let ((ret (shallow-clone seed))) + (set! (attribute-value ret) + (string-append + existing + string1 + string2)) + ret)) + (else seed))) + +(define-method (char-data-handler string1 string2 (seed <parser-reading-element>)) + seed) + +(define read/xml + (let ((parser + (ssax:make-parser + NEW-LEVEL-SEED new-level-seed + FINISH-ELEMENT finish-element + CHAR-DATA-HANDLER char-data-handler))) + (lambda (port) + (attribute-value (parser port (make <parser-root>)))))) + +(define (->sxml object) + (let ((class (class-of object))) + (if (is-a? class <plugin-class>) + (let ((namespace + (encode-and-join-uri-path + (map symbol->string (module-name class))))) + (let ((all-slots (class-slots class))) + (define (get-slot-value slot) + (let ((name (slot-definition-name slot))) + (let-keywords + (slot-definition-options slot) #t + ((->sxml ->sxml)) + (catch 'slot-unbound + (lambda () + (let ((value (slot-ref object name))) + `((,name ,(->sxml value))))) + (lambda _ + '()))))) + `(,(direct-name class) (@ (xmlns ,namespace)) + ,@(apply append (map get-slot-value all-slots))))) + (call-with-output-string (lambda (port) (display object port)))))) |