diff options
Diffstat (limited to 'src/scm/webid-oidc/errors.scm')
-rw-r--r-- | src/scm/webid-oidc/errors.scm | 1515 |
1 files changed, 23 insertions, 1492 deletions
diff --git a/src/scm/webid-oidc/errors.scm b/src/scm/webid-oidc/errors.scm index 1c7d539..4e24659 100644 --- a/src/scm/webid-oidc/errors.scm +++ b/src/scm/webid-oidc/errors.scm @@ -18,1505 +18,36 @@ #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (ice-9 exceptions) #:use-module (ice-9 optargs) - #:use-module (ice-9 i18n) + #:use-module (ice-9 match) #:use-module (srfi srfi-19) #:use-module (web uri) #:use-module (web response) - #:use-module (web client)) + #:use-module (web client) + #:declarative? #t + #:export + ( + &message-for-the-user + make-message-for-the-user + message-for-the-user? + user-message -(define (G_ text) - (let ((out (gettext text))) - (if (string=? out text) - ;; No translation, disambiguate - (car (reverse (string-split text #\|))) - out))) + fail + )) -;; This is a collection of all errors that can happen, and a function -;; to log them. - -(define-public ¬-base64 - (make-exception-type - '¬-base64 - &external-error - '(value cause))) - -(define-public (raise-not-base64 value cause) - (raise-exception - ((record-constructor ¬-base64) value cause))) - -(define-public ¬-json - (make-exception-type - '¬-json - &external-error - '(value cause))) - -(define-public (raise-not-json value cause) - (raise-exception - ((record-constructor ¬-json) value cause))) - -(define-public ¬-turtle - (make-exception-type - '¬-turtle - &external-error - '(value cause))) - -(define-public (raise-not-turtle value cause) - (raise-exception - ((record-constructor ¬-turtle) value cause))) - -(define-public &unsupported-crv - (make-exception-type - '&unsupported-crv - &external-error - '(crv))) - -(define-public (raise-unsupported-crv crv) - (raise-exception - ((record-constructor &unsupported-crv) crv))) - -(define-public ¬-a-jwk - (make-exception-type - '¬-a-jwk - &external-error - '(value cause))) - -(define-public (raise-not-a-jwk value cause) - (raise-exception - ((record-constructor ¬-a-jwk) value cause))) - -(define-public ¬-a-public-jwk - (make-exception-type - '¬-a-public-jwk - &external-error - '(value cause))) - -(define-public (raise-not-a-public-jwk value cause) - (raise-exception - ((record-constructor ¬-a-public-jwk) value cause))) - -(define-public ¬-a-private-jwk - (make-exception-type - '¬-a-private-jwk - &external-error - '(value cause))) - -(define-public (raise-not-a-private-jwk value cause) - (raise-exception - ((record-constructor ¬-a-private-jwk) value cause))) - -(define-public ¬-a-jwks - (make-exception-type - '¬-a-jwks - &external-error - '(value cause))) - -(define-public (raise-not-a-jwks value cause) - (raise-exception - ((record-constructor ¬-a-jwks) value cause))) - -(define-public &unsupported-alg - (make-exception-type - '&unsupported-alg - &external-error - '(value))) - -(define-public (raise-unsupported-alg value) - (raise-exception - ((record-constructor &unsupported-alg) value))) - -(define-public &invalid-signature - (make-exception-type - '&invalid-signature - &external-error - '(key payload signature))) - -(define-public (raise-invalid-signature key payload signature) - (raise-exception - ((record-constructor &invalid-signature) key payload signature))) - -(define-public ¬-a-jws-header - (make-exception-type - '¬-a-jws-header - &external-error - '(value cause))) - -(define-public (raise-not-a-jws-header value cause) - (raise-exception - ((record-constructor ¬-a-jws-header) value cause))) - -(define-public ¬-a-jws-payload - (make-exception-type - '¬-a-jws-payload - &external-error - '(value cause))) - -(define-public (raise-not-a-jws-payload value cause) - (raise-exception - ((record-constructor ¬-a-jws-payload) value cause))) - -(define-public ¬-a-jws - (make-exception-type - '¬-a-jws - &external-error - '(value cause))) - -(define-public (raise-not-a-jws value cause) - (raise-exception - ((record-constructor ¬-a-jws-payload) value cause))) - -(define-public ¬-in-3-parts - (make-exception-type - '¬-in-3-parts - &external-error - '(string separator))) - -(define-public (raise-not-in-3-parts string separator) - (raise-exception - ((record-constructor ¬-in-3-parts) string separator))) - -(define-public &missing-alist-key - (make-exception-type - '&missing-alist-key - &external-error - '(value key))) - -(define-public (raise-missing-alist-key value key) - (raise-exception - ((record-constructor &missing-alist-key) value key))) - -(define-public &no-matching-key - (make-exception-type - '&no-matching-key - &external-error - '(candidates alg payload signature other-problems))) - -(define-public (raise-no-matching-key candidates alg payload signature) - (raise-exception - ((record-constructor &no-matching-key) candidates alg payload signature))) - -(define-public &cannot-decode-jws - (make-exception-type - '&cannot-decode-jws - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-jws value cause) - (raise-exception - ((record-constructor &cannot-decode-jws) value cause))) - -(define-public &cannot-encode-jws - (make-exception-type - '&cannot-encode-jws - &external-error - '(jws key cause))) - -(define-public (raise-cannot-encode-jws jws key cause) - (raise-exception - ((record-constructor &cannot-encode-jws) jws key cause))) - -(define-public &request-failed-unexpectedly - (make-exception-type - '&request-failed-unexpectedly - &external-error - '(response-code response-reason-phrase))) - -(define-public (raise-request-failed-unexpectedly - response-code response-reason-phrase) - (raise-exception - ((record-constructor &request-failed-unexpectedly) - response-code response-reason-phrase))) - -(define-public &unexpected-header-value - (make-exception-type - '&unexpected-header-value - &external-error - '(header value))) - -(define-public (raise-unexpected-header-value header value) - (raise-exception - ((record-constructor &unexpected-header-value) header value))) - -(define-public &unexpected-response - (make-exception-type - '&unexpected-response - &external-error - '(response cause))) - -(define-public (raise-unexpected-response response cause) - (raise-exception - ((record-constructor &unexpected-response) response cause))) - -(define-public ¬-an-oidc-configuration - (make-exception-type - '¬-an-oidc-configuration - &external-error - '(value cause))) - -(define-public (raise-not-an-oidc-configuration value cause) - (raise-exception - ((record-constructor ¬-an-oidc-configuration) value cause))) - -(define-public &incorrect-webid-field - (make-exception-type - '&incorrect-webid-field - &external-error - '(value))) - -(define-public (raise-incorrect-webid-field value) - (raise-exception - ((record-constructor &incorrect-webid-field) value))) - -(define-public &incorrect-sub-field - (make-exception-type - '&incorrect-sub-field - &external-error - '(value))) - -(define-public (raise-incorrect-sub-field value) - (raise-exception - ((record-constructor &incorrect-sub-field) value))) - -(define-public &incorrect-iss-field - (make-exception-type - '&incorrect-iss-field - &external-error - '(value))) - -(define-public (raise-incorrect-iss-field value) - (raise-exception - ((record-constructor &incorrect-iss-field) value))) - -(define-public &incorrect-aud-field - (make-exception-type - '&incorrect-aud-field - &external-error - '(value))) - -(define-public (raise-incorrect-aud-field value) - (raise-exception - ((record-constructor &incorrect-aud-field) value))) - -(define-public &incorrect-iat-field - (make-exception-type - '&incorrect-iat-field - &external-error - '(value))) - -(define-public (raise-incorrect-iat-field value) - (raise-exception - ((record-constructor &incorrect-iat-field) value))) - -(define-public &incorrect-exp-field - (make-exception-type - '&incorrect-exp-field - &external-error - '(value))) - -(define-public (raise-incorrect-exp-field value) - (raise-exception - ((record-constructor &incorrect-exp-field) value))) - -(define-public &incorrect-cnf/jkt-field - (make-exception-type - '&incorrect-cnf/jkt-field - &external-error - '(value))) - -(define-public (raise-incorrect-cnf/jkt-field value) - (raise-exception - ((record-constructor &incorrect-cnf/jkt-field) value))) - -(define-public &incorrect-client-id-field - (make-exception-type - '&incorrect-client-id-field - &external-error - '(value))) - -(define-public (raise-incorrect-client-id-field value) - (raise-exception - ((record-constructor &incorrect-client-id-field) value))) - -(define-public &incorrect-redirect-uris-field - (make-exception-type - '&incorrect-redirect-uris-field - &external-error - '(value))) - -(define-public (raise-incorrect-redirect-uris-field value) - (raise-exception - ((record-constructor &incorrect-redirect-uris-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-nonce-field - (make-exception-type - '&incorrect-nonce-field - &external-error - '(value))) - -(define-public (raise-incorrect-nonce-field value) - (raise-exception - ((record-constructor &incorrect-nonce-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-exception-type - &incorrect-ath-field - &external-error - make-incorrect-ath-field - incorrect-ath-field? - (value incorrect-ath-field-value)) - -(export &incorrect-ath-field - make-incorrect-ath-field - incorrect-ath-field? - incorrect-ath-field-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 - &external-error - '(value cause))) - -(define-public (raise-not-an-access-token value cause) - (raise-exception - ((record-constructor ¬-an-access-token) value cause))) - -(define-public ¬-an-access-token-header - (make-exception-type - '¬-an-access-token-header - &external-error - '(value cause))) - -(define-public (raise-not-an-access-token-header value cause) - (raise-exception - ((record-constructor ¬-an-access-token-header) value cause))) - -(define-public ¬-an-access-token-payload - (make-exception-type - '¬-an-access-token-payload - &external-error - '(value cause))) - -(define-public (raise-not-an-access-token-payload value cause) - (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 - &external-error - '(issuer cause))) - -(define*-public (raise-cannot-fetch-issuer-configuration issuer cause #:key (recoverable? #f)) - (raise-exception - ((record-constructor &cannot-fetch-issuer-configuration) issuer cause) - #:continuable? recoverable?)) - -(define-public &cannot-fetch-jwks - (make-exception-type - '&cannot-fetch-jwks - &external-error - '(issuer uri cause))) - -(define-public (raise-cannot-fetch-jwks issuer uri cause) - (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 current))) - -(define (the-date object) - (when (integer? object) - (set! object (make-time time-utc 0 object))) - (when (time? object) - (set! object (time-utc->date object))) - object) - -(define-public (raise-dpop-signed-in-future signed current) - (raise-exception - ((record-constructor &dpop-signed-in-future) (the-date signed) (the-date current)))) - -(define-public &dpop-too-old - (make-exception-type - '&dpop-too-old - &external-error - '(signed current))) - -(define-public (raise-dpop-too-old signed current) - (raise-exception - ((record-constructor &dpop-too-old) (the-date signed) (the-date current)))) - -(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))) +;; A message to show the user is an XHTML paragraph or equivalent (as +;; sxml). A div is used to contain multiple messages. (define-exception-type - &dpop-invalid-access-token-hash + &message-for-the-user &external-error - make-dpop-invalid-access-token-hash - dpop-invalid-access-token-hash? - (hash dpop-invalid-access-token-hash-hash) - (access-token dpop-invalid-access-token-hash-access-token)) - -(export &dpop-invalid-access-token-hash - make-dpop-invalid-access-token-hash - dpop-invalid-access-token-hash? - dpop-invalid-access-token-hash-hash - dpop-invalid-access-token-hash-access-token) - -(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 - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-access-token value cause) - (raise-exception - ((record-constructor &cannot-decode-access-token) value cause))) - -(define-public &cannot-encode-access-token - (make-exception-type - '&cannot-encode-access-token - &external-error - '(access-token key cause))) - -(define-public (raise-cannot-encode-access-token access-token key cause) - (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 &cannot-fetch-linked-data - (make-exception-type - '&cannot-fetch-linked-data - &external-error - '(uri cause))) - -(define-public (raise-cannot-fetch-linked-data uri cause) - (raise-exception - ((record-constructor &cannot-fetch-linked-data) uri cause))) - -(define-public ¬-a-client-manifest - (make-exception-type - '¬-a-client-manifest - &external-error - '(value cause))) - -(define-public (raise-not-a-client-manifest value cause) - (raise-exception - ((record-constructor ¬-a-client-manifest) value cause))) - -(define-public &unauthorized-redirection-uri - (make-exception-type - '&unauthorized-redirection-uri - &external-error - '(manifest uri))) - -(define-public (raise-unauthorized-redirection-uri manifest uri) - (raise-exception - ((record-constructor &unauthorized-redirection-uri) manifest uri))) - -(define-public &cannot-serve-public-manifest - (make-exception-type - '&cannot-serve-public-manifest - &external-error - '())) - -(define-public (raise-cannot-serve-public-manifest) - (raise-exception - ((record-constructor &cannot-serve-public-manifest)))) - -(define-public &no-client-manifest-registration - (make-exception-type - '&no-client-manifest-registration - &external-error - '(id))) - -(define-public (raise-no-client-manifest-registration id) - (raise-exception - ((record-constructor &no-client-manifest-registration) id))) - -(define-public &inconsistent-client-manifest-id - (make-exception-type - '&inconsistent-client-manifest-id - &external-error - '(id advertised-id))) - -(define-public (raise-inconsistent-client-manifest-id id advertised-id) - (raise-exception - ((record-constructor &inconsistent-client-manifest-id) id advertised-id))) + make-message-for-the-user + message-for-the-user? + (message user-message)) -(define-public &cannot-fetch-client-manifest - (make-exception-type - '&cannot-fetch-client-manifest - &external-error - '(id cause))) - -(define-public (raise-cannot-fetch-client-manifest id cause) - (raise-exception - ((record-constructor &cannot-fetch-client-manifest) id cause))) - -(define-public ¬-an-authorization-code - (make-exception-type - '¬-an-authorization-code - &external-error - '(value cause))) - -(define-public (raise-not-an-authorization-code value cause) - (raise-exception - ((record-constructor ¬-an-authorization-code) value cause))) - -(define-public ¬-an-authorization-code-header - (make-exception-type - '¬-an-authorization-code-header - &external-error - '(value cause))) - -(define-public (raise-not-an-authorization-code-header value cause) - (raise-exception - ((record-constructor ¬-an-authorization-code-header) value cause))) - -(define-public ¬-an-authorization-code-payload - (make-exception-type - '¬-an-authorization-code-payload - &external-error - '(value cause))) - -(define-public (raise-not-an-authorization-code-payload value cause) - (raise-exception - ((record-constructor ¬-an-authorization-code-payload) value cause))) - -(define-public &authorization-code-expired - (make-exception-type - '&authorization-code-expired - &external-error - '(exp current-time))) - -(define-public (raise-authorization-code-expired exp current-time) - (raise-exception - ((record-constructor &authorization-code-expired) - (the-date exp) - (the-date current-time)))) - -(define-public &cannot-decode-authorization-code - (make-exception-type - '&cannot-decode-authorization-code - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-authorization-code value cause) - (raise-exception - ((record-constructor &cannot-decode-authorization-code) value cause))) - -(define-public &cannot-encode-authorization-code - (make-exception-type - '&cannot-encode-authorization-code - &external-error - '(authorization-code key cause))) - -(define-public (raise-cannot-encode-authorization-code authorization-code key cause) +(define (fail message) + ;; Like error, but don’t do funny things when message is not a + ;; string literal (raise-exception - ((record-constructor &cannot-encode-authorization-code) authorization-code key cause))) - -(define-public &invalid-refresh-token - (make-exception-type - '&invalid-refresh-token - &external-error - '(refresh-token))) - -(define-public (raise-invalid-refresh-token refresh-token) - (raise-exception - ((record-constructor &invalid-refresh-token) refresh-token))) - -(define-public &invalid-key-for-refresh-token - (make-exception-type - '&invalid-key-for-refresh-token - &external-error - '(key jkt))) - -(define-public (raise-invalid-key-for-refresh-token key jkt) - (raise-exception - ((record-constructor &invalid-key-for-refresh-token) key jkt))) - -(define-public ¬-an-id-token - (make-exception-type - '¬-an-id-token - &external-error - '(value cause))) - -(define-public (raise-not-an-id-token value cause) - (raise-exception - ((record-constructor ¬-an-id-token) value cause))) - -(define-public ¬-an-id-token-header - (make-exception-type - '¬-an-id-token-header - &external-error - '(value cause))) - -(define-public (raise-not-an-id-token-header value cause) - (raise-exception - ((record-constructor ¬-an-id-token-header) value cause))) - -(define-public ¬-an-id-token-payload - (make-exception-type - '¬-an-id-token-payload - &external-error - '(value cause))) - -(define-public (raise-not-an-id-token-payload value cause) - (raise-exception - ((record-constructor ¬-an-id-token-payload) value cause))) - -(define-public &cannot-decode-id-token - (make-exception-type - '&cannot-decode-id-token - &external-error - '(value cause))) - -(define-public (raise-cannot-decode-id-token value cause) - (raise-exception - ((record-constructor &cannot-decode-id-token) value cause))) - -(define-public &cannot-encode-id-token - (make-exception-type - '&cannot-encode-id-token - &external-error - '(id-token key cause))) - -(define-public (raise-cannot-encode-id-token id-token key cause) - (raise-exception - ((record-constructor &cannot-encode-id-token) id-token key cause))) - -(define-public &unknown-client-locale - (make-exception-type - '&unknown-client-locale - &external-error - '(web-locale c-locale))) - -(define-public (raise-unknown-client-locale web-locale c-locale) - (raise-exception - ((record-constructor &unknown-client-locale) web-locale c-locale) - #:continuable? #t)) - -(define-public &unsupported-grant-type - (make-exception-type - '&unsupported-grant-type - &external-error - '(value))) - -(define-public (raise-unsupported-grant-type value) - (raise-exception - ((record-constructor &unsupported-grant-type) value))) - -(define-public &no-authorization-code - (make-exception-type - '&no-authorization-code - &external-error - '(value))) - -(define-public (raise-no-authorization-code) - (raise-exception - ((record-constructor &no-authorization-code)))) - -(define-public &no-refresh-token - (make-exception-type - '&no-refresh-token - &external-error - '(value))) - -(define-public (raise-no-refresh-token) - (raise-exception - ((record-constructor &no-refresh-token)))) - -(define-public &unconfirmed-provider - (make-exception-type - '&unconfirmed-provider - &external-error - '(subject provider))) - -(define-public (raise-unconfirmed-provider subject provider) - (raise-exception - ((record-constructor &unconfirmed-provider) subject provider))) - -(define-public &neither-identity-provider-nor-webid - (make-exception-type - '&neither-identity-provider-nor-webid - &external-error - '(uri why-not-identity-provider why-not-webid))) - -(define-public (raise-neither-identity-provider-nor-webid uri why-not-identity-provider why-not-webid) - (raise-exception - ((record-constructor &neither-identity-provider-nor-webid) - uri why-not-identity-provider why-not-webid))) - -(define-public &profile-not-found - (make-exception-type - '&profile-not-found - &external-error - '(webid iss dir))) - -(define-public (raise-profile-not-found webid iss dir) - (raise-exception - ((record-constructor &profile-not-found) webid iss dir))) - -(define-public &no-provider-candidates - (make-exception-type - '&no-provider-candidates - &external-error - '(webid causes))) - -(define-public (raise-no-provider-candidates webid causes) - (raise-exception - ((record-constructor &no-provider-candidates) webid causes))) - -;; Server-side exceptions - -(define-exception-type - &path-not-found - &external-error - make-path-not-found - path-not-found? - (path path-not-found-path)) - -(export &path-not-found - make-path-not-found - path-not-found? - path-not-found-path) - -(define-exception-type - &auxiliary-resource-absent - &external-error - make-auxiliary-resource-absent - auxiliary-resource-absent? - (path auxiliary-resource-absent-path) - (kind auxiliary-resource-absent-kind)) - -(export &auxiliary-resource-absent - make-auxiliary-resource-absent - auxiliary-resource-absent? - auxiliary-resource-absent-path - auxiliary-resource-absent-kind) - -(define-exception-type - &uri-slash-semantics-error - &external-error - make-uri-slash-semantics-error - uri-slash-semantics-error? - (path uri-slash-semantics-error-path) - (expected-path uri-slash-semantics-error-expected-path)) - -(export &uri-slash-semantics-error - make-uri-slash-semantics-error - uri-slash-semantics-error? - uri-slash-semantics-error-path - uri-slash-semantics-error-expected-path) - -(define-exception-type - &cannot-delete-root - &external-error - make-cannot-delete-root - cannot-delete-root?) - -(export &cannot-delete-root - make-cannot-delete-root - cannot-delete-root?) - -(define-exception-type - &container-not-empty - &external-error - make-container-not-empty - container-not-empty? - (path container-not-empty-path)) - -(export &container-not-empty - make-container-not-empty - container-not-empty? - container-not-empty-path) - -(define-exception-type - &cannot-fetch-group - &warning - make-cannot-fetch-group - cannot-fetch-group? - (group-uri cannot-fetch-group-group-uri) - (cause cannot-fetch-group-cause)) - -(export &cannot-fetch-group - make-cannot-fetch-group - cannot-fetch-group? - cannot-fetch-group-group-uri - cannot-fetch-group-cause) - -(define-exception-type - &incorrect-containment-triples - &external-error - make-incorrect-containment-triples - incorrect-containment-triples? - (path incorrect-containment-triples-path)) - -(export &incorrect-containment-triples - make-incorrect-containment-triples - incorrect-containment-triples? - incorrect-containment-triples-path) - -(define-exception-type - &unsupported-media-type - &external-error - make-unsupported-media-type - unsupported-media-type? - (content-type unsupported-media-type-content-type)) - -(export &unsupported-media-type - make-unsupported-media-type - unsupported-media-type? - unsupported-media-type-content-type) - -(define-exception-type - &path-is-auxiliary - &external-error - make-path-is-auxiliary - path-is-auxiliary? - (path path-is-auxiliary-path)) - -(export &path-is-auxiliary - make-path-is-auxiliary - path-is-auxiliary? - path-is-auxiliary-path) - -(define-exception-type - &forbidden - &external-error - make-forbidden - forbidden? - (path forbidden-path) - (user forbidden-user) - (owner forbidden-owner) - (mode forbidden-mode)) - -(export &forbidden - make-forbidden - forbidden? - forbidden-path - forbidden-user - forbidden-owner - forbidden-mode) - -(define-exception-type - &precondition-failed - &external-error - make-precondition-failed - precondition-failed? - (path precondition-failed-path) - (if-match precondition-failed-if-match) - (if-none-match precondition-failed-if-none-match) - (real-etag precondition-failed-real-etag)) - -(export &precondition-failed - make-precondition-failed - precondition-failed? - precondition-failed-path - precondition-failed-if-match - precondition-failed-if-none-match - precondition-failed-real-etag) - -(define-exception-type - ¬-acceptable - &external-error - make-not-acceptable - not-acceptable? - (client-accepts not-acceptable-client-accepts) - (path not-acceptable-path) - (content-type not-acceptable-content-type)) - -(export ¬-acceptable - make-not-acceptable - not-acceptable? - not-acceptable-client-accepts - not-acceptable-path - not-acceptable-content-type) - -(define*-public (error->str err #:key (max-depth #f)) - (if (record? err) - (let* ((type (record-type-descriptor err)) - (get - (lambda (slot) - ((record-accessor type slot) err))) - (recurse - (if (eqv? max-depth 0) - (lambda (err) (G_ "that’s how it is")) - (lambda (err) - (error->str err #:max-depth (and max-depth (- max-depth 1))))))) - (case (record-type-name type) - ((¬-base64) - (format #f (G_ "the value ~s is not a base64 string (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-json) - (format #f (G_ "the value ~s is not JSON (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-turtle) - (format #f (G_ "the value ~s is not Turtle (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&unsupported-crv) - (format #f (G_ "the value ~s does not identify an elleptic curve") - (get 'crv))) - ((¬-a-jwk) - (let ((cause (get 'cause))) - (if cause - (format #f (G_ "the value ~s does not identify a JWK (because ~a)") - (get 'value) (recurse cause)) - (format #f (G_ "the value ~s does not identify a JWK") - (get 'value))))) - ((¬-a-public-jwk) - (let ((cause (get 'cause))) - (if cause - (format #f (G_ "the value ~s does not identify a public JWK (because ~a)") - (get 'value) (recurse cause)) - (format #f (G_ "the value ~s does not identify a public JWK") - (get 'value))))) - ((¬-a-private-jwk) - (let ((cause (get 'cause))) - (if cause - (format #f (G_ "the value ~s does not identify a private JWK (because ~a)") - (get 'value) cause) - (format #f (G_ "the value ~s does not identify a private JWK") - (get 'value))))) - ((¬-a-jwks) - (let ((cause (get 'cause))) - (if cause - (format #f (G_ "the value ~s does not identify a JWKS (because ~a)") - (get 'value) (recurse cause)) - (format #f (G_ "the value ~s does not identify a JWKS") - (get 'value))))) - ((&unsupported-alg) - (format #f (G_ "the value ~s does not identify a hash algorithm") - (get 'value))) - ((&missing-alist-key) - (format #f (G_ "the value ~s is not an alist or misses key ~s") - (get 'value) (get 'key))) - ((¬-a-jws-header) - (format #f (G_ "the value ~s is not a JWS header (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-a-jws-payload) - (format #f (G_ "the value ~s is not a JWS payload (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-a-jws) - (format #f (G_ "the value ~s is not a JWS (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-in-3-parts) - (format #f (G_ "the string ~s cannot be split in 3 parts with ~s") - (get 'string) (get 'separator))) - ((&no-matching-key) - (format #f (G_ "all key candidates failed to verify signature ~s with algorithm ~s and payload ~a (there were ~a: ~s)") - (get 'signature) (get 'alg) (get 'payload) (length (get 'candidates)) (get 'candidates))) - ((&cannot-decode-jws) - (format #f (G_ "I cannot decode JWS ~a (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-encode-jws) - (format #f (G_ "I cannot encode JWS ~a (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&response-failed-unexpectedly) - (format #f (G_ "the server request unexpectedly failed with code ~a and reason phrase ~s") - (get 'response-code) (get 'response-reason-phrase))) - ((&unexpected-header-value) - (let ((value (get 'value))) - (if value - (format #f (G_ "the header ~a should not have the value ~s") - (get 'header) value) - (format #f (G_ "the header ~a should be present") - (get 'header))))) - ((&unexpected-response) - (format #f (G_ "the server response wasn't expected: ~s (because ~a)") - (call-with-output-string - (lambda (port) - (write-response (get 'response) port))) - (recurse (get 'cause)))) - ((¬-an-oidc-configuration) - (format #f (G_ "the value ~s is not an OIDC configuration (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&incorrect-webid-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the webid field is incorrect: ~s") value) - (format #f (G_ "the webid field is missing"))))) - ((&incorrect-sub-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the sub field is incorrect: ~s") value) - (format #f (G_ "the sub field is missing"))))) - ((&incorrect-iss-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the iss field is incorrect: ~s") value) - (format #f (G_ "the iss field is missing"))))) - ((&incorrect-aud-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the aud field is incorrect: ~s") value) - (format #f (G_ "the aud field is missing"))))) - ((&incorrect-iat-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the iat field is incorrect: ~s") value) - (format #f (G_ "the iat field is missing"))))) - ((&incorrect-exp-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the exp field is incorrect: ~s") value) - (format #f (G_ "the exp field is missing"))))) - ((&incorrect-cnf/jkt-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the cnf/jkt field is incorrect: ~s") value) - (format #f (G_ "the cnf/jkt field is missing"))))) - ((&incorrect-client-id-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the client-id field is incorrect: ~s") value) - (format #f (G_ "the client-id field is missing"))))) - ((&incorrect-redirect-uris-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the redirect_uris field is incorrect: ~s") value) - (format #f (G_ "the redirect_uris 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-nonce-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the nonce field is incorrect: ~s") value) - (format #f (G_ "the nonce 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"))))) - ((&incorrect-ath-field) - (let ((value (get 'value))) - (if value - (format #f (G_ "the ath field is incorrect: ~s") value) - (format #f (G_ "the ath field is missing"))))) - ((¬-an-access-token) - (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)))) - ((¬-an-access-token-payload) - (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)))) - ((&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)))) - ((&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 'current))) - (time-second (date->time-utc (get 'signed))))) - ((&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 'current))) - (time-second (date->time-utc (get 'signed))))) - ((&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))))) - ((&dpop-invalid-access-token-hash) - (let ((h (get 'hash)) - (at (get 'access-token))) - (if h - (format #f (G_ "the DPoP proof is bound to an access token with hash ~s, not ~s") - h at) - (format #f (G_ "the DPoP proof should be bound to the access token ~s") - at)))) - ((&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)))) - ((&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)))) - ((&cannot-fetch-linked-data) - (format #f (G_ "I could not fetch a RDF graph at ~a (because ~a)") - (uri->string (get 'uri)) (recurse (get 'cause)))) - ((¬-a-client-manifest) - (format #f (G_ "~s is not a client manifest (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&unauthorized-redirection-uri) - (format #f (G_ "~s does not authorize redirection URI ~a") - (get 'manifest) (uri->string (get 'uri)))) - ((&cannot-serve-public-manifest) - (format #f (G_ "I cannot serve a public manifest"))) - ((&no-client-manifest-registration) - (format #f (G_ "~a does not have a client manifest registration triple") - (uri->string (get 'id)))) - ((&inconsistent-client-manifest-id) - (format #f (G_ "the client manifest at ~a is advertised for ~a") - (uri->string (get 'id)) (uri->string (get 'advertised-id)))) - ((&cannot-fetch-client-manifest) - (format #f (G_ "I could not fetch the client manifest of ~a (because ~a)") - (uri->string (get 'id)) (recurse (get 'cause)))) - ((¬-an-authorization-code) - (format #f (G_ "~s is not an authorization code (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-authorization-code-header) - (format #f (G_ "~s is not an authorization code header (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-authorization-code-payload) - (format #f (G_ "~s is not an authorization code payload (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&authorization-code-expired) - (format #f (G_ "the current time is ~a, and the authorization code expired at ~a") - (time-second (date->time-utc (get 'current-time))) - (time-second (date->time-utc (get 'exp))))) - ((&cannot-decode-authorization-code) - (format #f (G_ "I cannot decode ~s as an authorization code (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-encode-authorization-code) - (format #f (G_ "I cannot encode ~s as an authorization code (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&invalid-refresh-token) - (format #f (G_ "there is no such refresh token as ~s") - (get 'refresh-token))) - ((&invalid-key-for-refresh-token) - (format #f (G_ "the refresh token is bound to a key confirmed as ~s, but it is used with key ~s") - (get 'jkt) (get 'key))) - ((&cannot-decode-id-token) - (format #f (G_ "I cannot decode ~s as an ID token (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&cannot-encode-id-token) - (format #f (G_ "I cannot encode ~s as an ID token (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&unsupported-grant-type) - (format #f (G_ "the grant type ~s is not supported") - (get 'value))) - ((&no-authorization-code) - (format #f (G_ "there is no authorization code in the request"))) - ((&no-refresh-token) - (format #f (G_ "there is no refresh token in the request"))) - ((¬-an-id-token) - (format #f (G_ "~s is not an ID token (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-id-token-header) - (format #f (G_ "~s is not an ID token header (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((¬-an-id-token-payload) - (format #f (G_ "~s is not an ID token payload (because ~a)") - (get 'value) (recurse (get 'cause)))) - ((&unknown-client-locale) - (format #f (G_ "I couldn’t set the locale to ~s as an approximation of the client locale ~s") - (get 'c-locale) (get 'web-locale))) - ((&unconfirmed-provider) - (format #f (G_ "~s does not admit ~s as an identity provider") - (get 'subject) (get 'provider))) - ((&neither-identity-provider-nor-webid) - (format #f (G_ "~a is neither an identity provider (because ~a) nor a webid (because ~a)") - (uri->string (get 'uri)) - (recurse (get 'why-not-identity-provider)) - (recurse (get 'why-not-webid)))) - ((&profile-not-found) - (format #f (G_ "you don’t have a refresh token for identity ~a certified by ~a in ~s") - (uri->string (get 'webid)) - (uri->string (get 'iss)) - (get 'dir))) - ((&no-provider-candidates) - (format #f (G_ "all identity provider candidates for ~a failed: ~a") - (uri->string (get 'webid)) - (string-join - (map (lambda (cause) - (format #f (G_ "~s failed (because ~a)") - (uri->string (car cause)) (recurse (cdr cause)))) - (get 'causes)) - (G_ ", ")))) - ((&path-not-found) - (format #f (G_ "no resource has been found to serve URI path ~s") - (get 'path))) - ((&auxiliary-resource-absent) - (format #f (G_ "the resource kind ~s is absent for the resource at ~s") - (get 'kind') (get 'path))) - ((&uri-slash-semantics-error) - (format #f (G_ "no resource has been found to serve URI path ~s, but ~s exists") - (get 'path) (get 'expected-path))) - ((&cannot-delete-root) - (format #f (G_ "the root storage cannot be deleted"))) - ((&container-not-empty) - (format #f (G_ "the container ~s should be emptied before being deleted") - (get 'path))) - ((&cannot-fetch-group) - (format #f (G_ "the group ~s cannot be fetched (because ~a)") - (uri->string (get 'group-uri)) - (recurse (get 'cause)))) - ((&incorrect-containment-triples) - (format #f (G_ "the containment triples in the request to update ~s are not up to date") - (get 'path))) - ((&unsupported-media-type) - (format #f (G_ "the server cannot process resources with the ~s content-type") - (get 'content-type))) - ((&path-is-auxiliary) - (format #f (G_ "the client wants to create a resource at ~s, which is reserved for an auxiliary resource") - (get 'path))) - ((&forbidden) - (format #f (G_ "the operation on ~s by ~a is refused, because it’s not by ~s and the access control forbids the following mode of operation: ~s") - (get 'path) - (if (get 'user) - (uri->string (get 'user)) - (G_ "an anonymous user")) - (uri->string (get 'owner)) - (uri->string (get 'mode)))) - ((&precondition-failed) - (if (get 'real-etag) - (format #f (G_ "the client precondition failed for ~s: it allows for ~s, forbids ~s, but the resource has a representation of ~s") - (get 'path) (get 'if-match) (get 'if-none-match) (get 'real-etag)) - (format #f (G_ "the client precondition failed for ~s: it allows for ~s, forbids ~s, but the resource has no representation") - (get 'path) (get 'if-match) (get 'if-none-match)))) - ((¬-acceptable) - (format #f (G_ "the client wanted a response with a content type among ~s, but the resource at ~s has content-type ~s which cannot be converted to one of them") - (get 'client-accepts) - (get 'path) - (get 'content-type))) - ((&compound-exception) - (let ((components (get 'components))) - (if (null? components) - (G_ "that’s it") - (if (null? (cdr components)) - (recurse (car components)) - (if (null? (cddr components)) - (format #f (G_ "~a and ~a") - (recurse (car components)) - (recurse (cadr components))) - (format #f (G_ "~a, ~a") - (recurse (car components)) - (recurse (apply make-exception (cdr components))))))))) - ((&invalid-signature) - (format #f (G_ "the signature ~a does not match key ~s with payload ~a") - (get 'signature) (get 'key) (get 'payload))) - ((&request-failed-unexpectedly) - (format #f (G_ "the request failed unexpectedly with code ~a: ~s") - (get 'response-code) - (get 'response-reason-phrase))) - ((&undefined-variable) - (G_ "there is an undefined variable")) - ((&origin) - (format #f (G_ "the origin is ~a") - (exception-origin err))) - ((&message) - (format #f (G_ "a message is attached: ~a") - (exception-message err))) - ((&irritants) - (format #f (G_ "the values ~s are problematic") - (exception-irritants err))) - ((&exception-with-kind-and-args) - (format #f (G_ "there is a kind (~s) and args ~s") - (get 'kind) (get 'args))) - ((&assertion-failure) - (format #f (G_ "there is an assertion failure"))) - ((&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"))) - ((&external-error) - (format #f (G_ "there is an external error"))) - ((&error) - (format #f (G_ "there is an error"))) - (else - (format #f (G_ "there is an unknown exception of kind ~s") - (record-type-name type))))) - (format #f "~a" err))) + (make-exception + (make-error) + (make-exception-with-message message)))) |