diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-20 11:25:29 +0200 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2021-09-21 22:28:51 +0200 |
commit | e910b3ba2ded990a5193f7ea0cfad525332e4171 (patch) | |
tree | b04e74e7c06e0a0fde5edd7ac0b8773db94cd515 /src | |
parent | dcd329af1ec765ca0fac97ef2dc18a3177d34083 (diff) |
JWS: use GOOPS
Diffstat (limited to 'src')
-rw-r--r-- | src/scm/webid-oidc/access-token.scm | 410 | ||||
-rw-r--r-- | src/scm/webid-oidc/authorization-code.scm | 255 | ||||
-rw-r--r-- | src/scm/webid-oidc/authorization-endpoint.scm | 2 | ||||
-rw-r--r-- | src/scm/webid-oidc/client.scm | 11 | ||||
-rw-r--r-- | src/scm/webid-oidc/client/accounts.scm | 26 | ||||
-rw-r--r-- | src/scm/webid-oidc/dpop-proof.scm | 475 | ||||
-rw-r--r-- | src/scm/webid-oidc/example-app.scm | 1 | ||||
-rw-r--r-- | src/scm/webid-oidc/jws.scm | 481 | ||||
-rw-r--r-- | src/scm/webid-oidc/oidc-id-token.scm | 361 | ||||
-rw-r--r-- | src/scm/webid-oidc/resource-server.scm | 28 | ||||
-rw-r--r-- | src/scm/webid-oidc/token-endpoint.scm | 45 |
11 files changed, 914 insertions, 1181 deletions
diff --git a/src/scm/webid-oidc/access-token.scm b/src/scm/webid-oidc/access-token.scm index 7e67270..7c23126 100644 --- a/src/scm/webid-oidc/access-token.scm +++ b/src/scm/webid-oidc/access-token.scm @@ -29,7 +29,17 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 exceptions) + #:use-module (ice-9 receive) + #:use-module (oop goops) #:declarative? #t + #:re-export + ( + alg iat exp iss + token->jwt + decode + encode + issue + ) #:export ( @@ -37,21 +47,7 @@ make-invalid-access-token invalid-access-token? - the-access-token - access-token? - - access-token-alg - - access-token-webid - access-token-iss - access-token-aud - access-token-iat - access-token-exp - access-token-client-id - access-token-cnf/jkt - - access-token-decode - issue-access-token + <access-token> webid aud client-id cnf/jkt )) (define-exception-type @@ -60,289 +56,109 @@ make-invalid-access-token invalid-access-token?) -;; The order is meaningful in this module, the-access-token reorders -;; them. -(define (the-access-token x) - (with-exception-handler - (lambda (error) - (let ((final-message - (cond - ((invalid-jws? error) - (if (exception-with-message? error) - (format #f (G_ "this is not an access token, because it is not even a JWS: ~a") - (exception-message error)) - (format #f (G_ "this is not an access token, because it is not even a JWS")))) - (else - (if (exception-with-message? error) - (format #f (G_ "this is not an access token: ~a") - (exception-message error)) - (format #f (G_ "this is not an access token"))))))) - (raise-exception - (make-exception - (make-invalid-access-token) - (make-exception-with-message final-message) - error)))) - (lambda () - (match (the-jws x) - ((header . payload) - (let examine-payload ((payload payload) - (webid #f) - (iss #f) - (aud #f) - (iat #f) - (exp #f) - (cnf #f) - (client-id #f) - (other-fields '())) - (match payload - (() - (unless (and webid iss aud iat exp cnf client-id) - ;; Missing some things - (fail (format #f (G_ "the payload is missing ~s") - `(,@(if webid '() '("webid")) - ,@(if iss '() '("iss")) - ,@(if aud '() '("aud")) - ,@(if iat '() '("iat")) - ,@(if exp '() '("exp")) - ,@(if cnf '() '("cnf")) - ,@(if client-id '() '("client_id")))))) - `(,header - . ((webid . ,(uri->string webid)) - (iss . ,(uri->string iss)) - (aud . "solid") - (iat . ,(time-second (date->time-utc iat))) - (exp . ,(time-second (date->time-utc exp))) - (client_id . ,(uri->string client-id)) - (cnf . ,cnf) - ,@(reverse other-fields)))) - ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...) - (examine-payload payload - (or webid webid-given) - iss aud iat exp cnf client-id other-fields)) - ((('webid . infringing) payload ...) - (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given") - infringing))) - ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...) - (examine-payload payload webid - (or iss iss-given) - aud iat exp cnf client-id other-fields)) - ((('iss . infringing) payload ...) - (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given") - infringing))) - ((('aud . "solid") payload ...) - (examine-payload payload webid iss #t iat exp cnf client-id other-fields)) - ((('aud . infringing) payload ...) - (fail (format #f (G_ "the \"aud\" field should be set to \"solid\", ~s is given") - infringing))) - ((('iat . (? (cute >= <> 0) (? integer? iat-given))) payload ...) - (examine-payload payload webid iss aud - (or iat (time-utc->date (make-time time-utc 0 iat-given))) - exp cnf client-id other-fields)) - ((('iat . infringing) payload ...) - (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given") - infringing))) - ((('exp . (? (cute >= <> 0) (? integer? exp-given))) payload ...) - (examine-payload payload webid iss aud iat - (or exp (time-utc->date (make-time time-utc 0 exp-given))) - cnf client-id other-fields)) - ((('exp . infringing) payload ...) - (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given") - infringing))) - ((('cnf . cnf) payload ...) - (let examine-cnf ((data cnf) - (jkt #f) - (other-cnf-fields '())) - (match data - (() - (unless jkt - (fail (format #f (G_ "the \"cnf\" / \"jkt\" field is missing")))) - (examine-payload payload webid iss aud iat exp - `((jkt . ,jkt) - ,@(reverse other-cnf-fields)) - client-id other-fields)) - ((('jkt . (? string? jkt-given)) data ...) - (examine-cnf data (or jkt jkt-given other-cnf-fields) other-cnf-fields)) - ((('jkt . infringing) _ ...) - (fail (format #f (G_ "the \"cnf\" / \"jkt\" field should be a string, ~s is given") - infringing))) - ((field data ...) - (examine-cnf data jkt `(,field ,@other-cnf-fields))) - (data - (fail (format #f (G_ "the \"cnf\" field should be an object, ~s is given") - data)))))) - ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...) - (examine-payload payload webid iss aud iat exp cnf - (or client-id client-id-given) - other-fields)) - ((('client_id . infringing) payload ...) - (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given") - infringing))) - ((field payload ...) - (examine-payload payload webid iss aud iat exp cnf client-id - `(,field ,@other-fields)))))) - (else - (scm-error 'wrong-type-arg "the-access-token" - "expected a pair of lists" - '() - (list x))))))) - -(define (access-token? x) - (false-if-exception (the-access-token x))) - -(define (access-token-alg code) - (match (the-access-token code) - ((header . _) - (string->symbol (assq-ref header 'alg))))) - -(define (access-token-webid code) - (match (the-access-token code) - ((_ . payload) - (string->uri (assq-ref payload 'webid))))) - -(define (access-token-iss code) - (match (the-access-token code) - ((_ . payload) - (string->uri (assq-ref payload 'iss))))) +(define-class <access-token> (<time-bound-token> <oidc-token>) + (webid #:init-keyword #:webid #:accessor webid) + (aud #:init-keyword #:aud #:accessor aud) + (client-id #:init-keyword #:client-id #:accessor client-id) + (cnf/jkt #:init-keyword #:cnf/jkt #:accessor cnf/jkt)) -(define (access-token-aud code) - (match (the-access-token code) - ((_ . payload) - (assq-ref payload 'aud)))) - -(define (access-token-iat code) - (match (the-access-token code) - ((_ . payload) - (time-utc->date - (make-time time-utc 0 (assq-ref payload 'iat)))))) - -(define (access-token-exp code) - (match (the-access-token code) - ((_ . payload) - (time-utc->date - (make-time time-utc 0 (assq-ref payload 'exp)))))) - -(define (access-token-client-id code) - (match (the-access-token code) - ((_ . payload) - (string->uri (assq-ref payload 'client-id))))) - -(define (access-token-cnf/jkt code) - (match (the-access-token code) - ((_ . payload) - (assq-ref (assq-ref payload 'cnf) 'jkt)))) - -(define* (access-token-decode str #:key (http-get http-get)) +(define-method (initialize (token <access-token>) initargs) (with-exception-handler (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the access token is invalid: ~a") - (exception-message error)) - (format #f (G_ "the access token is invalid"))))) - (raise-exception - (make-exception - (make-invalid-access-token) - (make-exception-with-message final-message) - error)))) + (raise-exception + (make-exception + (make-invalid-access-token) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "invalid access token: ~a") + (exception-message error)) + (G_ "invalid access token"))) + error))) (lambda () - (jws-decode - str - (lambda (token) - (let* ((iss (access-token-iss token)) - (cfg - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "I cannot query the identity provider configuration: ~a") - (exception-message error)) - (format #f (G_ "I cannot query the identity provider configuratioon"))))) - (raise-exception - (make-exception - (make-cannot-query-identity-provider iss) - (make-exception-with-message final-message) - error)))) - (lambda () - (get-oidc-configuration - (uri-host iss) - #:userinfo (uri-userinfo iss) - #:port (uri-port iss) - #:http-get http-get)))) - (jwks - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "I cannot query the identity provider public keys: ~a") - (exception-message error)) - (format #f (G_ "I cannot query the identity provider public keys"))))) - (raise-exception - (make-exception - (make-cannot-query-identity-provider iss) - (make-exception-with-message final-message) - error)))) - (lambda () - (oidc-configuration-jwks cfg #:http-get http-get))))) - (let ((iat (access-token-iat token)) - (exp (access-token-exp token)) - (current-date ((p:current-date)))) - (let ((iat-s (time-second (date->time-utc iat))) - (exp-s (time-second (date->time-utc exp))) - (current-s (time-second (date->time-utc current-date)))) - (when (>= iat-s (+ current-s 5)) - (let ((final-message - (format #f (G_ "the access token is signed in the future, ~a, relative to current ~a") - (date->string iat) - (date->string current-date)))) - (raise-exception - (make-exception - (make-signed-in-future iat current-date) - (make-exception-with-message final-message))))) - (when (>= current-s exp-s) - (let ((final-message - (format #f (G_ "the access token expired ~a, which is in the past (from ~a)") - (date->string exp) - (date->string current-date)))) - (raise-exception - (make-exception - (make-expired exp current-date) - (make-exception-with-message final-message))))))) - jwks)))))) - -(define (access-token-encode access-token key) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "cannot encode the access token: ~a") - (exception-message error)) - (format #f (G_ "cannot encode the access token"))))) - (raise-exception - (make-exception-with-message final-message)))) - (lambda () - (jws-encode access-token key)))) - -(define* (issue-access-token - issuer-key - #:key - (webid #f) - (iss #f) - (validity 3600) - (client-key #f) - (cnf/jkt #f) - (client-id #f)) - (when client-key - (set! cnf/jkt (jkt client-key))) - (let* ((iat (time-second (date->time-utc ((p:current-date))))) - (exp (+ iat validity))) - (jws-encode - (the-access-token - `(((alg . ,(symbol->string (alg issuer-key)))) - . ((webid . ,(uri->string webid)) - (iss . ,(uri->string iss)) - (aud . "solid") - (iat . ,iat) - (exp . ,exp) - (cnf . ((jkt . ,cnf/jkt))) - (client_id . ,(uri->string client-id))))) - issuer-key))) + (next-method) + (let-keywords + initargs #t + ((webid #f) + (aud "solid") + (client-id #f) + (cnf/jkt #f) + (client-key #f) + (jwt-header #f) + (jwt-payload #f)) + (let do-initialize ((webid webid) + (aud aud) + (client-id client-id) + (cnf/jkt cnf/jkt) + (client-key client-key) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((string? webid) + (do-initialize (string->uri webid) + aud + client-id + cnf/jkt + client-key + jwt-header + jwt-payload)) + ((string? client-id) + (do-initialize webid + aud + (string->uri client-id) + cnf/jkt + client-key + jwt-header + jwt-payload)) + ((and (not cnf/jkt) client-key) + (do-initialize webid aud client-id (jkt client-key) #f jwt-header jwt-payload)) + ((and webid client-id cnf/jkt) + (unless (uri? webid) + (scm-error 'wrong-type-arg "make" + (G_ "#:webid should be an URI") + '() + (list webid))) + (unless (uri? client-id) + (scm-error 'wrong-type-arg "make" + (G_ "#:client-id should be an URI") + '() + (list client-id))) + (unless (string? cnf/jkt) + (scm-error 'wrong-type-arg "make" + (G_ "#:cnf/jkt should be a string") + '() + (list cnf/jkt))) + (unless (equal? aud "solid") + (scm-error 'wrong-type-arg "make" + (G_ "#:aud should be exactly \"solid\"") + '() + (list aud))) + (slot-set! token 'webid webid) + (slot-set! token 'aud aud) + (slot-set! token 'client-id client-id) + (slot-set! token 'cnf/jkt cnf/jkt)) + ((and jwt-header jwt-payload) + (do-initialize (assq-ref jwt-payload 'webid) + (assq-ref jwt-payload 'aud) + (assq-ref jwt-payload 'client_id) + (assq-ref (assq-ref jwt-payload 'cnf) 'jkt) + #f #f #f)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (G_ "when making an access token either its required fields (#:alg, #:webid, #:iss, #:aud, #:client-id, #:cnf/jkt, #:iat and #:exp) or (#:jwt-header and #:jwt-payload) should be passed"))))))))))) + +(define-method (token->jwt (token <access-token>)) + (receive (base-header base-payload) + (next-method) + (values + base-header + `((webid . ,(uri->string (webid token))) + (iss . ,(uri->string (iss token))) + (aud . ,(aud token)) + (client_id . ,(uri->string (client-id token))) + (cnf . ((jkt . ,(cnf/jkt token)))) + (iat . ,(time-second (date->time-utc (iat token)))) + (exp . ,(time-second (date->time-utc (exp token)))) + ,@base-payload)))) diff --git a/src/scm/webid-oidc/authorization-code.scm b/src/scm/webid-oidc/authorization-code.scm index 1481b2c..13b7ac4 100644 --- a/src/scm/webid-oidc/authorization-code.scm +++ b/src/scm/webid-oidc/authorization-code.scm @@ -26,7 +26,18 @@ #:use-module (webid-oidc web-i18n) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) + #:use-module (ice-9 receive) + #:use-module (ice-9 optargs) + #:use-module (oop goops) #:declarative? #t + #:re-export + ( + alg iat exp nonce + token->jwt + decode + encode + issue + ) #:export ( @@ -34,18 +45,7 @@ make-invalid-authorization-code invalid-authorization-code? - the-authorization-code - authorization-code? - - authorization-code-alg - - authorization-code-webid - authorization-code-client-id - authorization-code-jti - authorization-code-exp - - authorization-code-decode - issue-authorization-code + <authorization-code> webid client-id )) (define-exception-type @@ -54,171 +54,74 @@ make-invalid-authorization-code invalid-authorization-code?) -(define (the-authorization-code x) - (with-exception-handler - (lambda (error) - (let ((final-message - (cond - ((invalid-jws? error) - (if (exception-with-message? error) - (format #f (G_ "this is not an authorization code, because it is not even a JWS: ~a") - (exception-message error)) - (format #f (G_ "this is not an authorization code, because it is not even a JWS")))) - (else - (if (exception-with-message? error) - (format #f (G_ "this is not an authorization code: ~a") - (exception-message error)) - (format #f (G_ "this is not an authorization code"))))))) - (raise-exception - (make-exception - (make-invalid-authorization-code) - (make-exception-with-message final-message) - error)))) - (lambda () - (match (the-jws x) - ((header . payload) - (let examine-payload ((payload payload) - (webid #f) - (client-id #f) - (jti #f) - (exp #f) - (other-fields '())) - (match payload - (() - (unless (and webid client-id jti exp) - (fail (format #f (G_ "the payload is missing ~s") - `(,@(if webid '() '("webid")) - ,@(if client-id '() '("client_id")) - ,@(if jti '() '("jti")) - ,@(if exp '() '("exp")))))) - `(,header - . ((webid . ,(uri->string webid)) - (client_id . ,(uri->string client-id)) - (jti . ,jti) - (exp . ,(time-second (date->time-utc exp))) - ,@(reverse other-fields)))) - ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...) - (examine-payload payload - (or webid webid-given) - client-id jti exp other-fields)) - ((('webid . infringing) payload ...) - (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given") - infringing))) - ((('client_id . (? string? (= string->uri (? uri? client-id-given)))) payload ...) - (examine-payload payload webid - (or client-id client-id-given) - jti exp other-fields)) - ((('client_id . infringing) payload ...) - (fail (format #f (G_ "the \"client_id\" field should be an URI, ~s is given") - infringing))) - ((('jti . (? string? jti-given)) payload ...) - (examine-payload payload webid client-id - (or jti jti-given) - exp other-fields)) - ((('jti . invalid) payload ...) - (fail (format #f (G_ "the \"jti\" field should be a string, ~s is given") - invalid))) - ((('exp . (? (lambda (x) (and (integer? x) (>= x 0))) exp-given)) payload ...) - (examine-payload payload webid client-id jti - (or exp (time-utc->date (make-time time-utc 0 exp-given))) - other-fields)) - ((('exp . infringing) payload ...) - (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given") - infringing))) - ((field payload ...) - (examine-payload payload webid client-id jti exp `(,field ,@other-fields)))))) - (else - (scm-error 'wrong-type-arg "the-authorization-code" - "expected a pair of lists" - '() - (list x))))))) - -(define (authorization-code? x) - (false-if-exception (the-authorization-code x))) +(define-class <authorization-code> (<single-use-token>) + (webid #:init-keyword #:webid #:accessor webid) + (client-id #:init-keyword #:client-id #:accessor client-id)) -(define (authorization-code-alg x) - (match (the-authorization-code x) - ((header . _) - (string->symbol (assq-ref header 'alg))))) - -(define (authorization-code-webid x) - (match (the-authorization-code x) - ((_ . payload) - (string->uri (assq-ref payload 'webid))))) - -(define (authorization-code-client-id x) - (match (the-authorization-code x) - ((_ . payload) - (string->uri (assq-ref payload 'client_id))))) - -(define (authorization-code-jti x) - (match (the-authorization-code x) - ((_ . payload) - (assq-ref payload 'jti)))) - -(define (authorization-code-exp x) - (match (the-authorization-code x) - ((_ . payload) - (time-utc->date (make-time time-utc 0 (assq-ref payload 'exp)))))) - -(define (authorization-code-decode str jwk) - (parameterize ((p:current-date - (time-second (date->time-utc ((p:current-date)))))) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the authorization code is invalid: ~a") - (exception-message error)) - (format #f (G_ "the authorization code is invalid"))))) - (raise-exception - (make-exception - (make-invalid-authorization-code) - (make-exception-with-message final-message) - error)))) - (lambda () - (let ((code (the-authorization-code (jws-decode str (lambda (x) jwk))))) - (let ((exp (authorization-code-exp code)) - (current-date ((p:current-date)))) - (let ((exp-s (time-second (date->time-utc exp))) - (current-s (time-second (date->time-utc current-date)))) - (when (>= current-s exp-s) - (let ((final-message - (format #f (G_ "the authorization expired ~a, which is in the past (from ~a)") - (date->string exp) - (date->string current-date)))) - (raise-exception - (make-exception - (make-expired exp current-date) - (make-exception-with-message final-message))))) - (jti-check (authorization-code-jti code) - (- exp-s current-s)) - code))))))) - -(define (authorization-code-encode authorization-code key) +(define-method (initialize (token <authorization-code>) initargs) (with-exception-handler (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "cannot encode the authorization code: ~a") - (exception-message error)) - (format #f (G_ "cannot encode the authorization code"))))) - (raise-exception - (make-exception-with-message final-message)))) + (raise-exception + (make-exception + (make-invalid-authorization-code) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "invalid authorization code: ~a") + (exception-message error)) + (G_ "invalid authorization code"))) + error))) (lambda () - (jws-encode authorization-code key)))) - -(define* (issue-authorization-code issuer-key - #:key - (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 issuer-key)))) - . ((webid . ,(uri->string webid)) - (client_id . ,(uri->string client-id)) - (exp . ,exp) - (jti . ,(stubs:random 12)))) - issuer-key))) + (next-method) + (let-keywords + initargs #t + ((webid #f) + (client-id #f) + (jwt-header #f) + (jwt-payload #f)) + (let do-initialize ((webid webid) + (client-id client-id) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((string? webid) + (do-initialize (string->uri webid) client-id jwt-header jwt-payload)) + ((string? client-id) + (do-initialize webid (string->uri client-id) jwt-header jwt-payload)) + ((and webid client-id) + (unless (uri? webid) + (scm-error 'wrong-type-arg "make" + (G_ "#:webid should be an URI") + '() + (list webid))) + (unless (uri? client-id) + (scm-error 'wrong-type-arg "make" + (G_ "#:client-id should be a string") + '() + (list client-id))) + (slot-set! token 'webid webid) + (slot-set! token 'client-id client-id)) + ((and jwt-header jwt-payload) + (do-initialize (assq-ref jwt-payload 'webid) + (assq-ref jwt-payload 'client_id) + #f #f)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (G_ "when making an authorization code either its required fields (#:webid and #:client-id) or (#:jwt-header and #:jwt-payload) should be passed"))))))))))) + +(define-method (token->jwt (token <authorization-code>)) + (receive (base-header base-payload) + (next-method) + (values + base-header + `((webid . ,(uri->string (webid token))) + (client_id . ,(uri->string (client-id token))) + ,@base-payload)))) + +(define-method (lookup-keys (token <authorization-code>) args) + (let-keywords + args #f + ((issuer-key #f)) + issuer-key)) diff --git a/src/scm/webid-oidc/authorization-endpoint.scm b/src/scm/webid-oidc/authorization-endpoint.scm index cf45a9c..4f171a2 100644 --- a/src/scm/webid-oidc/authorization-endpoint.scm +++ b/src/scm/webid-oidc/authorization-endpoint.scm @@ -106,7 +106,7 @@ (lambda (error) (error-application locale error)) (lambda () - (let ((code (issue-authorization-code + (let ((code (issue <authorization-code> jwk #:webid subject #:client-id client-id)) diff --git a/src/scm/webid-oidc/client.scm b/src/scm/webid-oidc/client.scm index 5b6b0ef..006c86a 100644 --- a/src/scm/webid-oidc/client.scm +++ b/src/scm/webid-oidc/client.scm @@ -137,11 +137,12 @@ (let* ((access-token (account:access-token account)) (dpop-proof (let ((key-pair (account:key-pair account))) - (issue-dpop-proof - key-pair - #:htm method - #:htu uri - #:access-token access-token)))) + (issue <dpop-proof> + key-pair + #:jwk (public-key key-pair) + #:htm method + #:htu uri + #:access-token access-token)))) (let ((all-headers `((dpop . ,dpop-proof) (authorization . (dpop . ,access-token)) diff --git a/src/scm/webid-oidc/client/accounts.scm b/src/scm/webid-oidc/client/accounts.scm index ddb592a..3591b52 100644 --- a/src/scm/webid-oidc/client/accounts.scm +++ b/src/scm/webid-oidc/client/accounts.scm @@ -27,12 +27,13 @@ #:use-module (srfi srfi-19) #:use-module (webid-oidc errors) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc jws) #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc oidc-id-token) #:prefix id:) #:use-module ((webid-oidc oidc-configuration) #:prefix cfg:) #:use-module ((webid-oidc jwk) #:prefix jwk:) - #:use-module ((webid-oidc dpop-proof) #:prefix dpop:) + #:use-module (webid-oidc dpop-proof) #:use-module ((webid-oidc client client) #:prefix client:) #:use-module (web uri) #:use-module (web response) @@ -87,6 +88,7 @@ #:declarative? #t) (define <jwk:key-pair> jwk:<key-pair>) +(define <id:id-token> id:<id-token>) ;; This exception is continuable! Continue with the authorization ;; code. @@ -253,10 +255,11 @@ (unless key-pair (set! key-pair (client:client-key-pair client))) (let ((dpop-proof - (dpop:issue-dpop-proof - key-pair - #:htm 'POST - #:htu token-endpoint))) + (issue <dpop-proof> + key-pair + #:jwk (jwk:public-key key-pair) + #:htm 'POST + #:htu token-endpoint))) (receive (response response-body) ((anonymous-http-request) token-endpoint #:method 'POST @@ -368,25 +371,24 @@ decoding-error)))) (lambda () (set! id-token - (id:id-token-decode id-token - #:http-get - (http-request->http-get (anonymous-http-request)))))) + (decode <id:id-token> id-token + #:http-request (anonymous-http-request))))) ;; We are not interested in the ID token ;; signature anymore, because it won’t be ;; transmitted to other parties and we know that ;; it is valid. (when (and subject - (not (equal? subject (id:id-token-webid id-token)))) + (not (equal? subject (id:webid id-token)))) (let ((final-message (format #f (G_ "the ID token delivered by the identity provider for ~s has ~s as webid") (uri->string subject) - (id:id-token-webid id-token)))) + (id:webid id-token)))) (raise-exception (make-exception (make-token-request-failed response response-body) (make-exception-with-message final-message))))) - (set! subject (id:id-token-webid id-token)) - (when (not (equal? issuer (id:id-token-iss id-token))) + (set! subject (id:webid id-token)) + (when (not (equal? issuer (iss id-token))) (let ((final-message (format #f (G_ "The ID token delivered by the identity provider ~s is for issuer ~s.") (uri->string issuer) diff --git a/src/scm/webid-oidc/dpop-proof.scm b/src/scm/webid-oidc/dpop-proof.scm index 8c66f68..318ebb8 100644 --- a/src/scm/webid-oidc/dpop-proof.scm +++ b/src/scm/webid-oidc/dpop-proof.scm @@ -26,10 +26,19 @@ #:use-module (ice-9 optargs) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) + #:use-module (ice-9 receive) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (oop goops) #:declarative? #t + #:re-export + ( + alg iat exp nonce (nonce . jti) + token->jwt + decode + encode + issue + ) #:export ( @@ -37,19 +46,6 @@ make-invalid-dpop-proof invalid-dpop-proof? - the-dpop-proof - dpop-proof? - - dpop-proof-alg - dpop-proof-typ - dpop-proof-jwk - - dpop-proof-jti - dpop-proof-htm - dpop-proof-htu - dpop-proof-iat - dpop-proof-ath - &dpop-method-mismatch make-dpop-method-mismatch dpop-method-mismatch? @@ -72,8 +68,7 @@ make-dpop-unconfirmed-key dpop-unconfirmed-key? - dpop-proof-decode - issue-dpop-proof + <dpop-proof> typ jwk htm htu ath )) (define-exception-type @@ -82,172 +77,6 @@ make-invalid-dpop-proof invalid-dpop-proof?) -(define (parse-jwk data) - (false-if-exception - (jwk->key data))) - -(define (the-dpop-proof x) - (with-exception-handler - (lambda (error) - (let ((final-message - (cond - ((invalid-jws? error) - (if (exception-with-message? error) - (format #f (G_ "this is not a DPoP proof, because it is not even a JWS: ~a") - (exception-message error)) - (format #f (G_ "this is not a DPoP proof, because it is not even a JWS")))) - (else - (if (exception-with-message? error) - (format #f (G_ "this is not an access token: ~a") - (exception-message error)) - (format #f (G_ "this is not an access token"))))))) - (raise-exception - (make-exception - (make-invalid-dpop-proof) - (make-exception-with-message final-message) - error)))) - (lambda () - (match (the-jws x) - ((header . payload) - (let examine-header ((header header) - (alg #f) - (typ #f) - (jwk #f) - (other-header-fields '())) - (match header - (() - (let examine-payload ((payload payload) - (jti #f) - (htm #f) - (htu #f) - (iat #f) - (ath #f) - (other-payload-fields '())) - (match payload - (() - (unless (and alg typ jwk jti htm htu iat) - (fail (format #f (G_ "the DPoP proof is missing ~s") - `(,@(if alg '() '("alg")) - ,@(if typ '() '("typ")) - ,@(if jwk '() '("jwk")) - ,@(if jti '() '("jti")) - ,@(if htm '() '("htm")) - ,@(if htu '() '("htu")) - ,@(if iat '() '("iat")))))) - `(((alg . ,(symbol->string alg)) - (typ . "dpop+jwt") - (jwk . ,(key->jwk (public-key jwk))) - ,@other-header-fields) - . ((jti . ,jti) - (htm . ,(symbol->string htm)) - (htu . ,(uri->string htu)) - (iat . ,(time-second (date->time-utc iat))) - ,@(if ath `((ath . ,ath)) '()) - ,@other-payload-fields))) - ((('jti . (? string? given-jti)) payload ...) - (examine-payload payload - (or jti given-jti) htm htu iat ath - other-payload-fields)) - ((('jti . incorrect) payload ...) - (fail (format #f (G_ "the \"jti\" field should be a string, not ~s") - incorrect))) - ((('htm . (? string? given-htm)) payload ...) - (examine-payload payload jti - (or htm (string->symbol given-htm)) - htu iat ath other-payload-fields)) - ((('htm . incorrect) payload ...) - (fail (format #f (G_ "the \"htm\" field should be a string, not ~s") - incorrect))) - ((('htu . (? string? (= string->uri (? uri? given-htu)))) payload ...) - (examine-payload payload jti htm - (or htu given-htu) - iat ath other-payload-fields)) - ((('htu . incorrect) payload ...) - (fail (format #f (G_ "the \"htu\" field should be an URI, not ~s") - incorrect))) - ((('iat . (? (cute >= <> 0) (? integer? given-iat))) payload ...) - (examine-payload payload jti htm htu - (or iat (time-utc->date (make-time time-utc 0 given-iat))) - ath other-payload-fields)) - ((('iat . incorrect) payload ...) - (fail (format #f (G_ "the \"iat\" field should be a timestamp, not ~s") - incorrect))) - ((('ath . (? string? given-ath)) payload ...) - (examine-payload payload jti htm htu iat - (or ath given-ath) - other-payload-fields)) - ((('ath . incorrect) payload ...) - (fail (format #f (G_ "the \"ath\" field should be an encoded JWT, not ~s") - incorrect))) - ((field payload ...) - (examine-payload payload jti htm htu iat ath - `(,field ,@other-payload-fields)))))) - ((('alg . (? string? given-alg)) header ...) - (examine-header header (or alg (string->symbol given-alg)) - typ jwk other-header-fields)) - ((('alg . incorrect) header ...) - (fail (format #f (G_ "the \"alg\" field should be a string, not ~s") - incorrect))) - ((('typ . "dpop+jwt") header ...) - (examine-header header alg #t jwk other-header-fields)) - ((('typ . incorrect) header ...) - (fail (format #f (G_ "the \"typ\" field should be \"dpop+jwt\", not ~s") - incorrect))) - ((('jwk . (= parse-jwk (? (cute is-a? <> <public-key>) given-jwk))) header ...) - (examine-header header alg typ (or jwk given-jwk) - other-header-fields)) - ((('jwk . (= parse-jwk (? (cute is-a? <> <key-pair>) given-jwk))) header ...) - (fail (format #f (G_ "the \"jwk\" field should not contain the private key")))) - ((('jwk . incorrect) header ...) - (fail (format #f (G_ "the \"jwk\" field should be a valid public key, not ~s") - incorrect))) - ((field header ...) - (examine-header header alg typ jwk `(,field ,@other-header-fields)))))))))) - -(define (dpop-proof? x) - (false-if-exception (the-dpop-proof x))) - -(define (dpop-proof-alg proof) - (match (the-dpop-proof proof) - ((header . _) - (symbol->string (assq-ref header 'alg))))) - -(define (dpop-proof-typ proof) - (match (the-dpop-proof proof) - ((header . _) - (assq-ref header 'typ)))) - -(define (dpop-proof-jwk proof) - (match (the-dpop-proof proof) - ((header . _) - (jwk->key (assq-ref header 'jwk))))) - -(define (dpop-proof-jti proof) - (match (the-dpop-proof proof) - ((_ . payload) - (assq-ref payload 'jti)))) - -(define (dpop-proof-htm proof) - (match (the-dpop-proof proof) - ((_ . payload) - (string->symbol (assq-ref payload 'htm))))) - -(define (dpop-proof-htu proof) - (match (the-dpop-proof proof) - ((_ . payload) - (string->uri (assq-ref payload 'htu))))) - -(define (dpop-proof-iat proof) - (match (the-dpop-proof proof) - ((_ . payload) - (time-utc->date - (make-time time-utc 0 (assq-ref payload 'iat)))))) - -(define (dpop-proof-ath proof) - (match (the-dpop-proof proof) - ((_ . payload) - (assq-ref payload 'ath)))) - (define-exception-type &dpop-method-mismatch &external-error @@ -299,129 +128,169 @@ make-dpop-unconfirmed-key dpop-unconfirmed-key?) -(define* (dpop-proof-decode method uri str cnf/check - #:key - (access-token #f)) - (let* ((current-date ((p:current-date))) - (current-time - (time-second (date->time-utc current-date)))) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the DPoP proof cannot be decoded: ~a") - (exception-message error)) - (format #f (G_ "the DPoP proof cannot be decoded"))))) - (raise-exception - (make-exception - (make-invalid-dpop-proof) - (make-exception-with-message final-message) - error)))) - (lambda () - (let ((decoded (the-dpop-proof (jws-decode str dpop-proof-jwk)))) - (unless (eq? method (dpop-proof-htm decoded)) - (let ((final-message - (format #f (G_ "the DPoP proof is signed for access through ~s, but it is used with ~s") - (dpop-proof-htm decoded) method))) - (raise-exception - (make-exception - (make-dpop-method-mismatch (dpop-proof-htm decoded) method) - (make-exception-with-message final-message))))) - (uris-compatible (dpop-proof-htu decoded) - (if (string? uri) - (string->uri uri) - uri)) - (let ((iat (dpop-proof-iat decoded))) - (let ((iat-s (time-second (date->time-utc iat)))) - (unless (>= current-time (- iat-s 5)) - (let ((final-message - (format #f (G_ "the DPoP proof is signed in the future, ~a, relative to the current date, ~a") - (date->string iat) - (date->string current-date)))) - (raise-exception - (make-exception - (make-signed-in-future iat current-date) - (make-exception-with-message final-message))))) - (unless (<= current-time (+ iat-s 120)) ;; valid for 2 minutes - (let ((final-message - (format #f (G_ "the DPoP proof is too old, it was signed ~a and now it is ~a") - (date->string iat) - (date->string current-date)))) - (raise-exception - (make-exception - (make-expired (time-utc->date (make-time time-utc 0 (+ iat-s 120))) - current-date) - (make-exception-with-message final-message))))))) - (when access-token - (let ((h (stubs:hash 'SHA-256 access-token))) - (unless (equal? (dpop-proof-ath decoded) h) - (let ((final-message - (format #f (G_ "the DPoP proof should go along with an access token hashed to ~s, not ~s") - (dpop-proof-ath decoded) access-token))) - (raise-exception - (make-exception - (make-dpop-invalid-ath (dpop-proof-ath decoded) access-token) - (make-exception-with-message final-message))))))) - (if (string? cnf/check) - (unless (equal? cnf/check (jkt (dpop-proof-jwk decoded))) - (let ((final-message - (format #f (G_ "the DPoP proof is signed with the wrong key")))) - (raise-exception - (make-exception - (make-dpop-unconfirmed-key) - (make-exception-with-message final-message))))) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the DPoP proof is signed with the wrong key: ~a") - (exception-message error)) - (format #f (G_ "the DPoP proof is signed with the wrong key"))))) - (raise-exception - (make-exception - (make-dpop-unconfirmed-key) - (make-exception-with-message final-message) - error)))) - (lambda () - (unless (cnf/check (jkt (dpop-proof-jwk decoded))) - ;; You should throw an error instead! - (fail (G_ "the cnf/check function returned #f")))))) - (parameterize ((p:current-date current-date)) - ;; jti-check should use the same date. - (jti-check (dpop-proof-jti decoded) 120)) - decoded))))) +(define-class <dpop-proof> (<single-use-token>) + (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)) + +(define-method (default-validity (proof <dpop-proof>)) + 30) + +(define-method (has-explicit-exp? (proof <dpop-proof>)) + #f) -(define (dpop-proof-encode dpop-proof key) +(define-method (nonce-field-name (proof <dpop-proof>)) + 'jti) + +(define-method (initialize (token <dpop-proof>) initargs) (with-exception-handler (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "cannot encode a DPoP proof: ~a") - (exception-message error)) - (format #f (G_ "cannot encode a DPoP proof"))))) - (raise-exception - (make-exception - (make-exception-with-message final-message) - error)))) + (raise-exception + (make-exception + (make-invalid-dpop-proof) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "invalid DPoP proof: ~a") + (exception-message error)) + (G_ "invalid DPoP proof token"))) + error))) (lambda () - (jws-encode dpop-proof key)))) - -(define* (issue-dpop-proof - client-key - #:key - (htm #f) - (htu #f) - (access-token #f)) - (dpop-proof-encode - (the-dpop-proof - `(((alg . ,(symbol->string (alg client-key))) - (typ . "dpop+jwt") - (jwk . ,(key->jwk (public-key client-key)))) - . ((jti . ,(stubs:random 12)) - (htm . ,(symbol->string htm)) - (htu . ,(uri->string htu)) - (iat . ,(time-second (date->time-utc ((p:current-date))))) - ,@(if access-token - `((ath . ,(stubs:hash 'SHA-256 access-token))) - '())))) - client-key)) + (next-method) + (let-keywords + initargs #t + ((typ "dpop+jwt") + (jwk #f) + (htm #f) + (htu #f) + (ath #f) + (access-token #f) + (jwt-header #f) + (jwt-payload #f)) + (let do-initialize ((typ typ) + (jwk jwk) + (htm htm) + (htu htu) + (ath ath) + (access-token access-token) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((string? htu) + (do-initialize typ jwk htm (string->uri htu) ath access-token jwt-header jwt-payload)) + ((string? htm) + (do-initialize typ jwk (string->symbol htm) htu ath access-token jwt-header jwt-payload)) + ((and (not ath) access-token) + (do-initialize typ jwk htm htu (stubs:hash 'SHA-256 access-token) #f jwt-header jwt-payload)) + ((and typ jwk htm htu) + (unless (equal? typ "dpop+jwt") + (scm-error 'wrong-type-arg "make" + (G_ "#:typ should be exactly \"dpop+jwt\"") + '() + (list typ))) + (unless (is-a? jwk <public-key>) + (scm-error 'wrong-type-arg "make" + (G_ "#:jwk should be a public key") + '() + (list jwk))) + (unless (symbol? htm) + (scm-error 'wrong-type-arg "make" + (G_ "#:htm should be a symbol") + '() + (list htm))) + (when ath + (unless (string? ath) + (scm-error 'wrong-type-arg "make" + (G_ "when present, #:ath should be a string") + '() + (list ath)))) + (slot-set! token 'typ typ) + (slot-set! token 'jwk jwk) + (slot-set! token 'htm htm) + (slot-set! token 'htu htu) + (slot-set! token 'ath ath)) + ((and jwt-header jwt-payload) + (do-initialize + (assq-ref jwt-header 'typ) + (jwk->key (assq-ref jwt-header 'jwk)) + (assq-ref jwt-payload 'htm) + (assq-ref jwt-payload 'htu) + (assq-ref jwt-payload 'ath) + #f #f #f)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (G_ "when making a DPoP proof, either its required fields (#:typ, #:jwk, #:htm and #:htu) or (#:jwt-header and #:jwt-payload) should be passed"))))))))))) + +(define-method (token->jwt (token <dpop-proof>)) + ;; exp should be implicit, and nonce should be replaced by jti + (receive (base-header base-payload) (next-method) + (values + `((typ . ,(typ token)) + (jwk . ,(key->jwk (jwk token))) + ,@base-header) + `((htm . ,(symbol->string (htm token))) + (htu . ,(uri->string (htu token))) + ,@(let ((ath (ath token))) + (if ath + `((ath . ,ath)) + '())) + ,@base-payload)))) + +(define-method (verify (token <dpop-proof>) args) + (next-method) + (let-keywords + args #t + ((access-token #f) + (method #f) + (uri #f) + (cnf/check #f)) + (begin + (when (string? uri) + (set! uri (string->uri uri))) + (unless (eq? (htm token) method) + (raise-exception + (make-exception + (make-dpop-method-mismatch (htm token) method) + (make-exception-with-message + (format #f (G_ "the DPoP proof is signed for access through ~s, but it is used with ~s") + (htm token) method))))) + (uris-compatible (htu token) uri) + (when access-token + (let ((h (stubs:hash 'SHA-256 access-token))) + (unless (equal? (ath token) h) + (raise-exception + (make-exception + (make-dpop-invalid-ath (ath token) access-token) + (make-exception-with-message + (format #f (G_ "the DPoP proof should go along with an access token hashed to ~s, not ~s") + (ath token) access-token))))))) + (if (string? cnf/check) + (unless (equal? cnf/check (jkt (jwk token))) + (raise-exception + (make-exception + (make-dpop-unconfirmed-key) + (make-exception-with-message + (format #f (G_ "the DPoP proof is signed with the wrong key")))))) + (with-exception-handler + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "the DPoP proof is signed with the wrong key: ~a") + (exception-message error)) + (format #f (G_ "the DPoP proof is signed with the wrong key"))))) + (raise-exception + (make-exception + (make-dpop-unconfirmed-key) + (make-exception-with-message final-message) + error)))) + (lambda () + (unless (cnf/check (jkt (jwk token))) + ;; You should throw an error instead! + (fail (G_ "the cnf/check function returned #f"))))))))) + +(define-method (lookup-keys (token <dpop-proof>) args) + (jwk token)) diff --git a/src/scm/webid-oidc/example-app.scm b/src/scm/webid-oidc/example-app.scm index c293d69..67d959f 100644 --- a/src/scm/webid-oidc/example-app.scm +++ b/src/scm/webid-oidc/example-app.scm @@ -18,7 +18,6 @@ #:use-module ((webid-oidc client) #:prefix client:) #:use-module ((webid-oidc client accounts) #:prefix account:) #:use-module ((webid-oidc cache) #:prefix cache:) - #:use-module (webid-oidc dpop-proof) #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) diff --git a/src/scm/webid-oidc/jws.scm b/src/scm/webid-oidc/jws.scm index 3e5e50b..af83c90 100644 --- a/src/scm/webid-oidc/jws.scm +++ b/src/scm/webid-oidc/jws.scm @@ -18,13 +18,30 @@ #:use-module (webid-oidc jwk) #:use-module (webid-oidc errors) #:use-module (webid-oidc web-i18n) + #:use-module (webid-oidc jti) + #:use-module (webid-oidc oidc-configuration) #:use-module ((webid-oidc stubs) #:prefix stubs:) + #:use-module ((webid-oidc parameters) #:prefix p:) #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-19) #:use-module (ice-9 receive) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) + #:use-module (ice-9 optargs) + #:use-module (web uri) #:use-module (oop goops) #:declarative? #t + #:re-export + ( + (&jti-found . &nonce-found) + (make-jti-found . make-nonce-found) + (jti-found? . nonce-found?) + (jti-found-jti . nonce-found-nonce) + ) + #:replace + ( + exp ;; This is a function in guile + ) #:export ( @@ -32,10 +49,16 @@ make-invalid-jws invalid-jws? - the-jws - jws? + <token> + + <time-bound-token> iat default-validity has-explicit-exp? + nonce-field-name ;; DPoP proofs use 'jti instead of 'nonce + + <oidc-token> iss - jws-alg + <single-use-token> nonce + + token->jwt &cannot-query-identity-provider make-cannot-query-identity-provider @@ -54,8 +77,11 @@ error-expiration-date ;; error-current-date works for that one too - jws-decode - jws-encode + lookup-keys + verify + decode + encode + issue )) @@ -65,70 +91,259 @@ make-invalid-jws invalid-jws?) -(define (the-jws x) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the JWS is invalid: ~a") - (exception-message error)) - (format #f (G_ "the JWS is invalid"))))) +(define-class <token> () + (alg #:init-keyword #:alg #:accessor alg)) + +(define (key-alg key) + (alg key)) + +(define-method (initialize (token <token>) initargs) + (next-method) + (let-keywords + initargs #t + ((alg #f) + (signing-key #f) + (jwt-header #f) + (jwt-payload #f)) + (let do-initialize ((alg alg) + (signing-key signing-key) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((string? alg) + (do-initialize (string->symbol alg) signing-key jwt-header jwt-payload)) + (alg + (case alg + ((HS256 HS384 HS512 + RS256 RS384 RS512 + ES256 ES384 ES512 + PS256 PS384 PS512) + (slot-set! token 'alg alg)) + (else (raise-exception (make-exception (make-invalid-jws) - (make-exception-with-message final-message) - error)))) - (lambda () - (match x - ((header . payload) - (let examine-header ((header header) - (alg #f) - (other-header-fields '())) - (match header - (() - (let examine-payload ((payload payload) - (other-payload-fields '())) - (match payload - (() - (unless alg - (fail (format #f (G_ "the JWS header does not have an \"alg\" field")))) - `(((alg . ,(symbol->string alg)) - ,@(reverse other-header-fields)) - . ,(reverse other-payload-fields))) - ((((? symbol? key) . value) payload ...) - (examine-payload payload - `((,key . ,value) ,@other-payload-fields))) - (else - (fail (format #f (G_ "invalid JSON object as payload"))))))) - ((('alg . (? string? given-alg)) header ...) - (case (string->symbol given-alg) - ((HS256 HS384 HS512 - RS256 RS384 RS512 - ES256 ES384 ES512 - PS256 PS384 PS512) - #t) - (else - (fail (format #f (G_ "invalid signature algorithm: ~s") given-alg)))) - (examine-header header (or alg (string->symbol given-alg)) - other-header-fields)) - ((('alg . invalid) header ...) - (fail (format #f (G_ "invalid \"alg\" value: ~s") invalid))) - ((((? symbol? key) . value) header ...) - (examine-header header alg - `((,key . ,value) ,@other-header-fields))) - (else - (fail (format #f (G_ "invalid JSON object as header"))))))) - (else - (fail (format #f (G_ "this is not a pair")))))))) - -(define (jws? x) - (false-if-exception - (the-jws x))) - -(define (jws-alg jws) - (match (the-jws jws) - ((header . _) - (string->symbol (assq-ref header 'alg))))) + (make-exception-with-message + (format #f (G_ "unsupported JWS algorithm: ~s") alg))))))) + (signing-key + (do-initialize (key-alg signing-key) #f jwt-payload jwt-header)) + ((and jwt-header jwt-payload) + (do-initialize (assq-ref jwt-header 'alg) #f #f #f)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (G_ "when making a token either #:alg or (#:jwt-header and #:jwt-payload) should be passed"))))))))) + +(define-class <generic-with-default> (<generic>) + ;; neutral is the list of values that are returned when there are no + ;; next methods. + (neutral #:init-keyword #:neutral)) + +(define-method (no-next-method (generic <generic-with-default>) args) + (apply values (slot-ref generic 'neutral))) + +(define-method (no-applicable-method (generic <generic-with-default>) args) + (apply values (slot-ref generic 'neutral))) + +(define-class <time-bound-token> (<token>) + (iat #:init-keyword #:iat #:accessor iat) + (exp #:init-keyword #:exp #:accessor exp)) + +(define default-validity + (make <generic-with-default> + #:name 'default-validity + #:neutral (list #f))) + +(define-method (has-explicit-exp? (token <time-bound-token>)) + ;; Change it to #f when the token should not have an explicit + ;; expiration date, such as DPoP proofs + #t) + +(define-method (initialize (token <time-bound-token>) initargs) + (next-method) + (let-keywords + initargs #t + ((iat ((p:current-date))) + (exp #f) + (validity (default-validity token)) + (jwt-header #f) + (jwt-payload #f)) + (let do-initialize ((iat iat) + (exp exp) + (validity validity) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((integer? iat) + (do-initialize (make-time time-utc 0 iat) exp validity jwt-header jwt-payload)) + ((time? iat) + (do-initialize (time-utc->date iat) exp validity jwt-header jwt-payload)) + ((and (not exp) (date? iat) (integer? validity)) + (do-initialize iat + (+ (time-second (date->time-utc iat)) + validity) + validity + jwt-header + jwt-payload)) + ((integer? exp) + (do-initialize iat (make-time time-utc 0 exp) validity jwt-header jwt-payload)) + ((time? exp) + (do-initialize iat (time-utc->date exp) validity jwt-header jwt-payload)) + ((and jwt-header jwt-payload) + (do-initialize (assq-ref jwt-payload 'iat) + (and (has-explicit-exp? token) + (assq-ref jwt-payload 'exp)) + validity #f #f)) + ((and iat exp) + (unless (date? iat) + (scm-error 'wrong-type-arg "make" + (G_ "#:iat should be a date") + '() + (list iat))) + (unless (date? exp) + (scm-error 'wrong-type-arg "make" + (G_ "#:exp should be a date") + '() + (list exp))) + (slot-set! token 'iat iat) + (slot-set! token 'exp exp)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (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)) + +(define-method (default-validity (token <oidc-token>)) + (let ((next (next-method)) + (mine 3600)) + (if (and next (< next mine)) + next + mine))) + +(define-method (initialize (token <oidc-token>) initargs) + (next-method) + (let-keywords + initargs #t + ((iss #f) + (jwt-header #f) + (jwt-payload #f)) + (let do-initialize ((iss iss) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((string? iss) + (do-initialize (string->uri iss) jwt-header jwt-payload)) + (iss + (unless (uri? iss) + (scm-error 'wrong-type-arg "make" + (G_ "#:iss should be an URI") + '() + (list iss))) + (slot-set! token 'iss iss)) + ((and jwt-header jwt-payload) + (do-initialize (assq-ref jwt-payload 'iss) #f #f)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (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)) + +(define-method (default-validity (token <single-use-token>)) + (let ((next (next-method)) + (mine 120)) + (if (and next (< next mine)) + next + mine))) + +(define nonce-field-name + (make <generic-with-default> + #:name 'nonce-field-name + #:neutral (list 'nonce))) + +(define-method (nonce-field-name (token <top>)) + ;; Without this method, this is an infinite loop. + (next-method)) + +(define-method (initialize (token <single-use-token>) initargs) + (next-method) + (let-keywords + initargs #t + ((nonce (stubs:random 12)) + (jwt-header #f) + (jwt-payload #f)) + ;; The maximum validity is 2 minutes + (let ((iat (time-second (date->time-utc (iat token)))) + (exp (time-second (date->time-utc (exp token))))) + (let ((validity (- exp iat))) + (when (> validity 120) + (let ((true-exp (+ iat 120))) + (slot-set! token 'exp (time-utc->date (make-time time-utc 0 true-exp))))))) + (let do-initialize ((nonce nonce) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((and jwt-header jwt-payload) + (do-initialize (assq-ref jwt-payload (nonce-field-name token)) #f #f)) + (nonce + (unless (string? nonce) + (scm-error 'wrong-type-arg "make" + (G_ "#:nonce should be a string") + '() + (list nonce))) + (slot-set! token 'nonce nonce)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (G_ "when making a single-use token, either its required #:nonce field or (#:jwt-header and #:jwt-payload) should be passed"))))))))) + +(define token->jwt + (make <generic-with-default> + #:name 'token->jwt + #:neutral (list '() '()))) + +(define-method (token->jwt (token <token>)) + (receive (base-header base-payload) + (next-method) + (values + `((alg . ,(symbol->string (alg token))) + ,@base-header) + base-payload))) + +(define-method (token->jwt (token <time-bound-token>)) + (receive (base-header base-payload) + (next-method) + (values base-header + `((iat . ,(time-second (date->time-utc (iat token)))) + ,@(if (has-explicit-exp? token) + `((exp . ,(time-second (date->time-utc (exp token))))) + '()) + ,@base-payload)))) + +(define-method (token->jwt (token <single-use-token>)) + (receive (base-header base-payload) + (next-method) + (values base-header + `((,(nonce-field-name token) . ,(nonce token)) + ,@base-payload)))) + +(define-method (token->jwt (token <oidc-token>)) + (receive (base-header base-payload) + (next-method) + (values base-header + `((iss . ,(uri->string (iss token))) + ,@base-payload)))) (define (split-in-3-parts string separator) (match (string-split string separator) @@ -193,14 +408,14 @@ (error-current-date (apply make-exception sub-exceptions))) (else #f))) -(define (parse str verify) +(define (parse token-class str verify-signature) (receive (header payload signature) (split-in-3-parts str #\.) (let ((base (string-append header "." payload)) (header (base64-decode-json header)) (payload (base64-decode-json payload))) - (let ((ret `(,header . ,payload))) - (verify ret base signature) + (let ((ret (make token-class #:jwt-header header #:jwt-payload payload))) + (verify-signature ret base signature) ret)))) (define (verify-any alg keys payload signature) @@ -245,7 +460,102 @@ (define-method (keys (keys <list>)) (map public-key keys)) -(define (jws-decode str lookup-keys) +(define lookup-keys + (make <generic-with-default> + #:name 'lookup-keys + #:neutral (list '()))) + +(define-method (lookup-keys (token <oidc-token>) args) + (let-keywords + args #f + ((http-request http-request)) + (let ((iss (iss token))) + (let ((cfg + (with-exception-handler + (lambda (error) + (let ((final-message + (if (exception-with-message? error) + (format #f (G_ "I cannot query the identity provider configuration: ~a") + (exception-message error)) + (format #f (G_ "I cannot query the identity provider configuration"))))) + (raise-exception + (make-exception + (make-cannot-query-identity-provider iss) + (make-exception-with-message final-message) + error)))) + (lambda () + (get-oidc-configuration + (uri-host iss) + #:userinfo (uri-userinfo iss) + #:port (uri-port iss) + #:http-get + (lambda* (uri . args) + (apply http-request uri #:method 'GET args))))))) + (with-exception-handler + (lambda (error) + (raise-exception + (make-exception + (make-cannot-query-identity-provider iss) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a") + (exception-message error)) + (format #f (G_ "I cannot query the JWKS URI of the identity provider"))))))) + (lambda () + (append + (keys (next-method)) + (keys + (oidc-configuration-jwks + cfg + #:http-get + (lambda* (uri . args) + (apply http-request uri #:method 'GET args))))))))))) + +(define verify + (make <generic-with-default> + #:name 'verify + #:neutral (list #t))) + +(define-method (verify (token <time-bound-token>) args) + (next-method) + (let-keywords + args #t + ((current-date ((p:current-date)))) + (let ((iat (iat token)) + (exp (exp token))) + (let ((iat-s (time-second (date->time-utc iat))) + (exp-s (time-second (date->time-utc exp))) + (current-s (time-second (date->time-utc current-date)))) + (when (>= iat-s (+ current-s 5)) + (let ((final-message + (format #f (G_ "the token is signed in the future, ~a, relative to current ~a") + (date->string iat) + (date->string current-date)))) + (raise-exception + (make-exception + (make-signed-in-future iat current-date) + (make-exception-with-message final-message))))) + (when (>= current-s exp-s) + (let ((final-message + (format #f (G_ "the token expired ~a, which is in the past (from ~a)") + (date->string exp) + (date->string current-date)))) + (raise-exception + (make-exception + (make-expired exp current-date) + (make-exception-with-message final-message))))))))) + +(define-method (verify (token <single-use-token>) args) + (next-method) + (let-keywords + args #t + ((current-date ((p:current-date)))) + (let ((exp (exp token))) + (let ((exp-s (time-second (date->time-utc exp))) + (current-s (time-second (date->time-utc current-date)))) + (jti-check (nonce token) (- exp-s current-s)))))) + +(define* (decode token-class str . args) (with-exception-handler (lambda (error) (let ((final-message @@ -259,12 +569,13 @@ (make-exception-with-message final-message) error)))) (lambda () - (parse str - (lambda (jws payload signature) - (let ((k (keys (lookup-keys jws)))) - (verify-any (jws-alg jws) k payload signature))))))) + (parse token-class str + (lambda (token payload signature) + (let ((k (keys (lookup-keys token args)))) + (verify-any (alg token) k payload signature)) + (verify token args)))))) -(define (jws-encode jws key) +(define (encode token key) (with-exception-handler (lambda (error) (let ((final-message @@ -278,12 +589,14 @@ (make-exception-with-message final-message) error)))) (lambda () - (match jws - ((header . payload) - (let ((header (stubs:scm->json-string header)) - (payload (stubs:scm->json-string payload))) - (let ((header (stubs:base64-encode header)) - (payload (stubs:base64-encode payload))) - (let ((payload (string-append header "." payload))) - (let ((signature (stubs:sign (jws-alg jws) (key->jwk key) payload))) - (string-append payload "." signature)))))))))) + (receive (header payload) (token->jwt token) + (let ((header (stubs:scm->json-string header)) + (payload (stubs:scm->json-string payload))) + (let ((header (stubs:base64-encode header)) + (payload (stubs:base64-encode payload))) + (let ((payload (string-append header "." payload))) + (let ((signature (stubs:sign (alg token) (key->jwk key) payload))) + (string-append payload "." signature))))))))) + +(define* (issue token-class issuer-key . args) + (encode (apply make token-class #:signing-key issuer-key args) issuer-key)) diff --git a/src/scm/webid-oidc/oidc-id-token.scm b/src/scm/webid-oidc/oidc-id-token.scm index abef88d..1d96a47 100644 --- a/src/scm/webid-oidc/oidc-id-token.scm +++ b/src/scm/webid-oidc/oidc-id-token.scm @@ -28,28 +28,26 @@ #:use-module (ice-9 optargs) #:use-module (ice-9 exceptions) #:use-module (ice-9 match) + #:use-module (ice-9 receive) #:use-module (srfi srfi-19) + #:use-module (oop goops) + #:duplicates (merge-generics) #:declarative? #t + #:re-export + ( + alg iat iss nonce + token->jwt + decode + encode + issue + ) #:export ( &invalid-id-token make-invalid-id-token invalid-id-token? - the-id-token - id-token? - - id-token-alg - id-token-webid - id-token-iss - id-token-sub - id-token-aud - id-token-nonce - id-token-iat - id-token-exp - - id-token-decode - issue-id-token + <id-token> webid sub aud )) (define-exception-type @@ -58,268 +56,81 @@ make-invalid-id-token invalid-id-token?) -(define (the-id-token x) - (with-exception-handler - (lambda (error) - (let ((final-message - (cond - ((and (invalid-jws? error) - (exception-with-message? error)) - (format #f (G_ "this is not an ID token, because it is not even a JWS: ~a") - (exception-message error))) - ((invalid-jws? error) - (format #f (G_ "this is not an ID token, because it is not even a JWS"))) - ((exception-with-message? error) - (format #f (G_ "this is not an ID token: ~a") - (exception-message error))) - (else - (format #f (G_ "this is not an ID token")))))) - (raise-exception - (make-exception - (make-invalid-id-token) - (make-exception-with-message final-message) - error)))) - (lambda () - (match (the-jws x) - ((header . payload) - (let examine-payload ((payload payload) - (webid #f) - (iss #f) - (sub #f) - (aud #f) - (nonce #f) - (iat #f) - (exp #f) - (other-fields '())) - (match payload - (() - (unless (and webid iss sub aud nonce iat exp) - (fail (format #f (G_ "the payload is missing ~s") - `(,@(if webid '() '("webid")) - ,@(if iss '() '("iss")) - ,@(if sub '() '("sub")) - ,@(if aud '() '("aud")) - ,@(if nonce '() '("nonce")) - ,@(if iat '() '("iat")) - ,@(if exp '() '("exp")))))) - `(,header - . ((webid . ,(uri->string webid)) - (iss . ,(uri->string iss)) - (sub . ,sub) - (aud . ,(uri->string aud)) - (nonce . ,nonce) - (iat . ,(time-second (date->time-utc iat))) - (exp . ,(time-second (date->time-utc exp)))))) - ((('webid . (? string? (= string->uri (? uri? webid-given)))) payload ...) - (examine-payload payload - (or webid webid-given) - iss sub aud nonce iat exp other-fields)) - ((('webid . invalid) payload ...) - (fail (format #f (G_ "the \"webid\" field should be an URI, ~s is given") - invalid))) - ((('iss . (? string? (= string->uri (? uri? iss-given)))) payload ...) - (examine-payload payload webid - (or iss iss-given) - sub aud nonce iat exp other-fields)) - ((('iss . invalid) payload ...) - (fail (format #f (G_ "the \"iss\" field should be an URI, ~s is given") - invalid))) - ((('sub . (? string? sub-given)) payload ...) - (examine-payload payload webid iss - (or sub sub-given) - aud nonce iat exp other-fields)) - ((('sub . invalid) payload ...) - (fail (format #f (G_ "the \"sub\" field should be a string, ~s is given") - invalid))) - ((('aud . (? string? (= string->uri (? uri? aud-given)))) payload ...) - (examine-payload payload webid iss sub - (or aud aud-given) - nonce iat exp other-fields)) - ((('aud . invalid) payload ...) - (fail (format #f (G_ "the \"aud\" field should be an URI, ~s is given") - invalid))) - ((('nonce . (? string? nonce-given)) payload ...) - (examine-payload payload webid iss sub aud - (or nonce nonce-given) - iat exp other-fields)) - ((('nonce . invalid) payload ...) - (fail (format #f (G_ "the \"nonce\" field should be a string, ~s is given") - invalid))) - ((('iat . (? (lambda (x) (>= x 0)) (? integer? iat-given))) payload ...) - (examine-payload payload webid iss sub aud nonce - (or iat (time-utc->date (make-time time-utc 0 iat-given))) - exp other-fields)) - ((('iat . invalid) payload ...) - (fail (format #f (G_ "the \"iat\" field should be a timestamp, ~s is given") - invalid))) - ((('exp . (? (lambda (x) (>= x 0)) (? integer? exp-given))) payload ...) - (examine-payload payload webid iss sub aud nonce iat - (or exp (time-utc->date (make-time time-utc 0 exp-given))) - other-fields)) - ((('exp . invalid) payload ...) - (fail (format #f (G_ "the \"exp\" field should be a timestamp, ~s is given") - invalid))) - ((field payload ...) - (examine-payload payload webid iss sub aud nonce iat exp - `(,field ,@other-fields))) - (else - (fail (format #f (G_ "the payload should be a JSON object"))))))))))) - -(define (id-token? x) - (false-if-exception - (the-id-token x))) - -(define (id-token-alg code) - (match (the-id-token code) - ((header . _) - (string->symbol (assq-ref header 'alg))))) - -(define (id-token-webid code) - (match (the-id-token code) - ((_ . payload) - (string->uri (assq-ref payload 'webid))))) - -(define (id-token-iss code) - (match (the-id-token code) - ((_ . payload) - (string->uri (assq-ref payload 'iss))))) +(define-class <id-token> (<single-use-token> <oidc-token>) + (webid #:init-keyword #:webid #:accessor webid) + (sub #:init-keyword #:sub #:accessor sub) + (aud #:init-keyword #:aud #:accessor aud)) -(define (id-token-sub code) - (match (the-id-token code) - ((_ . payload) - (assq-ref payload 'sub)))) - -(define (id-token-aud code) - (match (the-id-token code) - ((_ . payload) - (string->uri (assq-ref payload 'aud))))) - -(define (id-token-nonce code) - (match (the-id-token code) - ((_ . payload) - (assq-ref payload 'nonce)))) - -(define (id-token-iat code) - (match (the-id-token code) - ((_ . payload) - (time-utc->date - (make-time time-utc 0 (assq-ref payload 'iat)))))) - -(define (id-token-exp code) - (match (the-id-token code) - ((_ . payload) - (time-utc->date - (make-time time-utc 0 (assq-ref payload 'exp)))))) - -(define* (id-token-decode str #:key (http-get http-get)) +(define-method (initialize (token <id-token>) initargs) (with-exception-handler (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "the ID token is invalid: ~a") - (exception-message error)) - (format #f (G_ "the ID token is invalid"))))) - (raise-exception - (make-exception - (make-invalid-id-token) - (make-exception-with-message final-message) - error)))) + (raise-exception + (make-exception + (make-invalid-id-token) + (make-exception-with-message + (if (exception-with-message? error) + (format #f (G_ "invalid OIDC ID token: ~a") + (exception-message error)) + (G_ "invalid OIDC id token"))) + error))) (lambda () - (jws-decode - str - (lambda (token) - (let ((iss (id-token-iss token))) - (let* ((cfg - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "I cannot query the identity provider configuration: ~a") - (exception-message error)) - (format #f (G_ "I cannot query the identity provider configuratioon"))))) - (raise-exception - (make-exception - (make-cannot-query-identity-provider iss) - (make-exception-with-message final-message) - error)))) - (lambda () - (get-oidc-configuration - (uri-host iss) - #:userinfo (uri-userinfo iss) - #:port (uri-port iss) - #:http-get http-get)))) - (jwks - (with-exception-handler - (lambda (error) - (raise-exception - (make-exception - (make-cannot-query-identity-provider iss) - (make-exception-with-message - (if (exception-with-message? error) - (format #f (G_ "I cannot query the JWKS URI of the identity provider: ~a") - (exception-message error)) - (format #f (G_ "I cannot query the JWKS URI of the identity provider"))))))) - (lambda () - (oidc-configuration-jwks cfg #:http-get http-get))))) - (let ((iat (id-token-iat token)) - (exp (id-token-exp token)) - (current-date ((p:current-date)))) - (let ((iat-s (time-second (date->time-utc iat))) - (exp-s (time-second (date->time-utc exp))) - (current-s (time-second (date->time-utc current-date)))) - (when (>= iat-s (+ current-s 5)) - (let ((final-message - (format #f (G_ "the ID token is signed in the future, ~a, relative to current ~a") - (date->string iat) - (date->string current-date)))) - (raise-exception - (make-exception - (make-signed-in-future iat current-date) - (make-exception-with-message final-message))))) - (when (>= current-s exp-s) - (let ((final-message - (format #f (G_ "the ID token expired ~a, which is in the past (from ~a)") - (date->string exp) - (date->string current-date)))) - (raise-exception - (make-exception - (make-expired exp current-date) - (make-exception-with-message final-message))))))) - jwks))))))) - -(define (id-token-encode id-token key) - (with-exception-handler - (lambda (error) - (let ((final-message - (if (exception-with-message? error) - (format #f (G_ "cannot encode the ID token: ~a") - (exception-message error)) - (format #f (G_ "cannot encode the ID token"))))) - (raise-exception - (make-exception-with-message final-message)))) - (lambda () - (jws-encode id-token key)))) - -(define* (issue-id-token - issuer-key - #:key - (webid #f) - (iss #f) - (sub #f) - (aud #f) - (validity 3600)) - (unless sub - (set! sub (uri->string webid))) - (let* ((iat (time-second (date->time-utc ((p:current-date))))) - (exp (+ iat validity))) - (jws-encode - (the-id-token - `(((alg . ,(symbol->string (alg issuer-key)))) - . ((webid . ,(uri->string webid)) - (iss . ,(uri->string iss)) - (sub . ,sub) - (aud . ,(uri->string aud)) - (nonce . ,(stubs:random 12)) - (iat . ,iat) - (exp . ,exp)))) - issuer-key))) + (next-method) + (let-keywords + initargs #t + ((webid #f) + (sub #f) + (aud #f) + (jwt-header #f) + (jwt-payload #f)) + (let do-initialize ((webid webid) + (sub sub) + (aud aud) + (jwt-header jwt-header) + (jwt-payload jwt-payload)) + (cond + ((string? webid) + (do-initialize (string->uri webid) sub aud jwt-header jwt-payload)) + ((and (not sub) (uri? webid)) + (do-initialize webid (uri->string webid) aud jwt-header jwt-payload)) + ((string? aud) + (do-initialize webid sub (string->uri aud) jwt-header jwt-payload)) + ((and webid sub) + (unless (uri? webid) + (scm-error 'wrong-type-arg "make" + (G_ "#:webid should be an URI") + '() + (list webid))) + (unless (string? sub) + (scm-error 'wrong-type-arg "make" + (G_ "#:sub should be a string") + '() + (list sub))) + (unless (uri? aud) + (scm-error 'wrong-type-arg "make" + (G_ "#:aud should be a string") + '() + (list aud))) + (slot-set! token 'webid webid) + (slot-set! token 'sub sub) + (slot-set! token 'aud aud)) + ((and jwt-header jwt-payload) + (do-initialize (assq-ref jwt-payload 'webid) + (assq-ref jwt-payload 'sub) + (assq-ref jwt-payload 'aud) + #f #f)) + (else + (raise-exception + (make-exception + (make-invalid-jws) + (make-exception-with-message + (G_ "when making an ID token either its required fields (#:alg, #:webid, #:iss, #:sub, #:aud, #:iat and #:exp) or (#:jwt-header and #:jwt-payload) should be passed"))))))))))) + +(define-method (token->jwt (token <id-token>)) + (receive (base-header base-payload) + (next-method) + (values + base-header + `((webid . ,(uri->string (webid token))) + (sub . ,(sub token)) + (aud . ,(uri->string (aud token))) + ,@base-payload)))) diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm index 551b72d..99291b0 100644 --- a/src/scm/webid-oidc/resource-server.scm +++ b/src/scm/webid-oidc/resource-server.scm @@ -107,15 +107,27 @@ (('dpop . (? string? string-value)) string-value))) (access-token - (access-token-decode lit-access-token - #:http-get http-get)) - (cnf/jkt (access-token-cnf/jkt access-token)) + (decode <access-token> lit-access-token + #:http-request + (lambda* (uri . args) + (let without-method ((remaining-args args) + (kept-args '())) + (match remaining-args + (() (apply http-get uri (reverse kept-args))) + ((#:method 'GET remaining-args ...) + (without-method remaining-args kept-args)) + (((? keyword? key) value remaining-args ...) + (without-method remaining-args + `(,value ,key ,@kept-args)))))))) + (cnf/jkt (cnf/jkt access-token)) (dpop-proof - (dpop-proof-decode - method full-uri - dpop cnf/jkt #:access-token lit-access-token))) - (let ((subject (access-token-webid access-token)) - (issuer (access-token-iss access-token))) + (decode <dpop-proof> dpop + #:method method + #:uri full-uri + #:cnf/check cnf/jkt + #:access-token lit-access-token))) + (let ((subject (webid access-token)) + (issuer (iss access-token))) (confirm-provider subject issuer #:http-get http-get) subject))) #:unwind? #t))))))) diff --git a/src/scm/webid-oidc/token-endpoint.scm b/src/scm/webid-oidc/token-endpoint.scm index 81f8e48..292df4d 100644 --- a/src/scm/webid-oidc/token-endpoint.scm +++ b/src/scm/webid-oidc/token-endpoint.scm @@ -38,6 +38,8 @@ #:use-module (rnrs bytevectors) #:use-module (sxml simple) #:use-module (sxml match) + #:use-module (oop goops) + #:duplicates (merge-generics) #:declarative? #t #:export ( @@ -177,7 +179,7 @@ port))))))) thunk)))) -(define (make-token-endpoint token-endpoint-uri iss jwk validity) +(define (make-token-endpoint token-endpoint-uri iss issuer-key validity) (lambda (request request-body) (when (bytevector? request-body) (set! request-body (utf8->string request-body))) @@ -213,10 +215,11 @@ #:path (uri-path (request-uri request)) #:query (uri-query (request-uri request))))) (let ((grant-type (assoc-ref form-args "grant_type")) - (dpop (dpop-proof-decode - method uri - (assq-ref (request-headers request) 'dpop) - (lambda (jkt) #t)))) + (dpop (decode <dpop-proof> (assq-ref (request-headers request) 'dpop) + #:method method + #:uri uri + #:cnf/check + (lambda (jkt) #t)))) (unless (and grant-type (string? grant-type)) (let ((final-message (format #f (G_ "missing grant type"))) @@ -248,9 +251,16 @@ (make-no-authorization-code) (make-exception-with-message final-message) (make-message-for-the-user final-user-message))))) - (authorization-code-decode str jwk)))) - (values (authorization-code-webid code) - (authorization-code-client-id code)))) + (with-exception-handler + (lambda (error) + (raise-exception + (make-exception + (make-invalid-authorization-code) + error))) + (lambda () + (decode <authorization-code> str + #:issuer-key issuer-key)))))) + (values (webid code) (client-id code)))) ((refresh_token) (let ((refresh-token (assoc-ref form-args "refresh_token"))) (unless refresh-token @@ -268,7 +278,7 @@ (make-message-for-the-user final-user-message))))) (refresh:with-refresh-token refresh-token - (dpop-proof-jwk dpop) + (jwk dpop) values))) (else (let ((final-message @@ -288,26 +298,23 @@ (let* ((iat (time-second (date->time-utc current-time))) (exp (+ iat validity))) (let ((id-token - (issue-id-token - jwk + (issue <id-token> + issuer-key #:webid webid - #:sub (uri->string webid) #:iss iss - #:aud client-id - #:validity 3600)) + #:aud client-id)) (access-token - (issue-access-token - jwk + (issue <access-token> + issuer-key #:webid webid #:iss iss - #:validity 3600 - #:client-key (dpop-proof-jwk dpop) + #:client-key (jwk dpop) #:client-id client-id)) (refresh-token (if (equal? grant-type "refresh_token") (assoc-ref form-args "refresh_token") (refresh:issue-refresh-token webid client-id - (jkt (dpop-proof-jwk dpop)))))) + (jkt (jwk dpop)))))) (values (build-response #:headers '((content-type application/json) (cache-control (no-cache no-store))) |