server: add an authenticator endpoint

7 files changed, 315 insertions, 117 deletions

diff --git a/doc/disfluid.texi b/doc/disfluid.texi
index 17a985c..de04b9b 100644
--- a/doc/disfluid.texi
+++ b/doc/disfluid.texi
@@ -1546,6 +1546,7 @@ the user.
 @menu
 * Error signalling::
 * Router endpoint::
+* Request authentication::
 * Reverse proxy::
 @end menu
 
@@ -1633,6 +1634,34 @@ turn, or return a 404 Not Found response if no endpoint is relevant.
 Return the list of endpoints for @var{router}.
 @end deffn
 
+@node Request authentication
+@section Request authentication
+The @emph{(webid-oidc server endpoint authentication)} defines an
+endpoint that authentifies the user and passes the annotated request
+to a backend endpoint.
+
+@deftp {Class} <authenticator> (<endpoint>) @var{backend} @var{server-uri}
+The authenticator calls the @var{backend} endpoint once it has
+authentified the user. If the authentication is successful, the
+request is annotated with a @code{'user} entry in the alist table
+containing the URI of the user. Otherwise, it is passed as is.
+
+To check the validity of the DPoP proof, the endpoint must know the
+public name of the server that is running, @var{server-uri}.
+
+It can be constructed with the @code{#:@var{backend}} and
+@code{#:@var{server-uri}} keyword arguments, respectively an endpoint
+and an URI.
+@end deftp
+
+@deffn {Generic} backend @var{authenticator}
+Return the backend endpoint of @var{authenticator}.
+@end deffn
+
+@deffn {Generic} server-uri @var{authenticator}
+Return the public server URI of @var{authenticator}.
+@end deffn
+
 @node Reverse proxy
 @section Reverse proxy
 The @emph{(webid-oidc server endpoint reverse-proxy)} module defines a
diff --git a/po/POTFILES.in b/po/POTFILES.in
index 13ec133..8154eb0 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -79,6 +79,7 @@ src/scm/webid-oidc/serve.scm
 src/scm/webid-oidc/server/create.scm
 src/scm/webid-oidc/server/delete.scm
 src/scm/webid-oidc/server/endpoint.scm
+src/scm/webid-oidc/server/endpoint/authentication.scm
 src/scm/webid-oidc/server/endpoint/reverse-proxy.scm
 src/scm/webid-oidc/server/log.scm
 src/scm/webid-oidc/server/precondition.scm
diff --git a/po/disfluid.pot b/po/disfluid.pot
index a4070f9..0163544 100644
--- a/po/disfluid.pot
+++ b/po/disfluid.pot
@@ -346,7 +346,7 @@ msgid "The application you are trying to authorize behaved unexpectedly."
 msgstr ""
 
 #: src/scm/webid-oidc/authorization-page-unsafe.scm:126
-#: src/scm/webid-oidc/resource-server.scm:317
+#: src/scm/webid-oidc/resource-server.scm:283
 msgid "reason-phrase|Found"
 msgstr ""
 
@@ -492,7 +492,7 @@ msgstr ""
 msgid "#:grant-types should be a list of symbols"
 msgstr ""
 
-#: src/scm/webid-oidc/client.scm:286 src/scm/webid-oidc/resource-server.scm:177
+#: src/scm/webid-oidc/client.scm:286 src/scm/webid-oidc/resource-server.scm:143
 msgid "reason-phrase|Not Modified"
 msgstr ""
 
@@ -1072,7 +1072,7 @@ msgid "The port should be a number between 0 and 65535.\n"
 msgstr ""
 
 #: src/scm/webid-oidc/hello-world.scm:159
-#: src/scm/webid-oidc/resource-server.scm:338
+#: src/scm/webid-oidc/resource-server.scm:304
 msgid "reason-phrase|Unauthorized"
 msgstr ""
 
@@ -1085,7 +1085,7 @@ msgid "<p>This page requires authentication with Solid.</p>"
 msgstr ""
 
 #: src/scm/webid-oidc/hello-world.scm:179
-#: src/scm/webid-oidc/resource-server.scm:346
+#: src/scm/webid-oidc/resource-server.scm:312
 msgid "reason-phrase|Method Not Allowed"
 msgstr ""
 
@@ -2124,64 +2124,54 @@ msgstr ""
 msgid "the refresh token is bound to key ~s, which is not that one"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:59
+#: src/scm/webid-oidc/resource-server.scm:71
 msgid ""
 "You need to pass #:server-uri URI where URI is the public URI of the server, "
 "as a (web uri)."
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:86
-#, scheme-format
-msgid "~a: authentication failure: ~a\n"
-msgstr ""
-
-#: src/scm/webid-oidc/resource-server.scm:90
-#, scheme-format
-msgid "~a: authentication failure\n"
-msgstr ""
-
-#: src/scm/webid-oidc/resource-server.scm:162
-#: src/scm/webid-oidc/resource-server.scm:369
+#: src/scm/webid-oidc/resource-server.scm:128
+#: src/scm/webid-oidc/resource-server.scm:335
 msgid "reason-phrase|Precondition Failed"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:199
+#: src/scm/webid-oidc/resource-server.scm:165
 msgid "The owner is not defined."
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:249
-#: src/scm/webid-oidc/resource-server.scm:272
+#: src/scm/webid-oidc/resource-server.scm:215
+#: src/scm/webid-oidc/resource-server.scm:238
 msgid "Bad Request"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:283
+#: src/scm/webid-oidc/resource-server.scm:249
 msgid "reason-phrase|Created"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:306
+#: src/scm/webid-oidc/resource-server.scm:272
 #, scheme-format
 msgid "~a: ignoring a group that cannot be fetched: ~a\n"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:310
+#: src/scm/webid-oidc/resource-server.scm:276
 #, scheme-format
 msgid "~a: ignoring a group that cannot be fetched\n"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:334
+#: src/scm/webid-oidc/resource-server.scm:300
 #: src/scm/webid-oidc/token-endpoint.scm:105
 msgid "reason-phrase|Forbidden"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:355
+#: src/scm/webid-oidc/resource-server.scm:321
 msgid "reason-phrase|Conflict"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:362
+#: src/scm/webid-oidc/resource-server.scm:328
 msgid "reason-phrase|Unsupported Media Type"
 msgstr ""
 
-#: src/scm/webid-oidc/resource-server.scm:376
+#: src/scm/webid-oidc/resource-server.scm:342
 msgid "reason-phrase|Not Acceptable"
 msgstr ""
 
@@ -2252,6 +2242,29 @@ msgstr ""
 msgid "The resource could not be found."
 msgstr ""
 
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:63
+msgid "#:backend should be an endpoint"
+msgstr ""
+
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:73
+msgid "#:server-uri should be an URI"
+msgstr ""
+
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:111
+#, scheme-format
+msgid "~a: authentication failure: ~a\n"
+msgstr ""
+
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:115
+#, scheme-format
+msgid "~a: authentication failure\n"
+msgstr ""
+
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:121
+msgid ""
+"<p>There is an access token and a DPoP proof, but one or both is invalid.</p>"
+msgstr ""
+
 #: src/scm/webid-oidc/server/endpoint/reverse-proxy.scm:77
 msgid "#:backend-uri should be an URI"
 msgstr ""
diff --git a/po/fr.po b/po/fr.po
index 685b701..cef462b 100644
--- a/po/fr.po
+++ b/po/fr.po
@@ -3,7 +3,7 @@ msgstr ""
 "Project-Id-Version: webid-oidc 0.0.0\n"
 "Report-Msgid-Bugs-To: vivien@planete-kraus.eu\n"
 "POT-Creation-Date: 2021-10-19 11:31+0200\n"
-"PO-Revision-Date: 2021-10-19 11:32+0200\n"
+"PO-Revision-Date: 2021-10-19 11:33+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
 "Language: fr\n"
@@ -378,7 +378,7 @@ msgstr ""
 "L’application que vous essayez d’autoriser se comporte de façon inattendue."
 
 #: src/scm/webid-oidc/authorization-page-unsafe.scm:126
-#: src/scm/webid-oidc/resource-server.scm:317
+#: src/scm/webid-oidc/resource-server.scm:283
 msgid "reason-phrase|Found"
 msgstr "Trouvé"
 
@@ -535,7 +535,7 @@ msgstr "#:response-types doit être une liste de symboles"
 msgid "#:grant-types should be a list of symbols"
 msgstr "#:grant-types doit être une liste de symboles"
 
-#: src/scm/webid-oidc/client.scm:286 src/scm/webid-oidc/resource-server.scm:177
+#: src/scm/webid-oidc/client.scm:286 src/scm/webid-oidc/resource-server.scm:143
 msgid "reason-phrase|Not Modified"
 msgstr "Non Modifié"
 
@@ -1189,7 +1189,7 @@ msgid "The port should be a number between 0 and 65535.\n"
 msgstr "Le port doit être un nombre entre 0 et 65535.\n"
 
 #: src/scm/webid-oidc/hello-world.scm:159
-#: src/scm/webid-oidc/resource-server.scm:338
+#: src/scm/webid-oidc/resource-server.scm:304
 msgid "reason-phrase|Unauthorized"
 msgstr "Non Autorisé"
 
@@ -1202,7 +1202,7 @@ msgid "<p>This page requires authentication with Solid.</p>"
 msgstr "<p>Cette page requiert une authentification avec Solid.</p>"
 
 #: src/scm/webid-oidc/hello-world.scm:179
-#: src/scm/webid-oidc/resource-server.scm:346
+#: src/scm/webid-oidc/resource-server.scm:312
 msgid "reason-phrase|Method Not Allowed"
 msgstr "Méthode Non Autorisée"
 
@@ -2517,7 +2517,7 @@ msgid "the refresh token is bound to key ~s, which is not that one"
 msgstr ""
 "le jeton de rafraîchissement est lié à la clé ~s, ce n’est pas celle utilisée"
 
-#: src/scm/webid-oidc/resource-server.scm:59
+#: src/scm/webid-oidc/resource-server.scm:71
 msgid ""
 "You need to pass #:server-uri URI where URI is the public URI of the server, "
 "as a (web uri)."
@@ -2525,58 +2525,48 @@ msgstr ""
 "Vous devez passer #:server-uri URI où URI est l’URI publique du serveur, "
 "comme dans (web uri)."
 
-#: src/scm/webid-oidc/resource-server.scm:86
-#, scheme-format
-msgid "~a: authentication failure: ~a\n"
-msgstr "~a : échec d’authentificationn : ~a\n"
-
-#: src/scm/webid-oidc/resource-server.scm:90
-#, scheme-format
-msgid "~a: authentication failure\n"
-msgstr "~a : échec d’authentification\n"
-
-#: src/scm/webid-oidc/resource-server.scm:162
-#: src/scm/webid-oidc/resource-server.scm:369
+#: src/scm/webid-oidc/resource-server.scm:128
+#: src/scm/webid-oidc/resource-server.scm:335
 msgid "reason-phrase|Precondition Failed"
 msgstr "Échec de Précondition"
 
-#: src/scm/webid-oidc/resource-server.scm:199
+#: src/scm/webid-oidc/resource-server.scm:165
 msgid "The owner is not defined."
 msgstr "Le propriétaire n’est pas défini."
 
-#: src/scm/webid-oidc/resource-server.scm:249
-#: src/scm/webid-oidc/resource-server.scm:272
+#: src/scm/webid-oidc/resource-server.scm:215
+#: src/scm/webid-oidc/resource-server.scm:238
 msgid "Bad Request"
 msgstr "Requête invalide"
 
-#: src/scm/webid-oidc/resource-server.scm:283
+#: src/scm/webid-oidc/resource-server.scm:249
 msgid "reason-phrase|Created"
 msgstr "Créé"
 
-#: src/scm/webid-oidc/resource-server.scm:306
+#: src/scm/webid-oidc/resource-server.scm:272
 #, scheme-format
 msgid "~a: ignoring a group that cannot be fetched: ~a\n"
 msgstr "~a : j’ignore un groupe qui n’a pas pu être téléchargé : ~a\n"
 
-#: src/scm/webid-oidc/resource-server.scm:310
+#: src/scm/webid-oidc/resource-server.scm:276
 #, scheme-format
 msgid "~a: ignoring a group that cannot be fetched\n"
 msgstr "~a : j’ignore un groupe qui ne peut pas être téléchargé\n"
 
-#: src/scm/webid-oidc/resource-server.scm:334
+#: src/scm/webid-oidc/resource-server.scm:300
 #: src/scm/webid-oidc/token-endpoint.scm:105
 msgid "reason-phrase|Forbidden"
 msgstr "Interdit"
 
-#: src/scm/webid-oidc/resource-server.scm:355
+#: src/scm/webid-oidc/resource-server.scm:321
 msgid "reason-phrase|Conflict"
 msgstr "Conflit"
 
-#: src/scm/webid-oidc/resource-server.scm:362
+#: src/scm/webid-oidc/resource-server.scm:328
 msgid "reason-phrase|Unsupported Media Type"
 msgstr "Type de Média Non Supporté"
 
-#: src/scm/webid-oidc/resource-server.scm:376
+#: src/scm/webid-oidc/resource-server.scm:342
 msgid "reason-phrase|Not Acceptable"
 msgstr "Inacceptable"
 
@@ -2649,6 +2639,31 @@ msgstr "Non Trouvé"
 msgid "The resource could not be found."
 msgstr "La ressource n’a pas été trouvée."
 
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:63
+msgid "#:backend should be an endpoint"
+msgstr "#:backend doit être un terminal"
+
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:73
+msgid "#:server-uri should be an URI"
+msgstr "#:server-uri doit être une URI"
+
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:111
+#, scheme-format
+msgid "~a: authentication failure: ~a\n"
+msgstr "~a : échec d’authentificationn : ~a\n"
+
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:115
+#, scheme-format
+msgid "~a: authentication failure\n"
+msgstr "~a : échec d’authentification\n"
+
+#: src/scm/webid-oidc/server/endpoint/authentication.scm:121
+msgid ""
+"<p>There is an access token and a DPoP proof, but one or both is invalid.</p>"
+msgstr ""
+"<p>Il y a un jeton d’accès et une preuve DPoP, mais l’un ou les deux sont "
+"invalides.</p>"
+
 #: src/scm/webid-oidc/server/endpoint/reverse-proxy.scm:77
 msgid "#:backend-uri should be an URI"
 msgstr "#:backend-uri doit être une URI"
diff --git a/src/scm/webid-oidc/resource-server.scm b/src/scm/webid-oidc/resource-server.scm
index 77c0a81..65d64f0 100644
--- a/src/scm/webid-oidc/resource-server.scm
+++ b/src/scm/webid-oidc/resource-server.scm
@@ -28,6 +28,8 @@
   #:use-module ((webid-oidc server resource path) #:prefix ldp:)
   #:use-module ((webid-oidc server resource content) #:prefix ldp:)
   #:use-module (webid-oidc server precondition)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc server endpoint authentication)
   #:use-module (webid-oidc http-link)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
@@ -47,6 +49,8 @@
   #:use-module (ice-9 exceptions)
   #:use-module (sxml simple)
   #:use-module (srfi srfi-19)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
   #:declarative? #t
   #:export
   (
@@ -54,69 +58,31 @@
    make-resource-server
    ))
 
+(define-class <stub-endpoint> (<endpoint>))
+
+(define return
+  (make-parameter #f))
+
+(define-method (handle (endpoint <stub-endpoint>) request request-body)
+  ((return) (assq-ref (request-meta request) 'user)))
+
 (define* (make-authenticator #:key (server-uri #f))
   (unless (and server-uri (uri? server-uri))
     (fail (G_ "You need to pass #:server-uri URI where URI is the public URI of the server, as a (web uri).")))
-  (lambda (request request-body)
-    (let ((headers (request-headers request))
-          (uri (request-uri request))
-          (method (request-method request))
-          (current-time ((p:current-date))))
-      (parameterize ((web-locale request)
-                     (p:current-date current-time)) ;; fix the date
-        (let ((authz (assoc-ref headers 'authorization))
-              (dpop (assoc-ref headers 'dpop))
-              (full-uri (build-uri (uri-scheme server-uri)
-                                   #:userinfo (uri-userinfo server-uri)
-                                   #:host (uri-host server-uri)
-                                   #:port (uri-port server-uri)
-                                   #:path (string-append
-                                           "/"
-                                           (encode-and-join-uri-path
-                                            (append
-                                             (split-and-decode-uri-path (uri-path server-uri))
-                                             (split-and-decode-uri-path
-                                              (uri-path uri))))))))
-          (and authz dpop
-               (eq? (car authz) 'dpop)
-               (with-exception-handler
-                   (lambda (error)
-                     (if (exception-with-message? error)
-                         (format (current-error-port)
-                                 (G_ "~a: authentication failure: ~a\n")
-                                 (date->string current-time)
-                                 (exception-message error))
-                         (format (current-error-port)
-                                 (G_ "~a: authentication failure\n")
-                                 (date->string current-time)))
-                     #f)
-                 (lambda ()
-                   ;; Sometimes the access is the cadr as a symbol,
-                   ;; sometimes it is the cdr as a string. It depends
-                   ;; whether the response has been written and read,
-                   ;; or preserved as a guile object.
-                   (let* ((lit-access-token
-                           (match authz
-                             ;; That’s when the request is parsed:
-                             (('dpop (? symbol? symbol-value))
-                              (symbol->string symbol-value))
-                             ;; That’s when it’s not:
-                             (('dpop . (? string? string-value))
-                              string-value)))
-                          (access-token
-                           (decode <access-token> lit-access-token))
-                          (cnf/jkt (cnf/jkt access-token))
-                          (dpop-proof
-                           (decode <dpop-proof> dpop
-                                   #:method method
-                                   #:uri full-uri
-                                   #:cnf/check cnf/jkt
-                                   #:access-token lit-access-token)))
-                     (let ((subject (webid access-token))
-                           (issuer (iss access-token)))
-                       (confirm-provider subject issuer)
-                       subject)))
-                 #:unwind? #t)))))))
+  (let* ((backend (make <stub-endpoint>))
+         (endpoint (make <authenticator>
+                     #:backend backend
+                     #:server-uri server-uri)))
+    (lambda (request request-body)
+      (parameterize ((web-locale request))
+        (with-exception-handler
+            (lambda (error)
+              #f)
+          (lambda ()
+            (let/ec ret
+              (parameterize ((return ret))
+                (handle endpoint request request-body))))
+          #:unwind? #t)))))
 
 (define (handle-errors f g)
   (call/ec
diff --git a/src/scm/webid-oidc/server/endpoint/Makefile.am b/src/scm/webid-oidc/server/endpoint/Makefile.am
index ba4799a..51dee79 100644
--- a/src/scm/webid-oidc/server/endpoint/Makefile.am
+++ b/src/scm/webid-oidc/server/endpoint/Makefile.am
@@ -15,7 +15,9 @@
 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 dist_endpointserverwebidoidcmod_DATA += \
-  %reldir%/reverse-proxy.scm
+  %reldir%/reverse-proxy.scm \
+  %reldir%/authentication.scm
 
 endpointserverwebidoidcgo_DATA += \
-  %reldir%/reverse-proxy.go
+  %reldir%/reverse-proxy.go \
+  %reldir%/authentication.go
diff --git a/src/scm/webid-oidc/server/endpoint/authentication.scm b/src/scm/webid-oidc/server/endpoint/authentication.scm
new file mode 100644
index 0000000..5a22f48
--- /dev/null
+++ b/src/scm/webid-oidc/server/endpoint/authentication.scm
@@ -0,0 +1,172 @@
+;; disfluid, implementation of the Solid specification
+;; Copyright (C) 2021  Vivien Kraus
+
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+(define-module (webid-oidc server endpoint authentication)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc access-token)
+  #:use-module (webid-oidc dpop-proof)
+  #:use-module (webid-oidc provider-confirmation)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module ((webid-oidc config) #:prefix cfg:)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (web server)
+  #:use-module (web client)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (sxml simple)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
+  #:declarative? #t
+  #:export
+  (
+   <authenticator>
+   backend
+   server-uri
+   ))
+
+(define-class <authenticator> (<endpoint>)
+  (backend #:init-keyword #:backend #:getter backend)
+  (server-uri #:init-keyword #:server-uri #:getter server-uri))
+
+(define-method (initialize (endpoint <authenticator>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((backend #f)
+    (server-uri #f))
+   (unless (is-a? backend <endpoint>)
+     (scm-error 'wrong-type-arg "make <authenticator>"
+                (G_ "#:backend should be an endpoint")
+                '()
+                (list backend)))
+   (match server-uri
+     ((? string? (= string->uri (? uri? the-server-uri)))
+      (set! server-uri the-server-uri)
+      (slot-set! endpoint 'server-uri the-server-uri))
+     (else #t))
+   (unless (and server-uri (uri? server-uri))
+     (scm-error 'wrong-type-arg "make <authenticator>"
+                (G_ "#:server-uri should be an URI")
+                '()
+                (list server-uri)))))
+
+(define-method (handle (endpoint <authenticator>) request request-body)
+  (define accumulated-error '())
+  (let ((headers (request-headers request))
+        (uri (request-uri request))
+        (method (request-method request)))
+    (let ((authz (assq-ref headers 'authorization))
+          (dpop (assq-ref headers 'dpop))
+          (full-uri
+           (let ((server-uri (server-uri endpoint)))
+             (build-uri (uri-scheme server-uri)
+                        #:userinfo (uri-userinfo server-uri)
+                        #:host (uri-host server-uri)
+                        #:port (uri-port server-uri)
+                        #:path
+                        (string-append
+                         (if (and (equal? (uri-path server-uri) "")
+                                  (equal? (uri-path uri) ""))
+                             ""
+                             ;; It must start with a / then
+                             "/")
+                         (encode-and-join-uri-path
+                          (append
+                           (split-and-decode-uri-path (uri-path server-uri))
+                           (split-and-decode-uri-path (uri-path uri))))
+                         (if (string-suffix? (uri-path uri) "/")
+                             "/"
+                             ""))))))
+      (let ((user
+             (and authz dpop
+                  (eq? (car authz) 'dpop)
+                  (with-exception-handler
+                      (lambda (error)
+                        (if (exception-with-message? error)
+                            (format (current-error-port)
+                                    (G_ "~a: authentication failure: ~a\n")
+                                    (date->string ((p:current-date)))
+                                    (exception-message error))
+                            (format (current-error-port)
+                                    (G_ "~a: authentication failure\n")
+                                    (date->string ((p:current-date)))))
+                        (set! accumulated-error
+                              (make-exception
+                               (make-user-message
+                                (call-with-input-string
+                                    (format #f (W_ "<p>There is an access token and a DPoP proof, but one or both is invalid.</p>"))
+                                  xml->sxml))
+                               error))
+                        #f)
+                    (lambda ()
+                      ;; Sometimes the access is the cadr as a symbol,
+                      ;; sometimes it is the cdr as a string. It depends
+                      ;; whether the response has been written and read,
+                      ;; or preserved as a guile object.
+                      (let* ((lit-access-token
+                              (match authz
+                                ;; That’s when the request is parsed:
+                                (('dpop (? symbol? symbol-value))
+                                 (symbol->string symbol-value))
+                                ;; That’s when it’s not:
+                                (('dpop . (? string? string-value))
+                                 string-value)))
+                             (access-token
+                              (decode <access-token> lit-access-token))
+                             (cnf/jkt (cnf/jkt access-token))
+                             (dpop-proof
+                              (decode <dpop-proof> dpop
+                                      #:method method
+                                      #:uri full-uri
+                                      #:cnf/check cnf/jkt
+                                      #:access-token lit-access-token)))
+                        (let ((subject (webid access-token))
+                              (issuer (iss access-token)))
+                          (confirm-provider subject issuer)
+                          subject)))
+                    #:unwind? #t))))
+        (with-exception-handler
+            (lambda (exn)
+              ;; Since a 401 might be returned normally or raised as
+              ;; an exception, we won’t add the header to authenticate
+              ;; with DPoP in this layer.
+              (raise-exception
+               (apply make-exception
+                      exn
+                      (make-caused-by-user user)
+                      accumulated-error)))
+          (lambda ()
+            (receive (response response-body meta)
+                (handle (backend endpoint)
+                        (build-request (request-uri request)
+                                       #:method (request-method request)
+                                       #:headers (request-headers request)
+                                       #:port (request-port request)
+                                       #:meta `((user . ,user)
+                                                ,@(request-meta request)))
+                        request-body)
+              (values response response-body `((user . ,user) ,@meta)))))))))