Switch to a more sensible error reporting system

1 files changed, 74 insertions, 51 deletions

diff --git a/src/scm/webid-oidc/hello-world.scm b/src/scm/webid-oidc/hello-world.scm
index d752aae..45e0657 100644
--- a/src/scm/webid-oidc/hello-world.scm
+++ b/src/scm/webid-oidc/hello-world.scm
@@ -1,4 +1,4 @@
-;; webid-oidc, implementation of the Solid specification
+;; disfluis, implementation of the Solid specification
 ;; Copyright (C) 2020, 2021  Vivien Kraus
 
 ;; This program is free software: you can redistribute it and/or modify
@@ -17,6 +17,7 @@
 (define-module (webid-oidc hello-world)
   #:use-module (webid-oidc resource-server)
   #:use-module (webid-oidc server log)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc config) #:prefix cfg:)
   #:use-module (web request)
   #:use-module (web response)
@@ -28,14 +29,28 @@
   #:use-module (ice-9 getopt-long)
   #:use-module (ice-9 suspendable-ports)
   #:use-module (sxml simple)
-  #:use-module (srfi srfi-19))
+  #:use-module (sxml match)
+  #:use-module (srfi srfi-19)
+  #:declarative? #t)
 
-(define (G_ text)
-  (let ((out (gettext text)))
-    (if (string=? out text)
-        ;; No translation, disambiguate
-        (car (reverse (string-split text #\|)))
-        out)))
+(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
+              (W_ (format #f (W_ "<h1>Hello, ~a!</h1>")
+                          (uri->string id))
+                  (sxml->xml
+                   `(a (@ (href ,(uri->string id)))
+                       ,(uri->string id)))))
+             ((*TOP* ,title) title))
+           ,(sxml-match
+             (xml->sxml
+              (W_ (format #f (W_ "<p>The client is compatible with Solid.</p>"))))
+             ((*TOP* ,p) p))))))
 
 (define-public (main)
   (setvbuf (current-output-port) 'none)
@@ -126,48 +141,56 @@ Options:
                      (prepare-log-file log-file))
                    (when error-file
                      (prepare-error-file error-file))
-                   (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
-                                   `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
-                                           (html (@ (xmlns "http://www.w3.org/1999/xhtml")
-                                                    (xml:lang "en"))
-                                                 (body
-                                                  (h1 "Hello, "
-                                                      (a (@ (href ,(uri->string (string->uri agent))))
-                                                         ,(uri->string (string->uri agent))) "!"))))))))
-                             (values
-                              (build-response #:code 401
-                                              #: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 "en"))
-                                                 (body
-                                                  (h1 "Please authenticate!"))))))))))
-                       (values
-                        (build-response #:code 405
-                                        #: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 "en"))
-                                           (body
-                                            (h1 "Please issue a GET request."))))))))))))
+                   (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 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
+                                                       (W_ (format #f "<h1>Please authenticate</h1>")))
+                                                      ((*TOP* ,title) title))
+                                                    ,(sxml-match
+                                                      (xml->sxml
+                                                       (W_ (format #f "<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
+                                                 (W_ (format #f "<h1>Method not allowed</h1>")))
+                                                ((*TOP* ,title) title))
+                                              ,(sxml-match
+                                                (xml->sxml
+                                                 (W_ (format #f "<p>You can only use the <emph>GET</emph> method on this resource.</p>")))
+                                                ((*TOP* ,p) p))))))))))))))
             (install-suspendable-ports!)
             (run-server handler 'http (list #:port (string->number port-string))))))))))