TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

offload: Skip machines that are low on disk space. 

Fixes <https://bugs.gnu.org/33378>.

* guix/scripts/offload.scm (node-free-disk-space): New procedure.
(%minimum-disk-space): New variable.
(choose-build-machine): Call 'node-free-disk-space' and take it into
account in addition to LOAD.
(check-machine-status): Display the free disk space.
This commit is contained in:
Ludovic Courtès 2018-12-21 23:12:52 +01:00
parent bbe66a530a
commit 63b0c3eacc
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 28 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
guix/scripts/offload.scm
View File

@ -321,6 +321,13 @@ hook."
(set-port-revealed! port 1)
port))
(define (node-free-disk-space node)
"Return the free disk space, in bytes, in NODE's store."
(node-eval node
`(begin
(use-modules (guix build syscalls))
(free-disk-space ,(%store-prefix)))))
(define* (transfer-and-offload drv machine
#:key
(inputs '())
@ -392,6 +399,12 @@ MACHINE."
(build-requirements-features requirements)
(build-machine-features machine))))
(define %minimum-disk-space
;; Minimum disk space required on the build machine for a build to be
;; offloaded. This keeps us from offloading to machines that are bound to
;; run out of disk space.
(* 100 (expt 2 20))) ;100 MiB
(define (node-load node)
"Return the load on NODE. Return +∞ if NODE is misbehaving."
(let ((line (node-eval node
@ -486,9 +499,10 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
;; too costly to call it once for every machine.
(let* ((session (false-if-exception (open-ssh-session best)))
(node (and session (make-node session)))
(load (and node (normalized-load best (node-load node)))))
(load (and node (normalized-load best (node-load node))))
(space (and node (node-free-disk-space node))))
(when session (disconnect! session))
(if (and node (< load 2.))
(if (and node (< load 2.) (>= space %minimum-disk-space))
(match others
(((machines slots) ...)
;; Release slots from the uninteresting machines.
@ -498,7 +512,13 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
;; eventually release it.
(values best slot)))
(begin
;; BEST is overloaded, so try the next one.
;; BEST is unsuitable, so try the next one.
(when (and space (< space %minimum-disk-space))
(format (current-error-port)
"skipping machine '~a' because it is low \
on disk space (~,2f MiB free)~%"
(build-machine-name best)
(/ space (expt 2 20) 1.)))
(release-build-slot slot)
(loop others)))))
(()
@ -694,15 +714,17 @@ machine."
(let* ((session (open-ssh-session machine))
(node (make-node session))
(uts (node-eval node '(uname)))
(load (node-load node)))
(load (node-load node))
(free (node-free-disk-space node)))
(disconnect! session)
(format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\
host name: ~a~% normalized load: ~a~%"
host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%"
(build-machine-name machine)
(utsname:sysname uts) (utsname:release uts)
(utsname:machine uts)
(utsname:nodename uts)
load)))
load
(/ free (expt 2 20) 1.))))
machines)))