Skip to content
Snippets Groups Projects
Commit 88da0b68 authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

offload: Distinguish between 'decline' and 'postpone'.

* guix/scripts/offload.scm (transfer-and-offload): New procedure, with
  core formerly in 'process-request'.
  (choose-build-machine): Remove 'requirements' parameter.
  (process-request): Reply 'decline' when none of MACHINES matches the
  requirements, and 'postpone' when MACHINES are busy.
parent 0e6260a4
No related branches found
No related tags found
No related merge requests found
...@@ -199,6 +199,43 @@ (define* (offload drv machine ...@@ -199,6 +199,43 @@ (define* (offload drv machine
(close-pipe pipe))) (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) (define (send-files files machine)
"Send the subset of FILES that's missing to MACHINE's store. Return #t on "Send the subset of FILES that's missing to MACHINE's store. Return #t on
success, #f otherwise." success, #f otherwise."
...@@ -387,8 +424,8 @@ (define %slots ...@@ -387,8 +424,8 @@ (define %slots
;; List of acquired build slots (open ports). ;; List of acquired build slots (open ports).
'()) '())
(define (choose-build-machine requirements machines) (define (choose-build-machine machines)
"Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f." "Return the best machine among MACHINES, or #f."
;; Proceed like this: ;; Proceed like this:
;; 1. Acquire the global machine-choice lock. ;; 1. Acquire the global machine-choice lock.
...@@ -411,9 +448,7 @@ (define (undecorate pred) ...@@ -411,9 +448,7 @@ (define (undecorate pred)
(and (pred machine) (and (pred machine)
(list machine slot))))) (list machine slot)))))
(let ((machines+slots (sort (filter (undecorate (let ((machines+slots (sort machines+slots
(cut machine-matches? <> requirements))
machines+slots)
(undecorate machine-less-loaded-or-faster?)))) (undecorate machine-less-loaded-or-faster?))))
(match machines+slots (match machines+slots
(((best slot) (others slots) ...) (((best slot) (others slots) ...)
...@@ -436,43 +471,33 @@ (define* (process-request wants-local? system drv features ...@@ -436,43 +471,33 @@ (define* (process-request wants-local? system drv features
print-build-trace? (max-silent-time 3600) print-build-trace? (max-silent-time 3600)
(build-timeout 7200)) (build-timeout 7200))
"Process a request to build DRV." "Process a request to build DRV."
(let* ((local? (and wants-local? (string=? system (%current-system)))) (let* ((local? (and wants-local? (string=? system (%current-system))))
(reqs (build-requirements (reqs (build-requirements
(system system) (system system)
(features features))) (features features)))
(machine (choose-build-machine reqs (build-machines)))) (candidates (filter (cut machine-matches? <> reqs)
(if machine (build-machines))))
(begin (match candidates
(display "# accept\n") (()
(let ((inputs (string-tokenize (read-line))) ;; We'll never be able to match REQS.
(outputs (string-tokenize (read-line)))) (display "# decline\n"))
;; Acquire MACHINE's exclusive lock to serialize file transfers ((_ ...)
;; to/from MACHINE in the presence of several 'offload' hook (let ((machine (choose-build-machine candidates)))
;; instance. (if machine
(when (with-machine-lock machine 'bandwidth (begin
(send-files (cons (derivation-file-name drv) inputs) ;; Offload DRV to MACHINE.
machine)) (display "# accept\n")
(let ((status (offload drv machine (let ((inputs (string-tokenize (read-line)))
#:print-build-trace? print-build-trace? (outputs (string-tokenize (read-line))))
#:max-silent-time max-silent-time (transfer-and-offload drv machine
#:build-timeout build-timeout))) #:inputs inputs
(if (zero? status) #:outputs outputs
(begin #:max-silent-time max-silent-time
;; Likewise (see above.) #:build-timeout build-timeout
(with-machine-lock machine 'bandwidth #:print-build-trace? print-build-trace?)))
(retrieve-files outputs machine))
(format (current-error-port) ;; Not now, all the machines are busy.
"done with offloaded '~a'~%" (display "# postpone\n")))))))
(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"))))
(define-syntax-rule (with-nar-error-handling body ...) (define-syntax-rule (with-nar-error-handling body ...)
"Execute BODY with any &nar-error suitably reported to the user." "Execute BODY with any &nar-error suitably reported to the user."
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment