server: add a hello world backend

9 files changed, 305 insertions, 164 deletions

diff --git a/doc/disfluid.texi b/doc/disfluid.texi
index de04b9b..8f22927 100644
--- a/doc/disfluid.texi
+++ b/doc/disfluid.texi
@@ -1547,6 +1547,7 @@ the user.
 * Error signalling::
 * Router endpoint::
 * Request authentication::
+* Hello world::
 * Reverse proxy::
 @end menu
 
@@ -1662,6 +1663,16 @@ Return the backend endpoint of @var{authenticator}.
 Return the public server URI of @var{authenticator}.
 @end deffn
 
+@node Hello world
+@section Hello world
+The @emph{(webid-oidc server endpoint hello)} module defines an
+endpoint that will greet the user, to check that Solid authentication
+worked. It is intended to be a backend for an authenticator.
+
+@deftp {Class} <greeter> (<endpoint>)
+An endpoint that will greet anonymous users and authenticated users.
+@end deftp
+
 @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 8154eb0..f11d0d2 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -80,6 +80,7 @@ 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/hello.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 0163544..fd646d9 100644
--- a/po/disfluid.pot
+++ b/po/disfluid.pot
@@ -278,10 +278,9 @@ msgstr ""
 
 #: src/scm/webid-oidc/authorization-page-unsafe.scm:52
 #: src/scm/webid-oidc/client.scm:312 src/scm/webid-oidc/client.scm:329
-#: src/scm/webid-oidc/client.scm:346 src/scm/webid-oidc/hello-world.scm:40
-#: src/scm/webid-oidc/hello-world.scm:167
-#: src/scm/webid-oidc/hello-world.scm:187
+#: src/scm/webid-oidc/client.scm:346 src/scm/webid-oidc/hello-world.scm:147
 #: src/scm/webid-oidc/identity-provider.scm:136
+#: src/scm/webid-oidc/server/endpoint/hello.scm:63
 #: src/scm/webid-oidc/server/endpoint/reverse-proxy.scm:125
 #: src/scm/webid-oidc/token-endpoint.scm:113
 #: src/scm/webid-oidc/token-endpoint.scm:139
@@ -995,40 +994,31 @@ msgstr ""
 msgid "cannot negociate a recognized RFD content type, got ~s"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:44
-#, scheme-format
-msgid "<h1>Hello, ~a!</h1>"
-msgstr ""
-
-#: src/scm/webid-oidc/hello-world.scm:54
-msgid "<p>The client is compatible with Solid.</p>"
-msgstr ""
-
-#: src/scm/webid-oidc/hello-world.scm:64 src/scm/webid-oidc/program.scm:240
+#: src/scm/webid-oidc/hello-world.scm:49 src/scm/webid-oidc/program.scm:240
 msgid "command-line|version"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:66 src/scm/webid-oidc/program.scm:244
+#: src/scm/webid-oidc/hello-world.scm:51 src/scm/webid-oidc/program.scm:244
 msgid "command-line|complete-corresponding-source"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:68 src/scm/webid-oidc/program.scm:246
+#: src/scm/webid-oidc/hello-world.scm:53 src/scm/webid-oidc/program.scm:246
 msgid "command-line|help"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:70
+#: src/scm/webid-oidc/hello-world.scm:55
 msgid "command-line|port"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:72 src/scm/webid-oidc/program.scm:278
+#: src/scm/webid-oidc/hello-world.scm:57 src/scm/webid-oidc/program.scm:278
 msgid "command-line|log-file"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:74 src/scm/webid-oidc/program.scm:280
+#: src/scm/webid-oidc/hello-world.scm:59 src/scm/webid-oidc/program.scm:280
 msgid "command-line|error-file"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:86
+#: src/scm/webid-oidc/hello-world.scm:71
 #, scheme-format
 msgid ""
 "~a [OPTIONS]...\n"
@@ -1057,44 +1047,26 @@ msgid ""
 "    redirect the program errors to FILE.err.\n"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:119
+#: src/scm/webid-oidc/hello-world.scm:104
 #, scheme-format
 msgid "~a version ~a\n"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:128 src/scm/webid-oidc/program.scm:642
+#: src/scm/webid-oidc/hello-world.scm:113 src/scm/webid-oidc/program.scm:642
 msgid ""
 "You are legally required to link to the complete corresponding source code.\n"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:138
