Tweak handling web server errors

2 files changed, 44 insertions, 24 deletions

diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index a589941..8f23af7 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -712,26 +712,49 @@
       #:sxml (server-starting-up-page)
       #:code 503)))
 
-  (call-with-error-handling
-   (if startup-completed?
-       running-controller-thunk
-       startup-controller-thunk)
-   #:on-error 'backtrace
-   #:post-error (lambda args
-                  (case (most-appropriate-mime-type
-                         mime-types
-                         '(text/html application/json))
-                    ((application/json)
-                     (render-json `((error . ,(if (%show-error-details)
-                                                  (simple-format #f "~A" args)
-                                                  #f)))
-                                  #:code 500))
-                    (else
-                     (render-html #:sxml (error-page
-                                          (if (%show-error-details)
-                                              args
-                                              #f))
-                                  #:code 500))))))
+  (with-exception-handler
+      (lambda (exn)
+        (case (most-appropriate-mime-type
+               mime-types
+               '(text/html application/json))
+          ((application/json)
+           (render-json `((error . ,(if (%show-error-details)
+                                        (simple-format #f "~A" exn)
+                                        #f)))
+                        #:code 500))
+          (else
+           (render-html #:sxml (error-page
+                                (if (%show-error-details)
+                                    exn
+                                    #f))
+                        #:code 500))))
+    (lambda ()
+      (with-throw-handler #t
+        (if startup-completed?
+            running-controller-thunk
+            startup-controller-thunk)
+        (lambda (key . args)
+          (match method-and-path-components
+            ((method path-components ...)
+             (simple-format
+              (current-error-port)
+              "error: when processing: /~A ~A\n  ~A ~A\n"
+              method (string-join path-components "/")
+              key args)))
+
+          (let* ((stack (make-stack #t 4))
+                 (backtrace
+                  (call-with-output-string
+                    (lambda (port)
+                      (display "\nBacktrace:\n" port)
+                      (display-backtrace stack port)
+                      (newline port)
+                      (newline port)))))
+            (display
+             backtrace
+             (current-error-port))))))
+    #:unwind? #t))
+
 
 (define* (base-controller request method-and-path-components
                           startup-completed?)
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index 98766de..61b75f1 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -969,10 +969,7 @@
           (h1 "An error occurred")
           (p "Sorry about that!")
           ,@(if error
-                (match error
-                  ((key . args)
-                   `((b ,key)
-                     (pre ,args))))
+                `((pre ,error))
                 '())))))
 
 (define* (server-starting-up-page)