aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/scripts/offload.scm109
1 files changed, 67 insertions, 42 deletions
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index e1da31af5d..dffc3e9fd2 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -199,6 +199,43 @@ there, and write the build log to LOG-PORT. Return the exit status."
(close-pipe pipe)))
+(define* (transfer-and-offload drv machine
+ #:key
+ (inputs '())
+ (outputs '())
+ (max-silent-time 3600)
+ (build-timeout 7200)
+ print-build-trace?)
+ "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of
+INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
+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 'bandwidth
+ (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
+ ;; Likewise (see above.)
+ (with-machine-lock machine 'bandwidth
+ (retrieve-files outputs machine))
+ (format (current-error-port)
+ "done with offloaded '~a'~%"
+ (derivation-file-name drv)))
+ (begin
+ (format (current-error-port)
+ "derivation '~a' offloaded to '~a' failed \
+with exit code ~a~%"
+ (derivation-file-name drv)
+ (build-machine-name machine)
+ (status:exit-val status))
+ (primitive-exit (status:exit-val status)))))))
+
(define (send-files files machine)
"Send the subset of FILES that's missing to MACHINE's store. Return #t on
success, #f otherwise."
@@ -387,8 +424,8 @@ connections allowed to MACHINE."
;; List of acquired build slots (open ports).
'())
-(define (choose-build-machine requirements machines)
- "Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f."
+(define (choose-build-machine machines)
+ "Return the best machine among MACHINES, or #f."
;; Proceed like this:
;; 1. Acquire the global machine-choice lock.
@@ -411,9 +448,7 @@ connections allowed to MACHINE."
(and (pred machine)
(list machine slot)))))
- (let ((machines+slots (sort (filter (undecorate
- (cut machine-matches? <> requirements))
- machines+slots)
+ (let ((machines+slots (sort machines+slots
(undecorate machine-less-loaded-or-faster?))))
(match machines+slots
(((best slot) (others slots) ...)
@@ -436,43 +471,33 @@ connections allowed to MACHINE."
print-build-trace? (max-silent-time 3600)
(build-timeout 7200))
"Process a request to build DRV."
- (let* ((local? (and wants-local? (string=? system (%current-system))))
- (reqs (build-requirements
- (system system)
- (features features)))
- (machine (choose-build-machine reqs (build-machines))))
- (if machine
- (begin
- (display "# accept\n")
- (let ((inputs (string-tokenize (read-line)))
- (outputs (string-tokenize (read-line))))
- ;; 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 'bandwidth
- (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
- ;; Likewise (see above.)
- (with-machine-lock machine 'bandwidth
- (retrieve-files outputs machine))
- (format (current-error-port)
- "done with offloaded '~a'~%"
- (derivation-file-name drv)))
- (begin
- (format (current-error-port)
- "derivation '~a' offloaded to '~a' failed \
-with exit code ~a~%"
- (derivation-file-name drv)
- (build-machine-name machine)
- (status:exit-val status))
- (primitive-exit (status:exit-val status))))))))
- (display "# decline\n"))))
+ (let* ((local? (and wants-local? (string=? system (%current-system))))
+ (reqs (build-requirements
+ (system system)
+ (features features)))
+ (candidates (filter (cut machine-matches? <> reqs)
+ (build-machines))))
+ (match candidates
+ (()
+ ;; We'll never be able to match REQS.
+ (display "# decline\n"))
+ ((_ ...)
+ (let ((machine (choose-build-machine candidates)))
+ (if machine
+ (begin
+ ;; Offload DRV to MACHINE.
+ (display "# accept\n")
+ (let ((inputs (string-tokenize (read-line)))
+ (outputs (string-tokenize (read-line))))
+ (transfer-and-offload drv machine
+ #:inputs inputs
+ #:outputs outputs
+ #:max-silent-time max-silent-time
+ #:build-timeout build-timeout
+ #:print-build-trace? print-build-trace?)))
+
+ ;; Not now, all the machines are busy.
+ (display "# postpone\n")))))))
(define-syntax-rule (with-nar-error-handling body ...)
"Execute BODY with any &nar-error suitably reported to the user."