nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Ludovic Courtès 2016-11-02 12:00:47 +01:00
parent 21531add32
commit 9e76eed37f
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 43 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
guix/scripts/offload.scm
View File

@ -197,9 +197,9 @@ instead of '~a' of type '~a'~%")
session)) session))
(define* (remote-pipe machine command (define* (remote-pipe session command
#:key (quote? #t)) #: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 which is also an SSH channel. When QUOTE? is true, perform shell-quotation of
all the elements of COMMAND." all the elements of COMMAND."
(define (shell-quote str) (define (shell-quote str)
@ -209,9 +209,7 @@ all the elements of COMMAND."
(lambda () (lambda ()
(write str)))) (write str))))
;; TODO: Use (ssh popen) instead. (let* ((channel (make-channel session)))
(let* ((session (open-ssh-session machine))
(channel (make-channel session)))
(channel-open-session channel) (channel-open-session channel)
(channel-request-exec channel (channel-request-exec channel
(string-join (if quote? (string-join (if quote?
@ -312,8 +310,9 @@ hook."
;; File name of the temporary GC root we install. ;; File name of the temporary GC root we install.
(format #f "offload-~a-~a" (gethostname) (getpid))) (format #f "offload-~a-~a" (gethostname) (getpid)))
(define (register-gc-root file machine) (define (register-gc-root file session)
"Mark FILE, a store item, as a garbage collector root on MACHINE." "Mark FILE, a store item, as a garbage collector root in SESSION. Return
the exit status, zero on success."
(define script (define script
`(begin `(begin
(use-modules (guix config)) (use-modules (guix config))
@ -344,7 +343,7 @@ hook."
(unless (= EEXIST (system-error-errno args)) (unless (= EEXIST (system-error-errno args))
(apply throw args))))))) (apply throw args)))))))
(let ((pipe (remote-pipe machine (let ((pipe (remote-pipe session
`("guile" "-c" ,(object->string script))))) `("guile" "-c" ,(object->string script)))))
(read-string pipe) (read-string pipe)
(let ((status (channel-get-exit-status pipe))) (let ((status (channel-get-exit-status pipe)))
@ -353,10 +352,10 @@ hook."
;; Better be safe than sorry: if we ignore the error here, then FILE ;; Better be safe than sorry: if we ignore the error here, then FILE
;; may be GC'd just before we start using it. ;; may be GC'd just before we start using it.
(leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%") (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) (define (remove-gc-roots session)
"Remove from MACHINE the GC roots previously installed with "Remove in SESSION the GC roots previously installed with
'register-gc-root'." 'register-gc-root'."
(define script (define script
`(begin `(begin
@ -377,24 +376,19 @@ hook."
(false-if-exception (delete-file file))) (false-if-exception (delete-file file)))
roots))))) roots)))))
(let ((pipe (remote-pipe machine (let ((pipe (remote-pipe session
`("guile" "-c" ,(object->string script))))) `("guile" "-c" ,(object->string script)))))
(read-string pipe) (read-string pipe)
(close-port pipe))) (close-port pipe)))
(define* (offload drv machine (define* (offload drv session
#:key print-build-trace? (max-silent-time 3600) #:key print-build-trace? (max-silent-time 3600)
build-timeout (log-port (build-log-port))) 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." 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. ;; Normally DRV has already been protected from GC when it was transferred.
;; The '-r' flag below prevents the build result from being GC'd. ;; The '-r' flag below prevents the build result from being GC'd.
(let ((pipe (remote-pipe machine (let ((pipe (remote-pipe session
`("guix" "build" `("guix" "build"
"-r" ,%gc-root-file "-r" ,%gc-root-file
,(format #f "--max-silent-time=~a" ,(format #f "--max-silent-time=~a"
@ -432,23 +426,31 @@ there, and write the build log to LOG-PORT. Return the exit status."
"Offload DRV to MACHINE. Prior to the actual offloading, transfer all of "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of
INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
MACHINE." MACHINE."
(define session
(open-ssh-session machine))
(when (begin (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) (send-files (cons (derivation-file-name drv) inputs)
machine)) session))
(let ((status (offload drv machine (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? #:print-build-trace? print-build-trace?
#:max-silent-time max-silent-time #:max-silent-time max-silent-time
#:build-timeout build-timeout))) #:build-timeout build-timeout)))
(if (zero? status) (if (zero? status)
(begin (begin
(retrieve-files outputs machine) (retrieve-files outputs session)
(remove-gc-roots machine) (remove-gc-roots session)
(format (current-error-port) (format (current-error-port)
"done with offloaded '~a'~%" "done with offloaded '~a'~%"
(derivation-file-name drv))) (derivation-file-name drv)))
(begin (begin
(remove-gc-roots machine) (remove-gc-roots session)
(format (current-error-port) (format (current-error-port)
"derivation '~a' offloaded to '~a' failed \ "derivation '~a' offloaded to '~a' failed \
with exit code ~a~%" with exit code ~a~%"
@ -460,13 +462,13 @@ with exit code ~a~%"
;; interprets other non-zero codes as transient build failures. ;; interprets other non-zero codes as transient build failures.
(primitive-exit 100)))))) (primitive-exit 100))))))
(define (send-files files machine) (define (send-files files session)
"Send the subset of FILES that's missing to MACHINE's store. Return #t on "Send the subset of FILES that's missing to SESSION's store. Return #t on
success, #f otherwise." success, #f otherwise."
(define (missing-files files) (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. ;; 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") `("guix" "archive" "--missing")
#:quote? #f))) #:quote? #f)))
(format pipe "~{~a~%~}" files) (format pipe "~{~a~%~}" files)
@ -476,18 +478,17 @@ success, #f otherwise."
(with-store store (with-store store
(guard (c ((nix-protocol-error? c) (guard (c ((nix-protocol-error? c)
(warning (_ "failed to export files for '~a': ~s~%") (warning (_ "failed to export files for '~a': ~s~%")
(build-machine-name machine) (session-get session 'host) c)
c)
#f)) #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. ;; topologically sorted order so that they can actually be imported.
(let* ((files (missing-files (topologically-sorted store files))) (let* ((files (missing-files (topologically-sorted store files)))
(pipe (remote-pipe machine (pipe (remote-pipe session
'("guix" "archive" "--import") '("guix" "archive" "--import")
#:quote? #f))) #:quote? #f)))
(format #t (_ "sending ~a store files to '~a'...~%") (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) (export-paths store files pipe)
(channel-send-eof pipe) (channel-send-eof pipe)
@ -497,12 +498,12 @@ success, #f otherwise."
(close pipe) (close pipe)
status))))) status)))))
(define (retrieve-files files machine) (define (retrieve-files files session)
"Retrieve FILES from MACHINE's store, and import them." "Retrieve FILES from SESSION's store, and import them."
(define host (define host
(build-machine-name machine)) (session-get session 'host))
(let ((pipe (remote-pipe machine (let ((pipe (remote-pipe session
`("guix" "archive" "--export" ,@files) `("guix" "archive" "--export" ,@files)
#:quote? #f))) #:quote? #f)))
(and pipe (and pipe
@ -538,7 +539,8 @@ success, #f otherwise."
(define (machine-load machine) (define (machine-load machine)
"Return the load of MACHINE, divided by the number of parallel builds "Return the load of MACHINE, divided by the number of parallel builds
allowed on MACHINE." 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))) (line (read-line pipe)))
(close-port pipe) (close-port pipe)