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

Move the exception handling to the knots web server

Browse source 
Rather than adding another layer. This commit also removes the extra fibers
layer when processing requests. I forget exactly why this was added, but if
the reason resurfaces then it should be addressed in knots.
This commit is contained in:
Christopher Baines 2025-01-29 16:31:50 +00:00
parent 7dd6be1c3b
commit 98c4fae76f
2 changed files with 49 additions and 96 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -720,59 +720,9 @@
#:sxml (server-starting-up-page)
#:code 503)))
(with-exception-handler
(lambda (exn)
(when (resource-pool-timeout-error? exn)
(spawn-fiber
(lambda ()
(let* ((pool (resource-pool-timeout-error-pool exn))
(stats (resource-pool-stats pool)))
(simple-format (current-error-port)
"resource pool timeout error: ~A, ~A\n"
pool
stats)))))
(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))
(if startup-completed?
(running-controller-thunk)
(startup-controller-thunk)))
(define* (base-controller request method-and-path-components
startup-completed?)

89
guix-data-service/web/server.scm
View file

@ -19,6 +19,7 @@
(define-module (guix-data-service web server)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (web http)
@ -39,6 +40,8 @@
#:use-module (guix-data-service database)
#:use-module (guix-data-service web controller)
#:use-module (guix-data-service web util)
#:use-module (guix-data-service web render)
#:use-module (guix-data-service web view html)
#:use-module (guix-data-service model guix-revision-package-derivation)
#:export (%guix-data-service-metrics-registry
@ -134,33 +137,6 @@
#:hz 0
#:parallelism 1)))
(call-with-new-thread
(lambda ()
(run-fibers
(lambda ()
(let* ((current (current-scheduler))
(schedulers
(cons current (scheduler-remote-peers current))))
(set! request-scheduler current)
(for-each
(lambda (i sched)
(spawn-fiber
(lambda ()
(catch 'system-error
(lambda ()
(set-thread-name
(string-append "rp " (number->string i))))
(const #t)))
sched))
(iota (length schedulers))
schedulers))
(wait finished?))
#:hz 0
#:parallelism 4)))
(run-fibers
(lambda ()
(let* ((current (current-scheduler))
@ -179,8 +155,6 @@
(iota (length schedulers))
schedulers))
(while (not request-scheduler)
(sleep 0.1))
(while (not priority-scheduler)
(sleep 0.1))
@ -268,29 +242,58 @@ port. Also, the port used can be changed by passing the --port option.\n"
(with-resource-from-pool (background-connection-pool) conn
(backfill-guix-revision-package-derivation-distribution-counts
conn)))
request-scheduler)
#:parallel? #t)
(let ((render-metrics (make-render-metrics registry)))
(run-knots-web-server
(lambda (request)
(metric-increment requests-metric)
(let ((body (read-request-body request))
(reply (make-channel)))
(let ((body (read-request-body request)))
(handler request finished? body controller
secret-key-base
startup-completed
render-metrics)))
#:exception-handler
(lambda (exn request)
(when (resource-pool-timeout-error? exn)
(spawn-fiber
(lambda ()
(call-with-values
(lambda ()
(handler request finished? body controller
secret-key-base
startup-completed
render-metrics))
(lambda vals
(put-message reply vals))))
request-scheduler
#:parallel? #t)
(let* ((pool (resource-pool-timeout-error-pool exn))
(stats (resource-pool-stats pool)))
(simple-format (current-error-port)
"resource pool timeout error: ~A, ~A\n"
pool
stats)))))
(apply values (get-message reply))))
(let ((path-components
mime-types
(request->path-components-and-mime-type request)))
(simple-format
(current-error-port)
"error: when processing: ~A /~A\n ~A\n"
(request-method request)
(string-join path-components "/")
exn)
(case (most-appropriate-mime-type
mime-types
'(text/html application/json))
((application/json)
(apply
values
(render-json `((error . ,(if (%show-error-details)
(simple-format #f "~A" exn)
#f)))
#:code 500)))
(else
(apply
values
(render-html #:sxml (error-page
(if (%show-error-details)
exn
#f))
#:code 500))))))
#:host host
#:port port)))
#:unwind? #t)))