path: root/src/scm/webid-oidc/errors.scm

(define-module (webid-oidc errors)
  #:use-module ((webid-oidc stubs) #:prefix stubs:)
  #: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)
  (let ((out (gettext text)))
    (if (string=? out text)
        ;; No translation, disambiguate
        (car (reverse (string-split text #\|)))
        out)))

;; This is a collection of all errors that can happen, and a function
;; to log them.

(define-public &not-base64
  (make-exception-type
   '&not-base64
   &external-error
   '(value cause)))

(define-public (raise-not-base64 value cause)
  (raise-exception
   ((record-constructor &not-base64) value cause)))

(define-public &not-json
  (make-exception-type
   '&not-json
   &external-error
   '(value cause)))

(define-public (raise-not-json value cause)
  (raise-exception
   ((record-constructor &not-json) value cause)))

(define-public &not-turtle
  (make-exception-type
   '&not-turtle
   &external-error
   '(value cause)))

(define-public (raise-not-turtle value cause)
  (raise-exception
   ((record-constructor &not-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 &not-a-jwk
  (make-exception-type
   '&not-a-jwk
   &external-error
   '(value cause)))

(define-public (raise-not-a-jwk value cause)
  (raise-exception
   ((record-constructor &not-a-jwk) value cause)))

(define-public &not-a-public-jwk
  (make-exception-type
   '&not-a-public-jwk
   &external-error
   '(value cause)))

(define-public (raise-not-a-public-jwk value cause)
  (raise-exception
   ((record-constructor &not-a-public-jwk) value cause)))

(define-public &not-a-private-jwk
  (make-exception-type
   '&not-a-private-jwk
   &external-error
   '(value cause)))

(define-public (raise-not-a-private-jwk value cause)
  (raise-exception
   ((record-constructor &not-a-private-jwk) value cause)))

(define-public &not-a-jwks
  (make-exception-type
   '&not-a-jwks
   &external-error
   '(value cause)))

(define-public (raise-not-a-jwks value cause)
  (raise-exception
   ((record-constructor &not-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 &not-a-jws-header
  (make-exception-type
   '&not-a-jws-header
   &external-error
   '(value cause)))

(define-public (raise-not-a-jws-header value cause)
  (raise-exception
   ((record-constructor &not-a-jws-header) value cause)))

(define-public &not-a-jws-payload
  (make-exception-type
   '&not-a-jws-payload
   &external-error
   '(value cause)))

(define-public (raise-not-a-jws-payload value cause)
  (raise-exception
   ((record-constructor &not-a-jws-payload) value cause)))

(define-public &not-a-jws
  (make-exception-type
   '&not-a-jws
   &external-error
   '(value cause)))

(define-public (raise-not-a-jws value cause)
  (raise-exception
   ((record-constructor &not-a-jws-payload) value cause)))

(define-public &not-in-3-parts
  (make-exception-type
   '&not-in-3-parts
   &external-error
   '(string separator)))

(define-public (raise-not-in-3-parts string separator)
  (raise-exception
   ((record-constructor &not-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 &not-an-oidc-configuration
  (make-exception-type
   '&not-an-oidc-configuration
   &external-error
   '(value cause)))

(define-public (raise-not-an-oidc-configuration value cause)
  (raise-exception
   ((record-constructor &not-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-public (raise-incorrect-htu-field value)
  (raise-exception
   ((record-constructor &incorrect-htu-field) value)))

(define-public &not-an-access-token
  (make-exception-type
   '&not-an-access-token
   &external-error
   '(value cause)))

(define-public (raise-not-an-access-token value cause)
  (raise-exception
   ((record-constructor &not-an-access-token) value cause)))

(define-public &not-an-access-token-header
  (make-exception-type
   '&not-an-access-token-header
   &external-error
   '(value cause)))

(define-public (raise-not-an-access-token-header value cause)
  (raise-exception
   ((record-constructor &not-an-access-token-header) value cause)))

(define-public &not-an-access-token-payload
  (make-exception-type
   '&not-an-access-token-payload
   &external-error
   '(value cause)))

(define-public (raise-not-an-access-token-payload value cause)
  (raise-exception
   ((record-constructor &not-an-access-token-payload) value cause)))

(define-public &not-a-dpop-proof
  (make-exception-type
   '&not-a-dpop-proof
   &external-error
   '(value cause)))

(define-public (raise-not-a-dpop-proof value cause)
  (raise-exception
   ((record-constructor &not-a-dpop-proof) value cause)))

(define-public &not-a-dpop-proof-header
  (make-exception-type
   '&not-a-dpop-proof-header
   &external-error
   '(value cause)))

(define-public (raise-not-a-dpop-proof-header value cause)
  (raise-exception
   ((record-constructor &not-a-dpop-proof-header) value cause)))

(define-public &not-a-dpop-proof-payload
  (make-exception-type
   '&not-a-dpop-proof-payload
   &external-error
   '(value cause)))

(define-public (raise-not-a-dpop-proof-payload value cause)
  (raise-exception
   ((record-constructor &not-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 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
   &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 &not-a-client-manifest
  (make-exception-type
   '&not-a-client-manifest
   &external-error
   '(value cause)))

(define-public (raise-not-a-client-manifest value cause)
  (raise-exception
   ((record-constructor &not-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)))

(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 &not-an-authorization-code
  (make-exception-type
   '&not-an-authorization-code
   &external-error
   '(value cause)))

(define-public (raise-not-an-authorization-code value cause)
  (raise-exception
   ((record-constructor &not-an-authorization-code) value cause)))

(define-public &not-an-authorization-code-header
  (make-exception-type
   '&not-an-authorization-code-header
   &external-error
   '(value cause)))

(define-public (raise-not-an-authorization-code-header value cause)
  (raise-exception
   ((record-constructor &not-an-authorization-code-header) value cause)))

(define-public &not-an-authorization-code-payload
  (make-exception-type
   '&not-an-authorization-code-payload
   &external-error
   '(value cause)))

(define-public (raise-not-an-authorization-code-payload value cause)
  (raise-exception
   ((record-constructor &not-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)
  (when (integer? exp)
    (set! exp (make-time time-utc 0 exp)))
  (when (time? exp)
    (set! exp (time-utc->date exp)))
  (when (integer? current-time)
    (set! current-time (make-time time-utc 0 current-time)))
  (when (time? current-time)
    (set! current-time (time-utc->date current-time)))
  (raise-exception
   ((record-constructor &authorization-code-expired) exp 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)
  (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 &not-an-id-token
  (make-exception-type
   '&not-an-id-token
   &external-error
   '(value cause)))

(define-public (raise-not-an-id-token value cause)
  (raise-exception
   ((record-constructor &not-an-id-token) value cause)))

(define-public &not-an-id-token-header
  (make-exception-type
   '&not-an-id-token-header
   &external-error
   '(value cause)))

(define-public (raise-not-an-id-token-header value cause)
  (raise-exception
   ((record-constructor &not-an-id-token-header) value cause)))

(define-public &not-an-id-token-payload
  (make-exception-type
   '&not-an-id-token-payload
   &external-error
   '(value cause)))

(define-public (raise-not-an-id-token-payload value cause)
  (raise-exception
   ((record-constructor &not-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 &token-request-failed
  (make-exception-type
   '&token-request-failed
   &external-error
   '(cause)))

(define-public (raise-token-request-failed cause)
  (raise-exception
   ((record-constructor &token-request-failed) cause)))

(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
  &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*-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)
          ((&not-base64)
           (format #f (G_ "the value ~s is not a base64 string (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-json)
           (format #f (G_ "the value ~s is not JSON (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-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)))
          ((&not-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)))))
          ((&not-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)))))
          ((&not-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)))))
          ((&not-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)))
          ((&not-a-jws-header)
           (format #f (G_ "the value ~s is not a JWS header (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-a-jws-payload)
           (format #f (G_ "the value ~s is not a JWS payload (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-a-jws)
           (format #f (G_ "the value ~s is not a JWS (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-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))))
          ((&not-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")))))
          ((&not-an-access-token)
           (format #f (G_ "~s is not an access token (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-an-access-token-header)
           (format #f (G_ "~s is not an access token header (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-an-access-token-payload)
           (format #f (G_ "~s is not an access token payload (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-a-dpop-proof)
           (format #f (G_ "~s is not a DPoP proof (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-a-dpop-proof-header)
           (format #f (G_ "~s is not a DPoP proof header (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-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 '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))))
          ((&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))))
          ((&not-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))))
          ((&not-an-authorization-code)
           (format #f (G_ "~s is not an authorization code (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-an-authorization-code-header)
           (format #f (G_ "~s is not an authorization code header (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-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")))
          ((&not-an-id-token)
           (format #f (G_ "~s is not an ID token (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-an-id-token-header)
           (format #f (G_ "~s is not an ID token header (because ~a)")
                   (get 'value) (recurse (get 'cause))))
          ((&not-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))))
          ((&token-request-failed)
           (format #f (G_ "the token request failed (because ~a)")
                   (recurse (get 'cause))))
          ((&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)))
          ((&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)))
          ((&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)))
          ((&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 and 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")))
          ((&error)
           (format #f (G_ "there is an error")))
          (else
           (error (format #f (G_ "Unhandled exception type ~a.")
                          (record-type-name type))))))
      (format #f "~a" err)))