server: add a hello world backend

3 files changed, 135 insertions, 73 deletions

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