+#: src/scm/webid-oidc/hello-world.scm:123
 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:304
-msgid "reason-phrase|Unauthorized"
-msgstr ""
-
-#: src/scm/webid-oidc/hello-world.scm:171
+#: src/scm/webid-oidc/hello-world.scm:150
 msgid "<h1>Please authenticate</h1>"
 msgstr ""
 
-#: src/scm/webid-oidc/hello-world.scm:175
-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:312
-msgid "reason-phrase|Method Not Allowed"
-msgstr ""
-
-#: src/scm/webid-oidc/hello-world.scm:191
-msgid "<h1>Method not allowed</h1>"
-msgstr ""
-
-#: src/scm/webid-oidc/hello-world.scm:195
-msgid "<p>You can only use the <emph>GET</emph> method on this resource.</p>"
+#: src/scm/webid-oidc/hello-world.scm:155
+msgid "<p>No more information.</p>"
 msgstr ""
 
 #: src/scm/webid-oidc/http-link.scm:148
@@ -2163,6 +2135,15 @@ msgstr ""
 msgid "reason-phrase|Forbidden"
 msgstr ""
 
+#: src/scm/webid-oidc/resource-server.scm:304
+#: src/scm/webid-oidc/server/endpoint/hello.scm:54
+msgid "reason-phrase|Unauthorized"
+msgstr ""
+
+#: src/scm/webid-oidc/resource-server.scm:312
+msgid "reason-phrase|Method Not Allowed"
+msgstr ""
+
 #: src/scm/webid-oidc/resource-server.scm:321
 msgid "reason-phrase|Conflict"
 msgstr ""
@@ -2265,6 +2246,19 @@ 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/hello.scm:57
+msgid "<p>You are not authentified.</p>"
+msgstr ""
+
+#: src/scm/webid-oidc/server/endpoint/hello.scm:66
+#, scheme-format
+msgid "<h1>Hello, ~a!</h1>"
+msgstr ""
+
+#: src/scm/webid-oidc/server/endpoint/hello.scm:74
+msgid "<p>You are authenticated with Solid.</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 cef462b..dfbc8f5 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:33+0200\n"
+"PO-Revision-Date: 2021-10-19 11:34+0200\n"
 "Last-Translator: Vivien Kraus <vivien@planete-kraus.eu>\n"
 "Language-Team: French <vivien@planete-kraus.eu>\n"
 "Language: fr\n"
@@ -309,10 +309,9 @@ msgstr ""
 
 #: src/scm/webid-oidc/authorization-page-unsafe.scm:52
 #: src/scm/webid-oidc/client.scm:312 src/scm/webid-oidc/client.scm:329
-#: src/scm/webid-oidc/client.scm:346 src/scm/webid-oidc/hello-world.scm:40
-#: src/scm/webid-oidc/hello-world.scm:167
-#: src/scm/webid-oidc/hello-world.scm:187
+#: src/scm/webid-oidc/client.scm:346 src/scm/webid-oidc/hello-world.scm:147
 #: src/scm/webid-oidc/identity-provider.scm:136
+#: src/scm/webid-oidc/server/endpoint/hello.scm:63
 #: src/scm/webid-oidc/server/endpoint/reverse-proxy.scm:125
 #: src/scm/webid-oidc/token-endpoint.scm:113
 #: src/scm/webid-oidc/token-endpoint.scm:139
@@ -1085,40 +1084,31 @@ msgstr "la requête a échoué de façon inattendue avec ~s ~s"
 msgid "cannot negociate a recognized RFD content type, got ~s"
 msgstr "impossible de négocier un type de contenu RDF reconnu, ayant obtenu ~s"
 
-#: src/scm/webid-oidc/hello-world.scm:44
-#, scheme-format
-msgid "<h1>Hello, ~a!</h1>"
-msgstr "<h1>Bonjour, ~a !</h1>"
-
-#: src/scm/webid-oidc/hello-world.scm:54
-msgid "<p>The client is compatible with Solid.</p>"
-msgstr "<p>Le client est compatible avec Solid.</p>"
-
-#: src/scm/webid-oidc/hello-world.scm:64 src/scm/webid-oidc/program.scm:240
+#: src/scm/webid-oidc/hello-world.scm:49 src/scm/webid-oidc/program.scm:240
 msgid "command-line|version"
 msgstr "version"
 
