diff options
Diffstat (limited to 'guix/scripts/offload.scm')
| -rw-r--r-- | guix/scripts/offload.scm | 116 |
1 files changed, 57 insertions, 59 deletions
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 5b971302f3..d5ee907c36 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -122,38 +122,40 @@ determined." (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) -(define (open-ssh-gateway machine) - "Initiate an SSH connection gateway to MACHINE, and return the PID of the -running lsh gateway upon success, or #f on failure." - (catch 'system-error - (lambda () - (let* ((port (open-pipe* OPEN_READ %lsh-command - "-l" (build-machine-user machine) - "-i" (build-machine-private-key machine) - ;; XXX: With lsh 2.1, passing '--write-pid' - ;; last causes the PID not to be printed. - "--write-pid" "--gateway" "--background" "-z" - (build-machine-name machine))) - (line (read-line port)) - (status (close-pipe port))) - (if (zero? status) - (let ((pid (string->number line))) - (if (integer? pid) - pid - (begin - (warning (_ "'~a' did not write its PID on stdout: ~s~%") - %lsh-command line) - #f))) - (begin - (warning (_ "failed to initiate SSH connection to '~a':\ - '~a' exited with ~a~%") - (build-machine-name machine) - %lsh-command - (status:exit-val status)) - #f)))) - (lambda args - (leave (_ "failed to execute '~a': ~a~%") - %lsh-command (strerror (system-error-errno args)))))) +;;; FIXME: The idea was to open the connection to MACHINE once for all, but +;;; lshg is currently non-functional. +;; (define (open-ssh-gateway machine) +;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the +;; running lsh gateway upon success, or #f on failure." +;; (catch 'system-error +;; (lambda () +;; (let* ((port (open-pipe* OPEN_READ %lsh-command +;; "-l" (build-machine-user machine) +;; "-i" (build-machine-private-key machine) +;; ;; XXX: With lsh 2.1, passing '--write-pid' +;; ;; last causes the PID not to be printed. +;; "--write-pid" "--gateway" "--background" "-z" +;; (build-machine-name machine))) +;; (line (read-line port)) +;; (status (close-pipe port))) +;; (if (zero? status) +;; (let ((pid (string->number line))) +;; (if (integer? pid) +;; pid +;; (begin +;; (warning (_ "'~a' did not write its PID on stdout: ~s~%") +;; %lsh-command line) +;; #f))) +;; (begin +;; (warning (_ "failed to initiate SSH connection to '~a':\ +;; '~a' exited with ~a~%") +;; (build-machine-name machine) +;; %lsh-command +;; (status:exit-val status)) +;; #f)))) +;; (lambda args +;; (leave (_ "failed to execute '~a': ~a~%") +;; %lsh-command (strerror (system-error-errno args)))))) (define (remote-pipe machine mode command) "Run COMMAND on MACHINE, assuming an lsh gateway has been set up." @@ -324,34 +326,30 @@ allowed on MACHINE." (features features))) (machine (choose-build-machine reqs (build-machines)))) (if machine - (match (open-ssh-gateway machine) - ((? integer? pid) - (display "# accept\n") - (let ((inputs (string-tokenize (read-line))) - (outputs (string-tokenize (read-line)))) - (when (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))) - (kill pid SIGTERM) - (if (zero? status) - (begin - (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 \ + (begin + (display "# accept\n") + (let ((inputs (string-tokenize (read-line))) + (outputs (string-tokenize (read-line)))) + (when (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) + (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)))))))) - (#f - (display "# decline\n"))) + (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 ...) |