cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Don't start new jobs when there's low disk space

Browse source
This commit is contained in:
Christopher Baines 2024-03-11 19:34:20 +00:00
parent 7d1cc4d325
commit a667db2f5d
1 changed files with 10 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -22,6 +22,7 @@
#:use-module (ice-9 atomic) #:use-module (ice-9 atomic)
#:use-module (ice-9 textual-ports) #:use-module (ice-9 textual-ports)
#:use-module (squee) #:use-module (squee)
#:use-module (guix build syscalls)
#:use-module (guix-data-service utils) #:use-module (guix-data-service utils)
#:use-module (guix-data-service database) #:use-module (guix-data-service database)
#:use-module (guix-data-service jobs load-new-guix-revision) #:use-module (guix-data-service jobs load-new-guix-revision)
@ -128,7 +129,15 @@ guix-data-service: error: missing log line: ~A
skip-system-tests? skip-system-tests?
per-job-parallelism) per-job-parallelism)
(define (fetch-new-jobs) (define (fetch-new-jobs)
(fetch-unlocked-jobs conn)) (let ((free-space (free-disk-space "/gnu/store")))
(if (< free-space (* 2 (expt 2 30))) ; 2G
(begin
(simple-format
(current-error-port)
"not starting new jobs, low free disk space on /gnu/store (~A)\n"
free-space)
'())
(fetch-unlocked-jobs conn))))
(define (process-job job-id) (define (process-job job-id)
(let ((log-port (start-thread-for-process-output job-id))) (let ((log-port (start-thread-for-process-output job-id)))