-#: src/scm/webid-oidc/hello-world.scm:66 src/scm/webid-oidc/program.scm:244
+#: src/scm/webid-oidc/hello-world.scm:51 src/scm/webid-oidc/program.scm:244
 msgid "command-line|complete-corresponding-source"
 msgstr "code-source-correspondant-complet"
 
-#: src/scm/webid-oidc/hello-world.scm:68 src/scm/webid-oidc/program.scm:246
+#: src/scm/webid-oidc/hello-world.scm:53 src/scm/webid-oidc/program.scm:246
 msgid "command-line|help"
 msgstr "aide"
 
-#: src/scm/webid-oidc/hello-world.scm:70
+#: src/scm/webid-oidc/hello-world.scm:55
 msgid "command-line|port"
 msgstr "port"
 
-#: src/scm/webid-oidc/hello-world.scm:72 src/scm/webid-oidc/program.scm:278
+#: src/scm/webid-oidc/hello-world.scm:57 src/scm/webid-oidc/program.scm:278
 msgid "command-line|log-file"
 msgstr "fichier-journal"
 
-#: src/scm/webid-oidc/hello-world.scm:74 src/scm/webid-oidc/program.scm:280
+#: src/scm/webid-oidc/hello-world.scm:59 src/scm/webid-oidc/program.scm:280
 msgid "command-line|error-file"
 msgstr "fichier-erreur"
 
-#: src/scm/webid-oidc/hello-world.scm:86
+#: src/scm/webid-oidc/hello-world.scm:71
 #, scheme-format
 msgid ""
 "~a [OPTIONS]...\n"
@@ -1172,49 +1162,29 @@ msgstr ""
 "  -e FICHIER.err, --~a=FICHIER.err :\n"
 "      redirige la sortie d’erreur du programme vers ce fichier.\n"
 
-#: src/scm/webid-oidc/hello-world.scm:119
+#: src/scm/webid-oidc/hello-world.scm:104
 #, scheme-format
 msgid "~a version ~a\n"
 msgstr "~a version ~a\n"
 
-#: src/scm/webid-oidc/hello-world.scm:128 src/scm/webid-oidc/program.scm:642
+#: src/scm/webid-oidc/hello-world.scm:113 src/scm/webid-oidc/program.scm:642
 msgid ""
 "You are legally required to link to the complete corresponding source code.\n"
 msgstr ""
 "Vous êtes légalement tenu de fournir un lien vers le code source "
 "correspondant.\n"
 
-#: src/scm/webid-oidc/hello-world.scm:138
+#: src/scm/webid-oidc/hello-world.scm:123
 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:304
-msgid "reason-phrase|Unauthorized"
-msgstr "Non Autorisé"
-
-#: src/scm/webid-oidc/hello-world.scm:171
+#: src/scm/webid-oidc/hello-world.scm:150
 msgid "<h1>Please authenticate</h1>"
 msgstr "<h1>Veuillez vous authentifier</h1>"
 
-#: src/scm/webid-oidc/hello-world.scm:175
-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:312
-msgid "reason-phrase|Method Not Allowed"
-msgstr "Méthode Non Autorisée"
-
-#: src/scm/webid-oidc/hello-world.scm:191
-msgid "<h1>Method not allowed</h1>"
-msgstr "<h1>Méthode non autorisée</h1>"
-
-#: src/scm/webid-oidc/hello-world.scm:195
-msgid "<p>You can only use the <emph>GET</emph> method on this resource.</p>"
-msgstr ""
-"<p>Vous pouvez uniquement utiliser la méthode <emph>GET</emph> pour cette "
-"ressource.</p>"
+#: src/scm/webid-oidc/hello-world.scm:155
+msgid "<p>No more information.</p>"
+msgstr "<p>Pas plus d’information.</p>"
 
 #: src/scm/webid-oidc/http-link.scm:148
 msgid "the #:anchor parameter should be a string or an URI reference"
@@ -2558,6 +2528,15 @@ msgstr "~a : j’ignore un groupe qui ne peut pas être téléchargé\n"
 msgid "reason-phrase|Forbidden"
 msgstr "Interdit"
 
