cbaines pushed a commit to branch master
in repository data-service.
commit 37b7c568ed53aa6e49ae5bbd6a8b5a7b5ad1a1d5
Author: Christopher Baines <[email protected]>
AuthorDate: Mon Feb 10 10:53:24 2025 +0000
Make the job timeout configurable
---
guix-data-service/jobs.scm | 16 ++++++++--------
scripts/guix-data-service-process-jobs.in | 14 ++++++++++++--
2 files changed, 20 insertions(+), 10 deletions(-)
diff --git a/guix-data-service/jobs.scm b/guix-data-service/jobs.scm
index 3eb8403..b045133 100644
--- a/guix-data-service/jobs.scm
+++ b/guix-data-service/jobs.scm
@@ -147,7 +147,9 @@ WHERE load_new_guix_revision_jobs.id = $1"
ignore-systems
ignore-targets
(free-space-requirement
- (* 2 (expt 2 30)))) ; 2G
+ ;; 2G
+ (* 2 (expt 2 30)))
+ timeout)
(define (fetch-new-jobs)
(let ((free-space (free-disk-space "/gnu/store")))
(if (< free-space free-space-requirement)
@@ -204,7 +206,8 @@ WHERE load_new_guix_revision_jobs.id = $1"
handle-job-failure
#:max-processes max-processes
#:priority-max-processes
- latest-branch-revision-max-processes))
+ latest-branch-revision-max-processes
+ #:timeout timeout))
(define* (log-for-job conn job-id
@@ -312,10 +315,6 @@ WHERE job_id = $1")
4))
1))
-(define default-timeout
- (* (* 60 60) ;; 1 hour in seconds
- 72))
-
(define* (process-jobs-concurrently
fetch-new-jobs
process-job
@@ -324,7 +323,7 @@ WHERE job_id = $1")
#:key
(max-processes default-max-processes)
(priority-max-processes (* 2 max-processes))
- (timeout default-timeout))
+ timeout)
(define processes
(make-hash-table))
@@ -424,7 +423,8 @@ WHERE job_id = $1")
(atomic-box-set! exit? #t)))
(while #t
- (kill-long-running-processes)
+ (when timeout
+ (kill-long-running-processes))
(wait-on-processes)
(display-status)
diff --git a/scripts/guix-data-service-process-jobs.in
b/scripts/guix-data-service-process-jobs.in
index 64f9ad2..dc666be 100644
--- a/scripts/guix-data-service-process-jobs.in
+++ b/scripts/guix-data-service-process-jobs.in
@@ -70,14 +70,22 @@
(lambda (opt name arg result)
(alist-cons 'ignore-targets
(string-split arg #\,)
+ result)))
+ (option '("timeout") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'timeout
+ (string->number arg)
result)))))
+
(define %default-options
;; Alist of default option values
`((max-processes . ,default-max-processes)
(per-job-parallelism . 1)
(ignore-systems . ())
- (ignore-targets . ())))
+ (ignore-targets . ())
+ (timeout . ,(* (* 60 60) ;; 1 hour in seconds
+ 72))))
(define (parse-options args)
(args-fold
@@ -130,7 +138,9 @@
#:ignore-systems (assq-ref opts 'ignore-systems)
#:ignore-targets (assq-ref opts 'ignore-targets)
#:free-space-requirement
- (assq-ref opts 'free-space-requirement)))
+ (assq-ref opts 'free-space-requirement)
+ #:timeout
+ (assq-ref opts 'timeout)))
(lambda _
(backtrace))))
#:unwind? #t))))
