cbaines pushed a commit to branch master
in repository data-service.
commit 0c08ce069dd08e2a73aadc4c9ee3a7900d6ef34a
Author: Christopher Baines <[email protected]>
AuthorDate: Wed Aug 14 20:40:34 2024 +0100
Tweak handling web server errors
---
guix-data-service/web/controller.scm | 63 ++++++++++++++++++++++++------------
guix-data-service/web/view/html.scm | 5 +--
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)
