summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/scm/webid-oidc/access-token.scm3
-rw-r--r--src/scm/webid-oidc/authorization-code.scm4
-rw-r--r--src/scm/webid-oidc/authorization-endpoint.scm3
-rw-r--r--src/scm/webid-oidc/client.scm3
-rw-r--r--src/scm/webid-oidc/client/accounts.scm3
-rw-r--r--src/scm/webid-oidc/dpop-proof.scm3
-rw-r--r--src/scm/webid-oidc/identity-provider.scm126
-rw-r--r--src/scm/webid-oidc/jwk.scm45
-rw-r--r--src/scm/webid-oidc/oidc-id-token.scm4
-rw-r--r--src/scm/webid-oidc/token-endpoint.scm4
10 files changed, 107 insertions, 91 deletions
diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm
index 0cc8c27..7e67270 100644
--- a/src/scm/webid-oidc/access-token.scm
+++ b/src/scm/webid-oidc/access-token.scm
@@ -325,7 +325,6 @@
(define* (issue-access-token
issuer-key
#:key
- (alg #f)
(webid #f)
(iss #f)
(validity 3600)
@@ -338,7 +337,7 @@
(exp (+ iat validity)))
(jws-encode
(the-access-token
- `(((alg . ,(symbol->string alg)))
+ `(((alg . ,(symbol->string (alg issuer-key))))
. ((webid . ,(uri->string webid))
(iss . ,(uri->string iss))
(aud . "solid")
diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm
index ff7fe60..1481b2c 100644
--- a/src/scm/webid-oidc/authorization-code.scm
+++ b/src/scm/webid-oidc/authorization-code.scm
@@ -18,6 +18,7 @@
#:use-module (webid-oidc errors)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
#:use-module (webid-oidc jws)
+ #:use-module (webid-oidc jwk)
#:use-module (webid-oidc jti)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module (web uri)
@@ -209,14 +210,13 @@
(define* (issue-authorization-code issuer-key
#:key
- alg
(validity 120)
webid
client-id)
(let* ((iat (time-second (date->time-utc ((p:current-date)))))
(exp (+ iat validity)))
(authorization-code-encode
- `(((alg . ,(symbol->string alg)))
+ `(((alg . ,(symbol->string (alg issuer-key))))
. ((webid . ,(uri->string webid))
(client_id . ,(uri->string client-id))
(exp . ,exp)
diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm
index 86a8a4d..cf45a9c 100644
--- a/src/scm/webid-oidc/authorization-endpoint.scm
+++ b/src/scm/webid-oidc/authorization-endpoint.scm
@@ -43,7 +43,7 @@
(let ((c (crypt password encrypted-password)))
(string=? c encrypted-password)))
-(define* (make-authorization-endpoint subject encrypted-password alg jwk validity
+(define* (make-authorization-endpoint subject encrypted-password jwk validity
#:key
(http-get http-get))
(define (parse-arg x decode-plus-to-space?)
@@ -108,7 +108,6 @@
(lambda ()
(let ((code (issue-authorization-code
jwk
- #:alg alg
#:webid subject
#:client-id client-id))
(mf (get-client-manifest client-id
diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm
index 52a33a4..5b6b0ef 100644
--- a/src/scm/webid-oidc/client.scm
+++ b/src/scm/webid-oidc/client.scm
@@ -139,9 +139,6 @@
(let ((key-pair (account:key-pair account)))
(issue-dpop-proof
key-pair
- #:alg (case (kty key-pair)
- ((EC) 'ES256)
- ((RSA) 'RS256))
#:htm method
#:htu uri
#:access-token access-token))))
diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm
index 54c6e07..ddb592a 100644
--- a/src/scm/webid-oidc/client/accounts.scm
+++ b/src/scm/webid-oidc/client/accounts.scm
@@ -255,9 +255,6 @@
(let ((dpop-proof
(dpop:issue-dpop-proof
key-pair
- #:alg (case (jwk:kty key-pair)
- ((EC) 'ES256)
- ((RSA) 'RS256))
#:htm 'POST
#:htu token-endpoint)))
(receive (response response-body)
diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm
index 5e01235..8c66f68 100644
--- a/src/scm/webid-oidc/dpop-proof.scm
+++ b/src/scm/webid-oidc/dpop-proof.scm
@@ -409,13 +409,12 @@
(define* (issue-dpop-proof
client-key
#:key
- (alg #f)
(htm #f)
(htu #f)
(access-token #f))
(dpop-proof-encode
(the-dpop-proof
- `(((alg . ,(symbol->string alg))
+ `(((alg . ,(symbol->string (alg client-key)))
(typ . "dpop+jwt")
(jwk . ,(key->jwk (public-key client-key))))
. ((jti . ,(stubs:random 12))
diff --git a/src/scm/webid-oidc/identity-provider.scm b/src/scm/webid-oidc/identity-provider.scm
index cf06b62..7973917 100644
--- a/src/scm/webid-oidc/identity-provider.scm
+++ b/src/scm/webid-oidc/identity-provider.scm
@@ -80,73 +80,69 @@
(lambda (port)
(stubs:scm->json (key->jwk k) port #:pretty #t)))
k)))))
- (let ((alg
- (if (eq? (kty key) 'RSA)
- 'RS256
- 'ES256)))
- (let ((authorization-endpoint
- (make-authorization-endpoint subject encrypted-password alg key 120
- #:http-get http-get))
- (token-endpoint
- (make-token-endpoint token-endpoint-uri issuer alg key 3600))
- (openid-configuration
- `((jwks_uri . ,(uri->string jwks-uri))
- (authorization_endpoint . ,(uri->string authorization-endpoint-uri))
- (token_endpoint . ,(uri->string token-endpoint-uri))
- (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc")))
- (openid-configuration-uri
- (build-uri 'https
- #:host (uri-host issuer)
- #:path "/.well-known/openid-configuration")))
- (lambda (request request-body)
- (let ((uri (request-uri request))
- (current-time ((p:current-date))))
- (parameterize ((web-locale request))
- (cond ((same-uri? uri openid-configuration-uri)
- (let* ((current-sec (time-second (date->time-utc current-time)))
- (exp-sec (+ current-sec 3600))
- (exp (time-utc->date
- (make-time time-utc 0 exp-sec))))
- (serve-oidc-configuration exp openid-configuration)))
- ((same-uri? uri jwks-uri)
- (let* ((current-sec (time-second (date->time-utc current-time)))
- (exp-sec (+ current-sec 3600))
- (exp (time-utc->date
- (make-time time-utc 0 exp-sec))))
- (serve (make <jwks> #:keys (list key)) exp)))
- ((same-uri? uri authorization-endpoint-uri #:skip-query #t)
- (authorization-endpoint request request-body))
- ((same-uri? uri token-endpoint-uri)
- (token-endpoint request request-body))
- ((same-uri? uri subject)
- (values
- (build-response #:headers '((content-type text/turtle))
- #:port #f)
- (format #f
- "@prefix foaf: <http://xmlns.com/foaf/0.1/> .
+ (let ((authorization-endpoint
+ (make-authorization-endpoint subject encrypted-password key 120
+ #:http-get http-get))
+ (token-endpoint
+ (make-token-endpoint token-endpoint-uri issuer key 3600))
+ (openid-configuration
+ `((jwks_uri . ,(uri->string jwks-uri))
+ (authorization_endpoint . ,(uri->string authorization-endpoint-uri))
+ (token_endpoint . ,(uri->string token-endpoint-uri))
+ (solid_oidc_supported . "https://solidproject.org/TR/solid-oidc")))
+ (openid-configuration-uri
+ (build-uri 'https
+ #:host (uri-host issuer)
+ #:path "/.well-known/openid-configuration")))
+ (lambda (request request-body)
+ (let ((uri (request-uri request))
+ (current-time ((p:current-date))))
+ (parameterize ((web-locale request))
+ (cond ((same-uri? uri openid-configuration-uri)
+ (let* ((current-sec (time-second (date->time-utc current-time)))
+ (exp-sec (+ current-sec 3600))
+ (exp (time-utc->date
+ (make-time time-utc 0 exp-sec))))
+ (serve-oidc-configuration exp openid-configuration)))
+ ((same-uri? uri jwks-uri)
+ (let* ((current-sec (time-second (date->time-utc current-time)))
+ (exp-sec (+ current-sec 3600))
+ (exp (time-utc->date
+ (make-time time-utc 0 exp-sec))))
+ (serve (make <jwks> #:keys (list key)) exp)))
+ ((same-uri? uri authorization-endpoint-uri #:skip-query #t)
+ (authorization-endpoint request request-body))
+ ((same-uri? uri token-endpoint-uri)
+ (token-endpoint request request-body))
+ ((same-uri? uri subject)
+ (values
+ (build-response #:headers '((content-type text/turtle))
+ #:port #f)
+ (format #f
+ "@prefix foaf: <http://xmlns.com/foaf/0.1/> .
@prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .
<#~a> a foaf:Person ;
rdfs:comment \"It works. Now you should use another service to serve that resource.\" .
"
- (uri-fragment subject))))
- (else
- (values
- (build-response #:code 404
- #:reason-phrase (W_ "reason-phrase|Not Found")
- #:headers '((content-type application/xhtml+xml)))
- (with-output-to-string
- (lambda ()
- (sxml->xml
- `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
- (html (@ (xmlns "http://www.w3.org/1999/xhtml")
- (xml:lang ,(W_ "xml-lang|en")))
- (body
- ,(sxml-match
- (xml->sxml
- (W_ (format #f "<h1>Resource not found</h1>")))
- ((*TOP* ,title) title))
- ,(sxml-match
- (xml->sxml
- (W_ (format #f "<p>This OpenID Connect identity provider does not know the resource you are requesting.</p>")))
- ((*TOP* ,p) p))))))))))))))))))
+ (uri-fragment subject))))
+ (else
+ (values
+ (build-response #:code 404
+ #:reason-phrase (W_ "reason-phrase|Not Found")
+ #:headers '((content-type application/xhtml+xml)))
+ (with-output-to-string
+ (lambda ()
+ (sxml->xml
+ `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+ (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+ (xml:lang ,(W_ "xml-lang|en")))
+ (body
+ ,(sxml-match
+ (xml->sxml
+ (W_ (format #f "<h1>Resource not found</h1>")))
+ ((*TOP* ,title) title))
+ ,(sxml-match
+ (xml->sxml
+ (W_ (format #f "<p>This OpenID Connect identity provider does not know the resource you are requesting.</p>")))
+ ((*TOP* ,p) p)))))))))))))))))
diff --git a/src/scm/webid-oidc/jwk.scm b/src/scm/webid-oidc/jwk.scm
index e0308cb..f06818d 100644
--- a/src/scm/webid-oidc/jwk.scm
+++ b/src/scm/webid-oidc/jwk.scm
@@ -31,7 +31,7 @@
#:declarative? #t
#:export
(
- <private-key>
+ <private-key> alg
<public-key>
<key-pair> public-key private-key
<rsa-key-pair>
@@ -72,7 +72,8 @@
make-not-a-jwks
not-a-jwks?)
-(define-class <private-key> ())
+(define-class <private-key> ()
+ (alg #:init-keyword #:alg #:accessor alg))
(define-class <public-key> ())
@@ -154,6 +155,12 @@
(define-method (initialize (key <rsa-private-key>) initargs)
(next-method)
+ (let-keywords
+ initargs #t
+ ((alg #f))
+ (when (string? alg)
+ (set! alg (string->symbol alg)))
+ (slot-set! key 'alg (or alg 'RS256)))
(check-key key))
(define-method (initialize (key <rsa-public-key>) initargs)
@@ -166,8 +173,17 @@
(define-method (initialize (key <ec-scalar>) initargs)
(next-method)
+ (let-keywords
+ initargs #t
+ ((alg #f))
+ (when (string? alg)
+ (set! alg (string->symbol alg)))
+ (slot-set! key 'alg (or alg 'ES256)))
(check-key key))
+(define-method (alg (key <key-pair>))
+ (alg (private-key key)))
+
(define-method (rsa-d (key <rsa-key-pair>))
(rsa-d (private-key key)))
@@ -216,7 +232,8 @@
(equal? (rsa-e x) (rsa-e y))))
(define-method (equal? (x <rsa-private-key>) (y <rsa-private-key>))
- (and (equal? (rsa-d x) (rsa-d y))
+ (and (equal? (alg x) (alg y))
+ (equal? (rsa-d x) (rsa-d y))
(equal? (rsa-p x) (rsa-p y))
(equal? (rsa-q x) (rsa-q y))
(equal? (rsa-dp x) (rsa-dp y))
@@ -228,7 +245,8 @@
(equal? (ec-y x) (ec-y y))))
(define-method (equal? (x <ec-scalar>) (y <ec-scalar>))
- (equal? (ec-z x) (ec-z y)))
+ (and (equal? (alg x) (alg y))
+ (equal? (ec-z x) (ec-z y))))
(define (check-and-kty key)
(with-exception-handler
@@ -273,6 +291,7 @@
(define-method (key->jwk (key <rsa-private-key>))
`((kty . ,(symbol->string (kty key)))
+ (alg . ,(symbol->string (alg key)))
(d . ,(rsa-d key))
(p . ,(rsa-p key))
(q . ,(rsa-q key))
@@ -294,6 +313,7 @@
(define-method (key->jwk (key <ec-scalar>))
`((crv . ,(symbol->string (ec-crv key)))
(kty . ,(symbol->string (kty key)))
+ (alg . ,(symbol->string (alg key)))
(z . ,(ec-z key))))
(define-method (check-key key)
@@ -348,7 +368,8 @@
key)
(define (jwk->key fields)
- (let ((kty (stubs:kty fields)))
+ (let ((kty (stubs:kty fields))
+ (alg (assq-ref fields 'alg)))
(let ((explicit-kty (assq-ref fields 'kty)))
(when (and kty explicit-kty (not (eq? kty (string->symbol explicit-kty))))
(raise-exception
@@ -371,7 +392,14 @@
(make <rsa-public-key> #:n n #:e e)))
(private
(and d p q dp dq qi
- (make <rsa-private-key> #:d d #:p p #:q q #:dp dp #:dq dq #:qi qi))))
+ (make <rsa-private-key>
+ #:alg (and alg (string->symbol alg))
+ #:d d
+ #:p p
+ #:q q
+ #:dp dp
+ #:dq dq
+ #:qi qi))))
(if (and public private)
(make <rsa-key-pair> #:public-key public #:private-key private)
(or public private)))))
@@ -385,7 +413,10 @@
(make <ec-point> #:crv crv #:x x #:y y)))
(private
(and z
- (make <ec-scalar> #:crv crv #:z z))))
+ (make <ec-scalar>
+ #:alg (and alg (string->symbol alg))
+ #:crv crv
+ #:z z))))
(if (and public private)
(make <ec-key-pair> #:public-key public #:private-key private)
(or public private)))))
diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm
index e44d946..abef88d 100644
--- a/src/scm/webid-oidc/oidc-id-token.scm
+++ b/src/scm/webid-oidc/oidc-id-token.scm
@@ -18,6 +18,7 @@
#:use-module (webid-oidc oidc-configuration)
#:use-module (webid-oidc errors)
#:use-module (webid-oidc jws)
+ #:use-module (webid-oidc jwk)
#:use-module (webid-oidc jti)
#:use-module (webid-oidc web-i18n)
#:use-module ((webid-oidc stubs) #:prefix stubs:)
@@ -302,7 +303,6 @@
(define* (issue-id-token
issuer-key
#:key
- (alg #f)
(webid #f)
(iss #f)
(sub #f)
@@ -314,7 +314,7 @@
(exp (+ iat validity)))
(jws-encode
(the-id-token
- `(((alg . ,(symbol->string alg)))
+ `(((alg . ,(symbol->string (alg issuer-key))))
. ((webid . ,(uri->string webid))
(iss . ,(uri->string iss))
(sub . ,sub)
diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm
index 30a78d4..81f8e48 100644
--- a/src/scm/webid-oidc/token-endpoint.scm
+++ b/src/scm/webid-oidc/token-endpoint.scm
@@ -177,7 +177,7 @@
port)))))))
thunk))))
-(define (make-token-endpoint token-endpoint-uri iss alg jwk validity)
+(define (make-token-endpoint token-endpoint-uri iss jwk validity)
(lambda (request request-body)
(when (bytevector? request-body)
(set! request-body (utf8->string request-body)))
@@ -290,7 +290,6 @@
(let ((id-token
(issue-id-token
jwk
- #:alg alg
#:webid webid
#:sub (uri->string webid)
#:iss iss
@@ -299,7 +298,6 @@
(access-token
(issue-access-token
jwk
- #:alg alg
#:webid webid
#:iss iss
#:validity 3600
generated by cgit v1.2.3 (git 2.44.0) at 2024-07-01 16:45:04 +0000