cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Tweak handling web server errors

Browse source
This commit is contained in:
Christopher Baines 2024-08-14 20:40:34 +01:00
parent b2dcccb264
commit 0c08ce069d
2 changed files with 44 additions and 24 deletions
Download patch file Download diff file Expand all files Collapse all files

41
guix-data-service/web/controller.scm
View file

@ -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
(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" args)
(simple-format #f "~A" exn)
#f)))
#:code 500))
(else
(render-html #:sxml (error-page
(if (%show-error-details)
args
exn
#f))
#:code 500))))))
#: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?)

5
guix-data-service/web/view/html.scm
View file

@ -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)