mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
offload: Reuse SSH session during 'transfer-and-offload'.
* guix/scripts/offload.scm (remote-pipe): Replace 'machine' parameter with 'session'. Remove 'open-ssh-session' call. (register-gc-root): Replace 'machine' with 'session'. Use ' session-get' instead of 'build-machine-name'. (remove-gc-roots, offload, send-files, retrieve-files): Likewise. (transfer-and-offload): Add 'open-ssh-session' call. Handle 'offload' errors here. (machine-load): Add call to 'open-ssh-session'.
This commit is contained in:
parent
21531add32
commit
9e76eed37f
1 changed files with 43 additions and 41 deletions
|
@ -197,9 +197,9 @@ (define (open-ssh-session machine)
|
|||
|
||||
session))
|
||||
|
||||
(define* (remote-pipe machine command
|
||||
(define* (remote-pipe session command
|
||||
#:key (quote? #t))
|
||||
"Run COMMAND (a list) on MACHINE, and return an open input/output port,
|
||||
"Run COMMAND (a list) on SESSION, and return an open input/output port,
|
||||
which is also an SSH channel. When QUOTE? is true, perform shell-quotation of
|
||||
all the elements of COMMAND."
|
||||
(define (shell-quote str)
|
||||
|
@ -209,9 +209,7 @@ (define (shell-quote str)
|
|||
(lambda ()
|
||||
(write str))))
|
||||
|
||||
;; TODO: Use (ssh popen) instead.
|
||||
(let* ((session (open-ssh-session machine))
|
||||
(channel (make-channel session)))
|
||||
(let* ((channel (make-channel session)))
|
||||
(channel-open-session channel)
|
||||
(channel-request-exec channel
|
||||
(string-join (if quote?
|
||||
|
@ -312,8 +310,9 @@ (define %gc-root-file
|
|||
;; File name of the temporary GC root we install.
|
||||
(format #f "offload-~a-~a" (gethostname) (getpid)))
|
||||
|
||||
(define (register-gc-root file machine)
|
||||
"Mark FILE, a store item, as a garbage collector root on MACHINE."
|
||||
(define (register-gc-root file session)
|
||||
"Mark FILE, a store item, as a garbage collector root in SESSION. Return
|
||||
the exit status, zero on success."
|
||||
(define script
|
||||
`(begin
|
||||
(use-modules (guix config))
|
||||
|
@ -344,7 +343,7 @@ (define script
|
|||
(unless (= EEXIST (system-error-errno args))
|
||||
(apply throw args)))))))
|
||||
|
||||
(let ((pipe (remote-pipe machine
|
||||
(let ((pipe (remote-pipe session
|
||||
`("guile" "-c" ,(object->string script)))))
|
||||
(read-string pipe)
|
||||
(let ((status (channel-get-exit-status pipe)))
|
||||
|
@ -353,10 +352,10 @@ (define script
|
|||
;; Better be safe than sorry: if we ignore the error here, then FILE
|
||||
;; may be GC'd just before we start using it.
|
||||
(leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%")
|
||||
file (build-machine-name machine) status)))))
|
||||
file (session-get session 'host) status)))))
|
||||
|
||||
(define (remove-gc-roots machine)
|
||||
"Remove from MACHINE the GC roots previously installed with
|
||||
(define (remove-gc-roots session)
|
||||
"Remove in SESSION the GC roots previously installed with
|
||||
'register-gc-root'."
|
||||
(define script
|
||||
`(begin
|
||||
|
@ -377,24 +376,19 @@ (define script
|
|||
(false-if-exception (delete-file file)))
|
||||
roots)))))
|
||||
|
||||
(let ((pipe (remote-pipe machine
|
||||
(let ((pipe (remote-pipe session
|
||||
`("guile" "-c" ,(object->string script)))))
|
||||
(read-string pipe)
|
||||
(close-port pipe)))
|
||||
|
||||
(define* (offload drv machine
|
||||
(define* (offload drv session
|
||||
#:key print-build-trace? (max-silent-time 3600)
|
||||
build-timeout (log-port (build-log-port)))
|
||||
"Perform DRV on MACHINE, assuming DRV and its prerequisites are available
|
||||
"Perform DRV in SESSION, assuming DRV and its prerequisites are available
|
||||
there, and write the build log to LOG-PORT. Return the exit status."
|
||||
(format (current-error-port) "offloading '~a' to '~a'...~%"
|
||||
(derivation-file-name drv) (build-machine-name machine))
|
||||
(format (current-error-port) "@ build-remote ~a ~a~%"
|
||||
(derivation-file-name drv) (build-machine-name machine))
|
||||
|
||||
;; Normally DRV has already been protected from GC when it was transferred.
|
||||
;; The '-r' flag below prevents the build result from being GC'd.
|
||||
(let ((pipe (remote-pipe machine
|
||||
(let ((pipe (remote-pipe session
|
||||
`("guix" "build"
|
||||
"-r" ,%gc-root-file
|
||||
,(format #f "--max-silent-time=~a"
|
||||
|
@ -432,23 +426,31 @@ (define* (transfer-and-offload drv machine
|
|||
"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."
|
||||
(define session
|
||||
(open-ssh-session machine))
|
||||
|
||||
(when (begin
|
||||
(register-gc-root (derivation-file-name drv) machine)
|
||||
(register-gc-root (derivation-file-name drv) session)
|
||||
(send-files (cons (derivation-file-name drv) inputs)
|
||||
machine))
|
||||
(let ((status (offload drv machine
|
||||
session))
|
||||
(format (current-error-port) "offloading '~a' to '~a'...~%"
|
||||
(derivation-file-name drv) (build-machine-name machine))
|
||||
(format (current-error-port) "@ build-remote ~a ~a~%"
|
||||
(derivation-file-name drv) (build-machine-name machine))
|
||||
|
||||
(let ((status (offload drv session
|
||||
#:print-build-trace? print-build-trace?
|
||||
#:max-silent-time max-silent-time
|
||||
#:build-timeout build-timeout)))
|
||||
(if (zero? status)
|
||||
(begin
|
||||
(retrieve-files outputs machine)
|
||||
(remove-gc-roots machine)
|
||||
(retrieve-files outputs session)
|
||||
(remove-gc-roots session)
|
||||
(format (current-error-port)
|
||||
"done with offloaded '~a'~%"
|
||||
(derivation-file-name drv)))
|
||||
(begin
|
||||
(remove-gc-roots machine)
|
||||
(remove-gc-roots session)
|
||||
(format (current-error-port)
|
||||
"derivation '~a' offloaded to '~a' failed \
|
||||
with exit code ~a~%"
|
||||
|
@ -460,13 +462,13 @@ (define* (transfer-and-offload drv machine
|
|||
;; interprets other non-zero codes as transient build failures.
|
||||
(primitive-exit 100))))))
|
||||
|
||||
(define (send-files files machine)
|
||||
"Send the subset of FILES that's missing to MACHINE's store. Return #t on
|
||||
(define (send-files files session)
|
||||
"Send the subset of FILES that's missing to SESSION's store. Return #t on
|
||||
success, #f otherwise."
|
||||
(define (missing-files files)
|
||||
;; Return the subset of FILES not already on MACHINE. Use 'head' as a
|
||||
;; Return the subset of FILES not already on SESSION. Use 'head' as a
|
||||
;; hack to make sure the remote end stops reading when we're done.
|
||||
(let* ((pipe (remote-pipe machine
|
||||
(let* ((pipe (remote-pipe session
|
||||
`("guix" "archive" "--missing")
|
||||
#:quote? #f)))
|
||||
(format pipe "~{~a~%~}" files)
|
||||
|
@ -476,18 +478,17 @@ (define (missing-files files)
|
|||
(with-store store
|
||||
(guard (c ((nix-protocol-error? c)
|
||||
(warning (_ "failed to export files for '~a': ~s~%")
|
||||
(build-machine-name machine)
|
||||
c)
|
||||
(session-get session 'host) c)
|
||||
#f))
|
||||
|
||||
;; Compute the subset of FILES missing on MACHINE, and send them in
|
||||
;; Compute the subset of FILES missing on SESSION, and send them in
|
||||
;; topologically sorted order so that they can actually be imported.
|
||||
(let* ((files (missing-files (topologically-sorted store files)))
|
||||
(pipe (remote-pipe machine
|
||||
(pipe (remote-pipe session
|
||||
'("guix" "archive" "--import")
|
||||
#:quote? #f)))
|
||||
(format #t (_ "sending ~a store files to '~a'...~%")
|
||||
(length files) (build-machine-name machine))
|
||||
(length files) (session-get session 'host))
|
||||
|
||||
(export-paths store files pipe)
|
||||
(channel-send-eof pipe)
|
||||
|
@ -497,12 +498,12 @@ (define (missing-files files)
|
|||
(close pipe)
|
||||
status)))))
|
||||
|
||||
(define (retrieve-files files machine)
|
||||
"Retrieve FILES from MACHINE's store, and import them."
|
||||
(define (retrieve-files files session)
|
||||
"Retrieve FILES from SESSION's store, and import them."
|
||||
(define host
|
||||
(build-machine-name machine))
|
||||
(session-get session 'host))
|
||||
|
||||
(let ((pipe (remote-pipe machine
|
||||
(let ((pipe (remote-pipe session
|
||||
`("guix" "archive" "--export" ,@files)
|
||||
#:quote? #f)))
|
||||
(and pipe
|
||||
|
@ -538,7 +539,8 @@ (define (machine-matches? machine requirements)
|
|||
(define (machine-load machine)
|
||||
"Return the load of MACHINE, divided by the number of parallel builds
|
||||
allowed on MACHINE."
|
||||
(let* ((pipe (remote-pipe machine '("cat" "/proc/loadavg")))
|
||||
(let* ((session (open-ssh-session machine))
|
||||
(pipe (remote-pipe session '("cat" "/proc/loadavg")))
|
||||
(line (read-line pipe)))
|
||||
(close-port pipe)
|
||||
|
||||
|
|
Loading…
Reference in a new issue