aboutsummaryrefslogtreecommitdiff
path: root/guix-data-service/web/server.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix-data-service/web/server.scm')
-rw-r--r--guix-data-service/web/server.scm267
1 files changed, 191 insertions, 76 deletions
diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index 6e91809..2fd26f5 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -19,22 +19,29 @@
(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)
#:use-module (web request)
#:use-module (web uri)
#:use-module (system repl error-handling)
#:use-module (ice-9 atomic)
#:use-module (fibers)
+ #:use-module (fibers channels)
#:use-module (fibers scheduler)
#:use-module (fibers conditions)
- #:use-module ((guix build syscalls)
- #:select (set-thread-name))
+ #:use-module (knots)
+ #:use-module (knots web-server)
+ #:use-module (knots thread-pool)
+ #:use-module (knots resource-pool)
#:use-module (prometheus)
#:use-module (guix-data-service utils)
#: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
@@ -94,9 +101,38 @@
(%guix-data-service-metrics-registry registry)
- (let ((finished? (make-condition)))
+ (let ((finished? (make-condition))
+ (priority-scheduler #f)
+ (request-scheduler #f))
(call-with-sigint
(lambda ()
+ (call-with-new-thread
+ (lambda ()
+ (run-fibers
+ (lambda ()
+ (let* ((current (current-scheduler))
+ (schedulers
+ (cons current (scheduler-remote-peers current))))
+
+ (set! priority-scheduler current)
+
+ (for-each
+ (lambda (i sched)
+ (spawn-fiber
+ (lambda ()
+ (catch 'system-error
+ (lambda ()
+ (set-thread-name
+ (string-append "priority " (number->string i))))
+ (const #t)))
+ sched))
+ (iota (length schedulers))
+ schedulers))
+
+ (wait finished?))
+ #:hz 0
+ #:parallelism 1)))
+
(run-fibers
(lambda ()
(let* ((current (current-scheduler))
@@ -109,88 +145,166 @@
(catch 'system-error
(lambda ()
(set-thread-name
- (string-append "fibers " (number->string i))))
+ (string-append "server " (number->string i))))
(const #t)))
sched))
(iota (length schedulers))
schedulers))
- (parameterize
- ((connection-pool
- (make-resource-pool
- (lambda ()
- (open-postgresql-connection
- "web"
- postgresql-statement-timeout))
- (floor (/ postgresql-connections 2))
- #:idle-seconds 30
- #:destructor
- (lambda (conn)
- (close-postgresql-connection conn "web"))))
-
- (reserved-connection-pool
- (make-resource-pool
- (lambda ()
- (open-postgresql-connection
- "web-reserved"
- postgresql-statement-timeout))
- (floor (/ postgresql-connections 2))
- #:idle-seconds 600
- #:destructor
- (lambda (conn)
- (close-postgresql-connection conn "web-reserved"))))
-
- (resource-pool-default-timeout 5))
-
- (let ((resource-pool-checkout-failures-metric
- (make-counter-metric registry
- "resource_pool_checkout_timeouts_total"
- #:labels '(pool_name))))
- (%resource-pool-timeout-handler
- (lambda (pool proc timeout)
- (let ((pool-name
- (cond
- ((eq? pool (connection-pool)) "normal")
- ((eq? pool (reserved-connection-pool)) "reserved")
- (else #f))))
- (when pool-name
- (metric-increment
- resource-pool-checkout-failures-metric
- #:label-values `((pool_name . ,pool-name))))))))
-
- (spawn-fiber
- (lambda ()
- (with-resource-from-pool (connection-pool) conn
- (backfill-guix-revision-package-derivation-distribution-counts
- conn))))
-
- (let ((render-metrics
- (make-render-metrics registry))
- (requests-metric
- (make-counter-metric registry "requests_total")))
-
- (with-exception-handler
- (lambda (exn)
- (simple-format
- (current-error-port)
- "\n
+ (while (not priority-scheduler)
+ (sleep 0.1))
+
+ (let ((requests-metric
+ (make-counter-metric registry "requests_total")))
+
+ (with-exception-handler
+ (lambda (exn)
+ (simple-format
+ (current-error-port)
+ "\n
error: guix-data-service could not start: ~A
Check if it's already running, or whether another process is using that
port. Also, the port used can be changed by passing the --port option.\n"
- exn)
- (primitive-exit 1))
- (lambda ()
- (run-server/patched
- (lambda (request body)
- (metric-increment requests-metric)
-
- (handler request finished? body controller
- secret-key-base
- startup-completed
- render-metrics))
- #:host host
- #:port port))
+ exn)
+ (primitive-exit 1))
+ (lambda ()
+ (parameterize
+ ((background-connection-pool
+ (make-resource-pool
+ (lambda ()
+ (open-postgresql-connection
+ "background"
+ postgresql-statement-timeout))
+ 4
+ #:name "background"
+ #:idle-seconds 5
+ #:destructor
+ (lambda (conn)
+ (close-postgresql-connection conn "background"))
+ #:scheduler priority-scheduler))
+
+ (connection-pool
+ (make-resource-pool
+ (lambda ()
+ (open-postgresql-connection
+ "web"
+ postgresql-statement-timeout))
+ (floor (/ postgresql-connections 2))
+ #:name "web"
+ #:idle-seconds 30
+ #:destructor
+ (lambda (conn)
+ (close-postgresql-connection conn "web"))
+ #:scheduler priority-scheduler))
+
+ (reserved-connection-pool
+ (make-resource-pool
+ (lambda ()
+ (open-postgresql-connection
+ "web-reserved"
+ postgresql-statement-timeout))
+ (floor (/ postgresql-connections 2))
+ #:name "web-reserved"
+ #:idle-seconds 600
+ #:destructor
+ (lambda (conn)
+ (close-postgresql-connection conn "web-reserved"))
+ #:default-checkout-timeout 6
+ #:scheduler priority-scheduler)))
+
+ (let ((resource-pool-checkout-failures-metric
+ (make-counter-metric registry
+ "resource_pool_checkout_timeouts_total"
+ #:labels '(pool_name))))
+ (resource-pool-default-timeout-handler
+ (lambda (pool proc timeout)
+ (let ((pool-name
+ (cond
+ ((eq? pool (connection-pool)) "normal")
+ ((eq? pool (reserved-connection-pool)) "reserved")
+ (else #f))))
+ (when pool-name
+ (metric-increment
+ resource-pool-checkout-failures-metric
+ #:label-values `((pool_name . ,pool-name))))))))
+
+ (spawn-fiber
+ (lambda ()
+ (while (not (check-startup-completed startup-completed))
+ (sleep 1))
+
+ (with-resource-from-pool (background-connection-pool) conn
+ (backfill-guix-revision-package-derivation-distribution-counts
+ conn)))
+ #:parallel? #t)
+
+ (let ((render-metrics (make-render-metrics registry)))
+ (run-knots-web-server
+ (lambda (request)
+ (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)))))
+
+ (let ((path-components
+ mime-types
+ (request->path-components-and-mime-type request)))
+ (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))))))
+ (lambda ()
+ (with-exception-handler
+ (lambda (exn)
+ (let* ((error-string
+ (call-with-output-string
+ (lambda (port)
+ (simple-format
+ port
+ "exception when processing: ~A ~A\n"
+ (request-method request)
+ (uri-path (request-uri request)))
+ (print-backtrace-and-exception/knots
+ exn
+ #:port port)))))
+ (display error-string
+ (current-error-port)))
+
+ (raise-exception exn))
+ (lambda ()
+ (metric-increment requests-metric)
+
+ (let ((body (read-request-body request)))
+ (handler request finished? body controller
+ secret-key-base
+ startup-completed
+ render-metrics)))))
+ #:unwind? #t))
+ #:connection-buffer-size (expt 2 16)
+ #:host host
+ #:port port)))
#:unwind? #t)))
;; Guile sometimes just seems to stop listening on the port, so try
@@ -198,5 +312,6 @@ port. Also, the port used can be changed by passing the --port option.\n"
(spawn-port-monitoring-fiber port finished?)
(wait finished?))
+ #:hz 0
#:parallelism 4))
finished?)))
generated by cgit v1.2.3 (git 2.49.0) at 2025-07-16 14:50:44 +0000