diff options
Diffstat (limited to 'guix-data-service/utils.scm')
| -rw-r--r-- | guix-data-service/utils.scm | 81 |
1 files changed, 20 insertions, 61 deletions
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm index d72fa55..a9e8f39 100644 --- a/guix-data-service/utils.scm +++ b/guix-data-service/utils.scm @@ -39,6 +39,7 @@ prevent-inlining-for-tests resource-pool-default-timeout + %resource-pool-timeout-handler make-resource-pool destroy-resource-pool call-with-resource-from-pool @@ -55,8 +56,6 @@ delete-duplicates/sort! - get-gc-metrics-updater - get-port-metrics-updater get-guix-metrics-updater call-with-sigint @@ -245,13 +244,15 @@ (waiters . ,(length waiters)) (checkout-failure-count . ,checkout-failure-count)))) - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply stats) - (const #t)) - (wrap-operation (sleep-operation 0.2) - (const #f))))) + (spawn-fiber + (lambda () + (perform-operation + (choice-operation + (wrap-operation + (put-operation reply stats) + (const #t)) + (wrap-operation (sleep-operation 1) + (const #f))))))) (loop resources available @@ -343,7 +344,11 @@ (define resource-pool-timeout-error? (record-predicate &resource-pool-timeout)) -(define* (call-with-resource-from-pool pool proc #:key (timeout 'default)) +(define %resource-pool-timeout-handler + (make-parameter #f)) + +(define* (call-with-resource-from-pool pool proc #:key (timeout 'default) + (timeout-handler (%resource-pool-timeout-handler))) "Call PROC with a resource from POOL, blocking until a resource becomes available. Return the resource once PROC has returned." @@ -396,6 +401,9 @@ available. Return the resource once PROC has returned." (when (or (not resource) (eq? resource 'resource-pool-retry-checkout)) + (when timeout-handler + (timeout-handler pool proc timeout)) + (raise-exception (make-resource-pool-timeout-error))) @@ -580,55 +588,6 @@ available. Return the resource once PROC has returned." (cons current-element result))))))))) -(define (get-gc-metrics-updater registry) - (define metrics - `((gc-time-taken - . ,(make-gauge-metric registry "guile_gc_time_taken")) - (heap-size - . ,(make-gauge-metric registry "guile_heap_size")) - (heap-free-size - . ,(make-gauge-metric registry "guile_heap_free_size")) - (heap-total-allocated - . ,(make-gauge-metric registry "guile_heap_total_allocated")) - (heap-allocated-since-gc - . ,(make-gauge-metric registry "guile_allocated_since_gc")) - (protected-objects - . ,(make-gauge-metric registry "guile_gc_protected_objects")) - (gc-times - . ,(make-gauge-metric registry "guile_gc_times")))) - - (lambda () - (let ((stats (gc-stats))) - (for-each - (match-lambda - ((name . metric) - (let ((value (assq-ref stats name))) - (metric-set metric value)))) - metrics)))) - -(define (get-port-metrics-updater registry) - (let ((ports-metric - (make-gauge-metric registry "guile_ports_total")) - (fds-metric - (make-gauge-metric registry "file_descriptors_total"))) - (lambda () - (let ((count 0)) - (port-for-each - (lambda _ - (set! count (+ 1 count)))) - - (metric-set ports-metric count)) - - (metric-set - fds-metric - (length - ;; In theory 'scandir' cannot return #f, but in practice, - ;; we've seen it before. - (or (scandir "/proc/self/fd" - (lambda (file) - (not (member file '("." ".."))))) - '())))))) - (define (get-guix-metrics-updater registry) (define guix-db "/var/guix/db/db.sqlite") (define guix-db-wal (string-append guix-db "-wal")) @@ -820,6 +779,7 @@ available. Return the resource once PROC has returned." (spawn-fiber (lambda () (while #t + (sleep 20) (with-exception-handler (lambda (exn) (simple-format (current-error-port) @@ -833,8 +793,7 @@ available. Return the resource once PROC has returned." (connect sock AF_INET INADDR_LOOPBACK port) (close-port sock))) #:timeout 20)) - #:unwind? #t) - (sleep 20))))) + #:unwind? #t))))) ;; Copied from (fibers web server) (define (call-with-sigint thunk cvar) |