diff options
Diffstat (limited to 'guix-data-service/jobs.scm')
-rw-r--r-- | guix-data-service/jobs.scm | 45 |
1 files changed, 34 insertions, 11 deletions
diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm index 2d515ca..a63821f 100644 --- a/guix-data-service/jobs.scm +++ b/guix-data-service/jobs.scm @@ -21,10 +21,15 @@ 4)) 1)) +(define default-timeout + (* (* 60 60) ;; 1 hour in seconds + 24)) + (define* (process-jobs-concurrently fetch-new-jobs process-job #:key (max-processes - default-max-processes)) + default-max-processes) + (timeout default-timeout)) (define processes (make-hash-table)) @@ -44,9 +49,10 @@ "\n" (string-concatenate (hash-map->list - (lambda (pid job-args) - (format #f " pid: ~5d job args: ~a\n" - pid job-args)) + (match-lambda* + ((pid (start-time job-args)) + (format #f " pid: ~5d job args: ~a\n" + pid job-args))) processes)) "\n"))) @@ -59,17 +65,32 @@ ;; No process to wait for #f) ((pid . status) - (let ((job-args (hashv-ref processes pid))) - (hashv-remove! processes pid) - (simple-format - (current-error-port) - "pid ~A failed with status ~A\n" - pid status)) + (hashv-remove! processes pid) + (simple-format (current-error-port) + "pid ~A failed with status ~A\n" + pid status) + + ;; Recurse, to check for other finished processes. (wait-on-processes)))) (lambda (key . args) (simple-format #t "key ~A args ~A\n" key args)))) + (define (kill-long-running-processes) + (hash-map->list + (match-lambda* + ((pid (start-time job-args)) + (let ((running-for + (- (current-time) start-time))) + (when (> running-for timeout) + (display + (simple-format + #f "sending SIGTERM to pid ~A started at ~A, now running for ~A\n" + pid start-time running-for) + (current-error-port)) + (kill pid SIGTERM))))) + processes)) + (define (fork-and-process-job job-args) (match (primitive-fork) (0 @@ -80,10 +101,12 @@ (lambda () (primitive-exit 127)))) (pid - (hashv-set! processes pid job-args) + (hashv-set! processes pid + (list (current-time) job-args)) #t))) (while #t + (kill-long-running-processes) (wait-on-processes) (display-status) (match (fetch-new-jobs) |