+#: src/scm/webid-oidc/resource-server.scm:304
+#: src/scm/webid-oidc/server/endpoint/hello.scm:54
+msgid "reason-phrase|Unauthorized"
+msgstr "Non Autorisé"
+
+#: src/scm/webid-oidc/resource-server.scm:312
+msgid "reason-phrase|Method Not Allowed"
+msgstr "Méthode Non Autorisée"
+
 #: src/scm/webid-oidc/resource-server.scm:321
 msgid "reason-phrase|Conflict"
 msgstr "Conflit"
@@ -2664,6 +2643,19 @@ 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/hello.scm:57
+msgid "<p>You are not authentified.</p>"
+msgstr "<p>Vous n’êtes pas authentifié.</p>"
+
+#: src/scm/webid-oidc/server/endpoint/hello.scm:66
+#, scheme-format
+msgid "<h1>Hello, ~a!</h1>"
+msgstr "<h1>Bonjour, ~a !</h1>"
+
+#: src/scm/webid-oidc/server/endpoint/hello.scm:74
+msgid "<p>You are authenticated with Solid.</p>"
+msgstr "<p>Vous êtes authentifié par Solid.</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"
@@ -2932,6 +2924,18 @@ msgstr "Contenu :"
 msgid "Discard edits"
 msgstr "Rejeter les modifications"
 
+#~ msgid "<p>The client is compatible with Solid.</p>"
+#~ msgstr "<p>Le client est compatible avec Solid.</p>"
+
+#~ msgid "<h1>Method not allowed</h1>"
+#~ msgstr "<h1>Méthode non autorisée</h1>"
+
+#~ msgid ""
+#~ "<p>You can only use the <emph>GET</emph> method on this resource.</p>"
+#~ msgstr ""
+#~ "<p>Vous pouvez uniquement utiliser la méthode <emph>GET</emph> pour cette "
+#~ "ressource.</p>"
+
 #~ msgid "Disfluid"
 #~ msgstr "Disfluid"
 
diff --git a/src/scm/webid-oidc/hello-world.scm b/src/scm/webid-oidc/hello-world.scm
index 98b4703..4d97657 100644
--- a/src/scm/webid-oidc/hello-world.scm
+++ b/src/scm/webid-oidc/hello-world.scm
@@ -15,6 +15,8 @@
 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 (define-module (webid-oidc hello-world)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc server endpoint hello)
   #:use-module (webid-oidc resource-server)
   #:use-module (webid-oidc server log)
   #:use-module (webid-oidc web-i18n)
@@ -28,32 +30,15 @@
   #:use-module (ice-9 i18n)
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 suspendable-ports)
+  #:use-module (ice-9 match)
   #:use-module (sxml simple)
   #:use-module (sxml match)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
   #:declarative? #t)
 
