summaryrefslogtreecommitdiff
path: root/guix/scripts/offload.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/offload.scm')
-rw-r--r--guix/scripts/offload.scm50
1 files changed, 46 insertions, 4 deletions
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index d5ee907c36..2c9ecafcb9 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -23,7 +23,7 @@
#:use-module (guix derivations)
#:use-module (guix nar)
#:use-module (guix utils)
- #:use-module ((guix build utils) #:select (which))
+ #:use-module ((guix build utils) #:select (which mkdir-p))
#:use-module (guix ui)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
@@ -303,6 +303,38 @@ allowed on MACHINE."
(or (machine-less-loaded? m1 m2)
(machine-faster? m1 m2)))
+(define (machine-lock-file machine)
+ "Return the name of MACHINE's lock file."
+ (string-append %state-directory "/offload/"
+ (build-machine-name machine) ".lock"))
+
+(define (lock-machine machine)
+ "Wait to acquire MACHINE's lock, and return the lock."
+ (let ((file (machine-lock-file machine)))
+ (mkdir-p (dirname file))
+ (let ((port (open-file file "w0")))
+ (fcntl-flock port 'write-lock)
+ port)))
+
+(define (unlock-machine machine lock)
+ "Unlock LOCK, MACHINE's lock."
+ (fcntl-flock lock 'unlock)
+ (close-port lock)
+ #t)
+
+(define-syntax-rule (with-machine-lock machine exp ...)
+ "Wait to acquire MACHINE's exclusive lock, and evaluate EXP in that
+context."
+ (let* ((m machine)
+ (lock (lock-machine m)))
+ (dynamic-wind
+ (lambda ()
+ #t)
+ (lambda ()
+ exp ...)
+ (lambda ()
+ (unlock-machine m lock)))))
+
(define (choose-build-machine requirements machines)
"Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f."
(let ((machines (sort (filter (cut machine-matches? <> requirements)
@@ -330,15 +362,21 @@ allowed on MACHINE."
(display "# accept\n")
(let ((inputs (string-tokenize (read-line)))
(outputs (string-tokenize (read-line))))
- (when (send-files (cons (derivation-file-name drv) inputs)
- machine)
+ ;; Acquire MACHINE's exclusive lock to serialize file transfers
+ ;; to/from MACHINE in the presence of several 'offload' hook
+ ;; instance.
+ (when (with-machine-lock machine
+ (send-files (cons (derivation-file-name drv) inputs)
+ machine))
(let ((status (offload drv machine
#:print-build-trace? print-build-trace?
#:max-silent-time max-silent-time
#:build-timeout build-timeout)))
(if (zero? status)
(begin
- (retrieve-files outputs machine)
+ ;; Likewise (see above.)
+ (with-machine-lock machine
+ (retrieve-files outputs machine))
(format (current-error-port)
"done with offloaded '~a'~%"
(derivation-file-name drv)))
@@ -420,4 +458,8 @@ This tool is meant to be used internally by 'guix-daemon'.\n"))
(x
(leave (_ "invalid arguments: ~{~s ~}~%") x))))
+;;; Local Variables:
+;;; eval: (put 'with-machine-lock 'scheme-indent-function 1)
+;;; End:
+
;;; offload.scm ends here