diff options
Diffstat (limited to 'src/scm/webid-oidc/jws.scm')
-rw-r--r-- | src/scm/webid-oidc/jws.scm | 481 |
1 files changed, 397 insertions, 84 deletions
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)) |