-(define (hello-page id)
-  `(*TOP*
-    (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-    (html (@ (xmlns "http://www.w3.org/1999/xhtml")
-             (xml:lang ,(W_ "xml-lang|en")))
-          (body
-           ,(sxml-match
-             (xml->sxml
-              (format #f (W_ "<h1>Hello, ~a!</h1>")
-                      (uri->string id)
-                      (with-output-to-string
-                        (lambda ()
-                          (sxml->xml
-                           `(a (@ (href ,(uri->string id)))
-                               ,(uri->string id)))))))
-             ((*TOP* ,title) title))
-           ,(sxml-match
-             (xml->sxml
-              (format #f (W_ "<p>The client is compatible with Solid.</p>")))
-             ((*TOP* ,p) p))))))
-
 (define-public (main)
   (setvbuf (current-output-port) 'none)
   (setvbuf (current-error-port) 'none)
@@ -137,6 +122,7 @@ Options:
             (format (current-error-port)
                     (G_ "The port should be a number between 0 and 65535.\n"))
             (exit 1))
+          (define greeter (make <greeter>))
           (let ((handler
                  (lambda (request request-body)
                    (when log-file
@@ -144,55 +130,49 @@ Options:
                    (when error-file
                      (prepare-error-file error-file))
                    (parameterize ((web-locale request))
-                     (if (eq? (request-method request) 'GET)
-                         (let ((agent (assoc-ref (request-headers request) 'xxx-agent)))
-                           (if (and agent (string->uri agent))
-                               (values
-                                (build-response
-                                 #:headers `((content-type application/xhtml+xml)
-                                             (source . ,means-string)))
-                                (with-output-to-string
-                                  (lambda ()
-                                    (sxml->xml (hello-page (string->uri agent))))))
-                               (values
-                                (build-response #:code 401
-                                                #:reason-phrase (W_ "reason-phrase|Unauthorized")
-                                                #:headers `((content-type application/xhtml+xml)
-                                                            (source . ,means-string)))
-                                (with-output-to-string
-                                  (lambda ()
-                                    (sxml->xml
-                                     `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-                                             (html (@ (xmlns "http://www.w3.org/1999/xhtml")
-                                                      (xml:lang ,(W_ "xml-lang|en")))
-                                                   (body
-                                                    ,(sxml-match
-                                                      (xml->sxml
-                                                       (format #f (W_ "<h1>Please authenticate</h1>")))
-                                                      ((*TOP* ,title) title))
-                                                    ,(sxml-match
-                                                      (xml->sxml
-                                                       (format #f (W_ "<p>This page requires authentication with Solid.</p>")))
-                                                      ((*TOP* ,p) p)))))))))))
-                         (values
-                          (build-response #:code 405
-                                          #:reason-phrase (W_ "reason-phrase|Method Not Allowed")
-                                          #:headers `((content-type application/xhtml+xml)
-                                                      (source . ,means-string)))
-                          (with-output-to-string
-                            (lambda ()
-                              (sxml->xml
-                               `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-                                       (html (@ (xmlns "http://www.w3.org/1999/xhtml")
-                                                (xml:lang ,(W_ "xml-lang|en")))
-                                             (body
-                                              ,(sxml-match
-                                                (xml->sxml
-                                                 (format #f (W_ "<h1>Method not allowed</h1>")))
-                                                ((*TOP* ,title) title))
-                                              ,(sxml-match
-                                                (xml->sxml
-                                                 (format #f (W_ "<p>You can only use the <emph>GET</emph> method on this resource.</p>")))
-                                                ((*TOP* ,p) p))))))))))))))
+                     (with-exception-handler
+                         (lambda (exn)
+                           (unless (web-exception? exn)
+                             (raise-exception exn))
+                           (values
+                            (build-response
+                             #:code (web-exception-code exn)
+                             #:reason-phrase (web-exception-reason-phrase exn)
+                             #:headers `((content-type application/xhtml+xml)))
+                            (call-with-output-string
+                              (cute sxml->xml
+                                    `(*TOP*
+                                      (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                                      (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                                               (xml:lang ,(W_ "xml-lang|en")))
+                                            (body
+                                             ,(call-with-input-string
+                                                  (format #f (W_ "<h1>Please authenticate</h1>"))
+                                                xml->sxml)
+                                             ,(if (user-message? exn)
+                                                  (user-message-sxml exn)
+                                                  (call-with-input-string
+                                                      (format #f (W_ "<p>No more information.</p>"))
+                                                    xml->sxml)))))
+                                    <>))))
+                       (lambda ()
+                         (set! request
+                               (let ((user
+                                      (match (assq-ref (request-headers request) 'xxx-agent)
+                                        ((? string? (= string->uri (? uri? uri)))
+                                         uri)
+                                        (else #f))))
+                                 (build-request (request-uri request)
+                                                #:meta (if user `((user . ,user)) '())
+                                                #:headers (request-headers request)
+                                                #:version (request-version request)
+                                                #:method (request-method request))))
+                         (receive (response response-body response-meta)
+                             (handle greeter request request-body)
+                           (when (port? response-body)
+                             (set! response-body
+                                   (read-response-body response)))
+                           (values response response-body)))
+                       #:unwind? #t)))))
             (install-suspendable-ports!)
             (run-server handler 'http (list #:port (string->number port-string))))))))))
diff --git a/src/scm/webid-oidc/server/endpoint/Makefile.am b/src/scm/webid-oidc/server/endpoint/Makefile.am
index 51dee79..1e4ee16 100644
--- a/src/scm/webid-oidc/server/endpoint/Makefile.am
+++ b/src/scm/webid-oidc/server/endpoint/Makefile.am
@@ -16,8 +16,10 @@
 
 dist_endpointserverwebidoidcmod_DATA += \
   %reldir%/reverse-proxy.scm \
-  %reldir%/authentication.scm
+  %reldir%/authentication.scm \
+  %reldir%/hello.scm
 
 endpointserverwebidoidcgo_DATA += \
   %reldir%/reverse-proxy.go \
-  %reldir%/authentication.go
+  %reldir%/authentication.go \
+  %reldir%/hello.go
diff --git a/src/scm/webid-oidc/server/endpoint/hello.scm b/src/scm/webid-oidc/server/endpoint/hello.scm
new file mode 100644
index 0000000..b03c8f4
--- /dev/null
+++ b/src/scm/webid-oidc/server/endpoint/hello.scm
@@ -0,0 +1,80 @@
+;; 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 hello)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc provider-confirmation)
+  #: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
+  (
+   <greeter>
+   ))
+
+(define-class <greeter> (<endpoint>))
+
+(define-method (handle (endpoint <greeter>) request request-body)
+  (let ((user (assq-ref (request-meta request) 'user)))
+    (unless user
+      (raise-exception
+       (make-exception
+        (make-web-exception 401 (W_ "reason-phrase|Unauthorized"))
+        (make-user-message
+         (call-with-input-string
+             (format #f (W_ "<p>You are not authentified.</p>"))
+           xml->sxml)))))
+    (let ((page
+           `(*TOP*
+             (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+             (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                      (xml:lang ,(W_ "xml-lang|en")))
+                   (body
+                    ,(xml->sxml
+                      (format #f (W_ "<h1>Hello, ~a!</h1>")
+                              (call-with-output-string
+                                (lambda (port)
+                                  (sxml->xml
+                                   `(a (@ (href ,(uri->string user)))
+                                       ,(uri->string user))
+                                   port)))))
+                    ,(xml->sxml
+                      (format #f (W_ "<p>You are authenticated with Solid.</p>"))))))))
+      (values
+       (build-response
+        #:headers `((content-type application/xhtml+xml)))
+       (call-with-output-string
+         (cute sxml->xml page <>))
+       '()))))
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 8cc262b..a35c853 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -69,7 +69,8 @@ TESTS = %reldir%/load-library.scm \
   %reldir%/xml-accounts.scm \
   %reldir%/reverse-proxy.scm \
   %reldir%/reverse-proxy-502.scm \
-  %reldir%/reverse-proxy-anonymous.scm
+  %reldir%/reverse-proxy-anonymous.scm \
+  %reldir%/hello.scm
 
 EXTRA_DIST += $(TESTS) %reldir%/ChangeLog
 
diff --git a/tests/hello.scm b/tests/hello.scm
new file mode 100644
index 0000000..0c65b30
--- /dev/null
+++ b/tests/hello.scm
@@ -0,0 +1,68 @@
+;; 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 (tests hello)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc server endpoint hello)
+  #:use-module (webid-oidc testing)
+  #:use-module (webid-oidc offloading)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module (oop goops)
+  #:use-module (web server)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:declarative? #t
+  #:duplicates (merge-generics))
+
+(define (drop-sxml-top element)
+  (match element
+    (('*TOP* thing)
+     thing)
+    ((root subtrees ...)
+     `(,root ,@(map drop-sxml-top subtrees)))
+    (x x)))
+
+(with-test-environment
+ "hello"
+ (lambda ()
+   (define greeter (make <greeter>))
+   (with-exception-handler
+       (lambda (exn)
+         (unless (and (web-exception? exn)
+                      (equal? (drop-sxml-top (user-message-sxml exn))
+                              `(div (p "You are not authentified.")))
+                      (eqv? (web-exception-code exn) 401)
+                      (equal? (web-exception-reason-phrase exn) "Unauthorized"))
+           (exit 1)
+           #t))
+     (lambda ()
+       (handle greeter
+               (build-request (string->uri "https://example.com"))
+               #f)
+       (exit 2))
+     #:unwind? #t)
+   (receive (response response-body response-meta)
+       (handle greeter
+               (build-request (string->uri "https://example.com")
+                              #:meta `((user . ,(string->uri "https://example.com/profile/card#me"))))
+               #f)
+     (unless (eqv? (response-code response) 200)
+       (exit 3)))))