diff options
Diffstat (limited to 'src/scm/webid-oidc/errors.scm')
| -rw-r--r-- | src/scm/webid-oidc/errors.scm | 283 |
1 files changed, 259 insertions, 24 deletions
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 50d526c..959b04e 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -3,6 +3,8 @@ #:use-module (ice-9 exceptions) #:use-module (ice-9 optargs) #:use-module (ice-9 i18n) + #:use-module (srfi srfi-19) + #:use-module (web uri) #:use-module (web response)) (define (G_ text) @@ -297,6 +299,56 @@ (raise-exception ((record-constructor &incorrect-client-id-field) value))) +(define-public &incorrect-typ-field + (make-exception-type + '&incorrect-typ-field + &external-error + '(value))) + +(define-public (raise-incorrect-typ-field value) + (raise-exception + ((record-constructor &incorrect-typ-field) value))) + +(define-public &incorrect-jwk-field + (make-exception-type + '&incorrect-jwk-field + &external-error + '(value cause))) + +(define-public (raise-incorrect-jwk-field value cause) + (raise-exception + ((record-constructor &incorrect-jwk-field) value cause))) + +(define-public &incorrect-jti-field + (make-exception-type + '&incorrect-jti-field + &external-error + '(value))) + +(define-public (raise-incorrect-jti-field value) + (raise-exception + ((record-constructor &incorrect-jti-field) value))) + +(define-public &incorrect-htm-field + (make-exception-type + '&incorrect-htm-field + &external-error + '(value))) + +(define-public (raise-incorrect-htm-field value) + (raise-exception + ((record-constructor &incorrect-htm-field) value))) + +(define-public &incorrect-htu-field + (make-exception-type + '&incorrect-htu-field + &external-error + '(value))) + +(define-public (raise-incorrect-htu-field value) + (raise-exception + ((record-constructor &incorrect-htu-field) value))) + (define-public ¬-an-access-token (make-exception-type '¬-an-access-token @@ -327,6 +379,36 @@ (raise-exception ((record-constructor ¬-an-access-token-payload) value cause))) +(define-public ¬-a-dpop-proof + (make-exception-type + '¬-a-dpop-proof + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof) value cause))) + +(define-public ¬-a-dpop-proof-header + (make-exception-type + '¬-a-dpop-proof-header + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof-header value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof-header) value cause))) + +(define-public ¬-a-dpop-proof-payload + (make-exception-type + '¬-a-dpop-proof-payload + &external-error + '(value cause))) + +(define-public (raise-not-a-dpop-proof-payload value cause) + (raise-exception + ((record-constructor ¬-a-dpop-proof-payload) value cause))) + (define-public &cannot-fetch-issuer-configuration (make-exception-type '&cannot-fetch-issuer-configuration @@ -347,6 +429,66 @@ (raise-exception ((record-constructor &cannot-fetch-jwks) issuer uri cause))) +(define-public &dpop-method-mismatch + (make-exception-type + '&dpop-method-mismatch + &external-error + '(signed requested))) + +(define-public (raise-dpop-method-mismatch signed requested) + (raise-exception + ((record-constructor &dpop-method-mismatch) signed requested))) + +(define-public &dpop-uri-mismatch + (make-exception-type + '&dpop-uri-mismatch + &external-error + '(signed requested))) + +(define-public (raise-dpop-uri-mismatch signed requested) + (raise-exception + ((record-constructor &dpop-uri-mismatch) signed requested))) + +(define-public &dpop-signed-in-future + (make-exception-type + '&dpop-signed-in-future + &external-error + '(signed requested))) + +(define-public (raise-dpop-signed-in-future signed requested) + (raise-exception + ((record-constructor &dpop-signed-in-future) signed requested))) + +(define-public &dpop-too-old + (make-exception-type + '&dpop-too-old + &external-error + '(signed requested))) + +(define-public (raise-dpop-too-old signed requested) + (raise-exception + ((record-constructor &dpop-too-old) signed requested))) + +(define-public &dpop-unconfirmed-key + (make-exception-type + '&dpop-unconfirmed-key + &external-error + '(key expected cause))) + +(define-public (raise-dpop-unconfirmed-key key expected cause) + (raise-exception + ((record-constructor &dpop-unconfirmed-key) key expected cause))) + +(define-public &jti-found + (make-exception-type + '&jti-found + &external-error + '(jti cause))) + +(define-public (raise-jti-found jti cause) + (raise-exception + ((record-constructor &jti-found) jti cause))) + (define-public &cannot-decode-access-token (make-exception-type '&cannot-decode-access-token @@ -367,6 +509,26 @@ (raise-exception ((record-constructor &cannot-encode-access-token) access-token key cause))) +(define-public &cannot-decode-dpop-proof + (make-exception-type + '&cannot-decode-dpop-proof + &external-error + '(value cause))) + +(define-public (raise-cannot-decode-dpop-proof value cause) + (raise-exception + ((record-constructor &cannot-decode-dpop-proof) value cause))) + +(define-public &cannot-encode-dpop-proof + (make-exception-type + '&cannot-encode-dpop-proof + &external-error + '(dpop-proof key cause))) + +(define-public (raise-cannot-encode-dpop-proof dpop-proof key cause) + (raise-exception + ((record-constructor &cannot-encode-dpop-proof) dpop-proof key cause))) + (define*-public (error->str err #:key (max-depth #f)) (if (record? err) (let* ((type (record-type-descriptor err)) @@ -497,39 +659,108 @@ (if value (format #f (G_ "the client-id field is incorrect: ~s") value) (format #f (G_ "the client-id field is missing"))))) + ((&incorrect-typ-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the typ field is incorrect: ~s") value) + (format #f (G_ "the typ field is missing"))))) + ((&incorrect-jwk-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the jwk field is incorrect: ~s (because ~a)") + value (recurse (get 'cause))) + (format #f (G_ "the jwk field is missing"))))) + ((&incorrect-jti-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the jti field is incorrect: ~s") value) + (format #f (G_ "the jti field is missing"))))) + ((&incorrect-htm-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the htm field is incorrect: ~s") value) + (format #f (G_ "the htm field is missing"))))) + ((&incorrect-htu-field) + (let ((value (get 'value))) + (if value + (format #f (G_ "the htu field is incorrect: ~s") value) + (format #f (G_ "the htu field is missing"))))) ((¬-an-access-token) - (format #f (G_ "~s is not an access token (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token (because ~a)") + (get 'value) (recurse (get 'cause)))) ((¬-an-access-token-header) - (format #f (G_ "~s is not an access token header (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token header (because ~a)") + (get 'value) (recurse (get 'cause)))) ((¬-an-access-token-payload) - (format #f (G_ "~s is not an access token payload (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "~s is not an access token payload (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof) + (format #f (G_ "~s is not a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof-header) + (format #f (G_ "~s is not a DPoP proof header (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((¬-a-dpop-proof-payload) + (format #f (G_ "~s is not a DPoP proof payload (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&cannot-fetch-issuer-configuration) - (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)" - (let ((iss (get 'issuer))) - (when (uri? iss) - (set! iss (uri->string iss))) - iss) - (recurse (get 'cause))))) + (format #f (G_ "I cannot fetch the issuer configuration of ~a (because ~a)") + (let ((iss (get 'issuer))) + (when (uri? iss) + (set! iss (uri->string iss))) + iss) + (recurse (get 'cause)))) ((&cannot-fetch-jwks) - (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)" - (let ((iss (get 'issuer))) - (when (uri? iss) - (set! iss (uri->string iss))) - iss) - (let ((uri (get 'uri))) - (when (uri? uri) - (set! uri (uri->string uri))) - uri) - (recurse (get 'cause))))) + (format #f (G_ "I cannot fetch the JWKS of ~a at ~a (because ~a)") + (let ((iss (get 'issuer))) + (when (uri? iss) + (set! iss (uri->string iss))) + iss) + (let ((uri (get 'uri))) + (when (uri? uri) + (set! uri (uri->string uri))) + uri) + (recurse (get 'cause)))) + ((&dpop-method-mismatch) + (format #f (G_ "the HTTP method is signed for ~s, but ~s was requested") + (get 'signed) (get 'requested))) + ((&dpop-uri-mismatch) + (format #f (G_ "the HTTP uri is signed for ~a, but ~a was requested") + (uri->string (get 'signed)) (uri->string (get 'requested)))) + ((&dpop-signed-in-future) + (format #f (G_ "the date is ~a, but the DPoP proof is signed in the future at ~a") + (time-second (date->time-utc (get 'signed))) + (time-second (date->time-utc (get 'requested))))) + ((&dpop-too-old) + (format #f (G_ "the date is ~a, but the DPoP proof was signed too long ago at ~a") + (time-second (date->time-utc (get 'signed))) + (time-second (date->time-utc (get 'requested))))) + ((&dpop-unconfirmed-key) + (let ((key (get 'key)) + (expected (get 'expected)) + (cause (get 'cause))) + (cond + (expected + (format #f (G_ "the key ~s does not hash to ~a") key expected)) + (cause + (format #f (G_ "the key confirmation of ~s failed (because ~a)") key (recurse cause))) + (else + (format #f (G_ "the key confirmation of ~s failed") key))))) + ((&jti-found) + (format #f (G_ "the jti ~s has already been found (because ~a)") + (get 'jti) (recurse (get 'cause)))) ((&cannot-decode-access-token) - (format #f (G_ "I cannot decode ~s as an access token (because ~a)" - (get 'value) (recurse (get 'cause))))) + (format #f (G_ "I cannot decode ~s as an access token (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&cannot-encode-access-token) (format #f (G_ "I cannot encode ~s as an access token with key ~s (because ~a)") (get 'access-token) (get 'key) (recurse (get 'cause)))) + ((&cannot-decode-dpop-proof) + (format #f (G_ "I cannot decode ~s as a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) + ((&cannot-encode-dpop-proof) + (format #f (G_ "I cannot encode ~s as a DPoP proof (because ~a)") + (get 'value) (recurse (get 'cause)))) ((&compound-exception) (let ((components (get 'components))) (if (null? components) @@ -564,6 +795,10 @@ ((&quit-exception) (format #f (G_ "the program quits with code ~a") (get 'code))) + ((&non-continuable) + (format #f (G_ "the program cannot recover from this exception"))) + ((&error) + (format #f (G_ "there is an error"))) (else (error (format #f (G_ "Unhandled exception type ~a.") (record-type-name type)))))) |