Switch to a more sensible error reporting system

1 files changed, 67 insertions, 75 deletions

diff --git a/src/scm/webid-oidc/program.scm b/src/scm/webid-oidc/program.scm
index 9d65b70..2b80bef 100644
--- a/src/scm/webid-oidc/program.scm
+++ b/src/scm/webid-oidc/program.scm
@@ -25,6 +25,7 @@
   #:use-module (webid-oidc jti)
   #:use-module (webid-oidc offloading)
   #:use-module (webid-oidc catalog)
+  #:use-module (webid-oidc web-i18n)
   #:use-module ((webid-oidc parameters) #:prefix p:)
   #:use-module ((webid-oidc stubs) #:prefix stubs:)
   #:use-module ((webid-oidc config) #:prefix cfg:)
@@ -45,13 +46,6 @@
   #:use-module (webid-oidc cache)
   #:use-module (web server))
 
-(define (G_ text)
-  (let ((out (gettext text)))
-    (if (string=? out text)
-        ;; No translation, disambiguate
-        (car (reverse (string-split text #\|)))
-        out)))
-
 (define logging-mutex (make-mutex))
 
 (define* (http-get-with-log uri #:key (headers '()))
@@ -59,16 +53,17 @@
   (define uri-string (if (uri? uri) (uri->string uri) uri))
   (with-mutex logging-mutex
     (when (getenv "XML_CATALOG_FILES")
-      (format (current-error-port) "~a: Warning: XML_CATALOG_FILES is set to ~s.\n"
+      (format (current-error-port) (G_ "~a: Warning: XML_CATALOG_FILES is set to ~s.\n")
               date
               (getenv "XML_CATALOG_FILES")))
-    (format (current-error-port) "~a: GET ~a ~s...\n"
+    (format (current-error-port) (G_ "~a: GET ~a ~s...\n")
             date uri-string headers))
   (set! uri (resolve-uri uri
                          #:http-get
                          (lambda* (uri . args)
                            (with-mutex logging-mutex
-                             (format (current-error-port) "~a: Warning: loading XML catalog from the web, ~s.\n"
+                             (format (current-error-port)
+                                     (G_ "~a: Warning: loading XML catalog from the web, ~s.\n")
                                      date
                                      (uri->string uri)))
                            (apply http-get uri args))))
@@ -76,7 +71,7 @@
       (in-another-thread
        (http-get uri #:headers headers))
     (with-mutex logging-mutex
-      (format (current-error-port) "~a: GET ~a ~s: ~s ~a bytes\n"
+      (format (current-error-port) (G_ "~a: GET ~a ~s: ~s ~a bytes\n")
               date uri-string headers response
               (cond
                ((bytevector? response-body)
@@ -115,84 +110,81 @@
                          (string-append (getenv "HOME") "/.cache"))
                      "/disfluid"))
                    ;; Fix the date
-                   (p:current-date ((p:current-date))))
+                   (p:current-date ((p:current-date)))
+                   (web-locale request))
       (call/ec
        (lambda (return)
          (with-exception-handler
              (lambda (error)
+               (unless (exception-with-message? error)
+                 (let ((final-message
+                        (format #f (G_ "really bad internal server error"))))
+                   (raise-exception
+                    (make-exception
+                     (make-exception-with-message final-message)
+                     error))))
                (with-mutex logging-mutex
                  (format (current-error-port)
                          (G_ "~a: ~a: Internal server error: ~a\n")
                          (date->string ((p:current-date)))
                          (request-ip-address request)
-                         (error->str error)))
+                         (exception-message error)))
                (return
                 (build-response #:code 500
-                                #:reason-phrase "Internal Server Error"
+                                #:reason-phrase (W_ "Internal Server Error")
                                 #:headers `((source . ,complete-corresponding-source)
                                             (date . ,((p:current-date)))))
-                "Sorry, there was an error."))
+                (W_ "Sorry, there was an error.")))
            (lambda ()
-             (with-exception-handler
-                 (lambda (error)
-                   (with-mutex logging-mutex
-                     (format (current-error-port)
-                             (G_ "The client locale ~s can’t be approximated by system locale ~s (because ~a), using C.\n")
-                             ((record-accessor &unknown-client-locale 'web-locale) error)
-                             ((record-accessor &unknown-client-locale 'c-locale) error)
-                             (error->str error))))
-               (lambda ()
-                 (receive (response response-body user cause)
-                     (call-with-values
-                         (lambda ()
-                           (handler request request-body))
-                       (case-lambda
-                         ((response response-body)
-                          (values response response-body #f #f))
-                         ((response response-body user)
-                          (values response response-body user #f))
-                         ((response response-body user cause)
-                          (values response response-body user cause))))
-                   (let ((logging-port
-                          (let ((response-code (response-code response)))
-                            (if (>= response-code 400)
-                                ;; That’s an error
-                                (current-error-port)
-                                (current-output-port)))))
-                     (with-mutex logging-mutex
-                       (format logging-port
-                               (G_ "~a: ~s ~a ~s ~a\n")
-                               (if user
-                                   (format #f (G_ "~a: ~a (~a)")
-                                           (date->string (time-utc->date (current-time)))
-                                           (uri->string user)
-                                           (request-ip-address request))
-                                   (format #f (G_ "~a: ~a")
-                                           (date->string (time-utc->date (current-time)))
-                                           (request-ip-address request)))
-                               (request-method request)
-                               (uri-path (request-uri request))
-                               (response-code response)
-                               (if cause
-                                   (string-append
-                                    (response-reason-phrase response)
-                                    " "
-                                    (format #f (G_ "(there was an error: ~a)")
-                                            (error->str cause)))
-                                   (response-reason-phrase response)))))
-                   (return
-                    (build-response
-                     #:version (response-version response)
-                     #:code (response-code response)
-                     #:reason-phrase (response-reason-phrase response)
-                     #:headers `((source . ,complete-corresponding-source)
-                                 (date . ,((p:current-date)))
-                                 ,@(response-headers response))
-                     #:port (response-port response)
-                     #:validate-headers? #t)
-                    response-body)))
-               #:unwind? #t
-               #:unwind-for-type &unknown-client-locale))))))))
+             (receive (response response-body user cause)
+                 (call-with-values
+                     (lambda ()
+                       (handler request request-body))
+                   (case-lambda
+                     ((response response-body)
+                      (values response response-body #f #f))
+                     ((response response-body user)
+                      (values response response-body user #f))
+                     ((response response-body user cause)
+                      (values response response-body user cause))))
+               (let ((logging-port
+                      (let ((response-code (response-code response)))
+                        (if (>= response-code 400)
+                            ;; That’s an error
+                            (current-error-port)
+                            (current-output-port)))))
+                 (with-mutex logging-mutex
+                   (format logging-port
+                           (G_ "~a: ~s ~a ~s ~a\n")
+                           (if user
+                               (format #f (G_ "~a: ~a (~a)")
+                                       (date->string (time-utc->date (current-time)))
+                                       (uri->string user)
+                                       (request-ip-address request))
+                               (format #f (G_ "~a: ~a")
+                                       (date->string (time-utc->date (current-time)))
+                                       (request-ip-address request)))
+                           (request-method request)
+                           (uri-path (request-uri request))
+                           (response-code response)
+                           (if (and cause (exception-with-message? cause))
+                               (string-append
+                                (response-reason-phrase response)
+                                " "
+                                (format #f (G_ "(there was an error: ~a)")
+                                        (exception-message cause)))
+                               (response-reason-phrase response)))))
+               (return
+                (build-response
+                 #:version (response-version response)
+                 #:code (response-code response)
+                 #:reason-phrase (response-reason-phrase response)
+                 #:headers `((source . ,complete-corresponding-source)
+                             (date . ,((p:current-date)))
+                             ,@(response-headers response))
+                 #:port (response-port response)
+                 #:validate-headers? #t)
+                response-body)))))))))
 
 (define (serve-one-client* handler implementation server state)
   ;; Same as serve-one-client, except it is served in a promise.