guix/data-service
2
0
Fork 0
mirror of git://git.savannah.gnu.org/guix/data-service.git synced 2023-12-14 03:23:03 +01:00
Code Issues Releases Wiki Activity

Kill long running load new revision jobs

Browse source 
There are some revisions of Guix which take forever to process (or days at
least). To avoid jobs being processed forever, kill them after they've been
running for a while (default 24 hours).
This commit is contained in:
Christopher Baines 2019-07-12 20:02:44 +01:00
parent 83ef624b97
commit 3dfa9212f1
1 changed files with 34 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
guix-data-service/jobs.scm
View file

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