Switch to a more sensible error reporting system

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 &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-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 &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 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 &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)))
+  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 &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)
-  (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 &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 &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
-  &not-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 &not-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)
-          ((&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")))))
-          ((&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")))))
-          ((&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 '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))))
-          ((&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))))
-          ((&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))))
-          ((&not-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))))