summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-03-02 22:39:48 +0100
committerLudovic Courtès <ludo@gnu.org>2016-11-25 23:44:20 +0100
commit21531add3205e400707c8fbfd841845f9a71863a (patch)
tree8a88aa7b2fe01f5707bcf130fe09d54c0a95d33f
parent6634180f9eabc70cdc5bc8e9ce2ff0f9250625bc (diff)
offload: Use Guile-SSH instead of GNU lsh.
* guix/scripts/offload.scm (<build-machine>)[ssh-options]: Remove. [host-key, host-key-type]: New fields. (%lsh-command, %lshg-command, user-lsh-private-key): Remove. (user-openssh-private-key, private-key-from-file*): New procedures. (host-key->type+key, open-ssh-session): New procedures. (remote-pipe): Remove 'mode' parameter. Rewrite in terms of 'open-ssh-session' etc. Update users. (send-files)[missing-files]: Rewrite using the bidirectional channel port. Remove call to 'call-with-compressed-output-port'. (retrieve-files): Remove call to 'call-with-decompressed-port'. (machine-load): Remove exit status logic. * doc/guix.texi (Requirements): Mention Guile-SSH. (Daemon Offload Setup): Document 'host-key' and 'private-key'. Show the default value on each @item line. * m4/guix.m4 (GUIX_CHECK_GUILE_SSH): New macro. * config-daemon.ac: Use 'GUIX_CHECK_GUILE_SSH'. Set 'HAVE_DAEMON_OFFLOAD_HOOK' as a function of that.
-rw-r--r--config-daemon.ac18
-rw-r--r--doc/guix.texi69
-rw-r--r--guix/scripts/offload.scm279
-rw-r--r--m4/guix.m418
4 files changed, 213 insertions, 171 deletions
diff --git a/config-daemon.ac b/config-daemon.ac
index 8a3e6d8b601..056c939e390 100644
--- a/config-daemon.ac
+++ b/config-daemon.ac
@@ -128,12 +128,20 @@ if test "x$guix_build_daemon" = "xyes"; then
128 dnl 'restore-file-set', which requires unbuffered custom binary input 128 dnl 'restore-file-set', which requires unbuffered custom binary input
129 dnl ports from Guile >= 2.0.10.) 129 dnl ports from Guile >= 2.0.10.)
130 GUIX_CHECK_UNBUFFERED_CBIP 130 GUIX_CHECK_UNBUFFERED_CBIP
131 guix_build_daemon_offload="$ac_cv_guix_cbips_support_setvbuf"
132 131
133 if test "x$guix_build_daemon_offload" = "xyes"; then 132 dnl Check for Guile-SSH, which is required by 'guix offload'.
134 AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1], 133 GUIX_CHECK_GUILE_SSH
135 [Define if the daemon's 'offload' build hook is being built.]) 134
136 fi 135 case "x$ac_cv_guix_cbips_support_setvbuf$guix_cv_have_recent_guile_ssh" in
136 xyesyes)
137 guix_build_daemon_offload="yes"
138 AC_DEFINE([HAVE_DAEMON_OFFLOAD_HOOK], [1],
139 [Define if the daemon's 'offload' build hook is being built (requires Guile-SSH).])
140 ;;
141 *)
142 guix_build_daemon_offload="no"
143 ;;
144 esac
137 145
138 dnl Temporary directory used to store the daemon's data. 146 dnl Temporary directory used to store the daemon's data.
139 GUIX_TEST_ROOT_DIRECTORY 147 GUIX_TEST_ROOT_DIRECTORY
diff --git a/doc/guix.texi b/doc/guix.texi
index ebb138e15d6..f1cb007aa90 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -567,6 +567,12 @@ guix import}). It is of
567interest primarily for developers and not for casual users. 567interest primarily for developers and not for casual users.
568 568
569@item 569@item
570@c Note: We need at least 0.10.2 for 'channel-send-eof'.
571Support for build offloading (@pxref{Daemon Offload Setup}) depends on
572@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH},
573version 0.10.2 or later.
574
575@item
570When @url{http://zlib.net, zlib} is available, @command{guix publish} 576When @url{http://zlib.net, zlib} is available, @command{guix publish}
571can compress build byproducts (@pxref{Invoking guix publish}). 577can compress build byproducts (@pxref{Invoking guix publish}).
572@end itemize 578@end itemize
@@ -814,9 +820,11 @@ available on the system---making it much harder to view them as
814 820
815@cindex offloading 821@cindex offloading
816@cindex build hook 822@cindex build hook
817When desired, the build daemon can @dfn{offload} 823When desired, the build daemon can @dfn{offload} derivation builds to
818derivation builds to other machines 824other machines running Guix, using the @code{offload} @dfn{build
819running Guix, using the @code{offload} @dfn{build hook}. When that 825hook}@footnote{This feature is available only when
826@uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH} is
827present.}. When that
820feature is enabled, a list of user-specified build machines is read from 828feature is enabled, a list of user-specified build machines is read from
821@file{/etc/guix/machines.scm}; every time a build is requested, for 829@file{/etc/guix/machines.scm}; every time a build is requested, for
822instance via @code{guix build}, the daemon attempts to offload it to one 830instance via @code{guix build}, the daemon attempts to offload it to one
@@ -832,16 +840,18 @@ The @file{/etc/guix/machines.scm} file typically looks like this:
832(list (build-machine 840(list (build-machine
833 (name "eightysix.example.org") 841 (name "eightysix.example.org")
834 (system "x86_64-linux") 842 (system "x86_64-linux")
843 (host-key "ssh-ed25519 AAAAC3Nza@dots{}")
835 (user "bob") 844 (user "bob")
836 (speed 2.)) ; incredibly fast! 845 (speed 2.)) ;incredibly fast!
837 846
838 (build-machine 847 (build-machine
839 (name "meeps.example.org") 848 (name "meeps.example.org")
840 (system "mips64el-linux") 849 (system "mips64el-linux")
850 (host-key "ssh-rsa AAAAB3Nza@dots{}")
841 (user "alice") 851 (user "alice")
842 (private-key 852 (private-key
843 (string-append (getenv "HOME") 853 (string-append (getenv "HOME")
844 "/.lsh/identity-for-guix")))) 854 "/.ssh/identity-for-guix"))))
845@end example 855@end example
846 856
847@noindent 857@noindent
@@ -875,31 +885,50 @@ The user account to use when connecting to the remote machine over SSH.
875Note that the SSH key pair must @emph{not} be passphrase-protected, to 885Note that the SSH key pair must @emph{not} be passphrase-protected, to
876allow non-interactive logins. 886allow non-interactive logins.
877 887
888@item host-key
889This must be the machine's SSH @dfn{public host key} in OpenSSH format.
890This is used to authenticate the machine when we connect to it. It is a
891long string that looks like this:
892
893@example
894ssh-ed25519 AAAAC3NzaC@dots{}mde+UhL hint@@example.org
895@end example
896
897If the machine is running the OpenSSH daemon, @command{sshd}, the host
898key can be found in a file such as
899@file{/etc/ssh/ssh_host_ed25519_key.pub}.
900
901If the machine is running the SSH daemon of GNU@tie{}lsh,
902@command{lshd}, the host key is in @file{/etc/lsh/host-key.pub} or a
903similar file. It can be converted to the OpenSSH format using
904@command{lsh-export-key} (@pxref{Converting keys,,, lsh, LSH Manual}):
905
906@example
907$ lsh-export-key --openssh < /etc/lsh/host-key.pub
908ssh-rsa AAAAB3NzaC1yc2EAAAAEOp8FoQAAAQEAs1eB46LV@dots{}
909@end example
910
878@end table 911@end table
879 912
880A number of optional fields may be specified: 913A number of optional fields may be specified:
881 914
882@table @code 915@table @asis
883
884@item port
885Port number of SSH server on the machine (default: 22).
886 916
887@item private-key 917@item @code{port} (default: @code{22})
888The SSH private key file to use when connecting to the machine. 918Port number of SSH server on the machine.
889 919
890Currently offloading uses GNU@tie{}lsh as its SSH client 920@item @code{private-key} (default: @file{~/.ssh/id_rsa})
891(@pxref{Invoking lsh,,, GNU lsh Manual}). Thus, the key file here must 921The SSH private key file to use when connecting to the machine, in
892be an lsh key file. This may change in the future, though. 922OpenSSH format.
893 923
894@item parallel-builds 924@item @code{parallel-builds} (default: @code{1})
895The number of builds that may run in parallel on the machine (1 by 925The number of builds that may run in parallel on the machine.
896default.)
897 926
898@item speed 927@item @code{speed} (default: @code{1.0})
899A ``relative speed factor''. The offload scheduler will tend to prefer 928A ``relative speed factor''. The offload scheduler will tend to prefer
900machines with a higher speed factor. 929machines with a higher speed factor.
901 930
902@item features 931@item @code{features} (default: @code{'()})
903A list of strings denoting specific features supported by the machine. 932A list of strings denoting specific features supported by the machine.
904An example is @code{"kvm"} for machines that have the KVM Linux modules 933An example is @code{"kvm"} for machines that have the KVM Linux modules
905and corresponding hardware support. Derivations can request features by 934and corresponding hardware support. Derivations can request features by
@@ -915,7 +944,7 @@ machines, since offloading works by invoking the @code{guix archive} and
915this is the case by running: 944this is the case by running:
916 945
917@example 946@example
918lsh build-machine guile -c "'(use-modules (guix config))'" 947ssh build-machine guile -c "'(use-modules (guix config))'"
919@end example 948@end example
920 949
921There is one last thing to do once @file{machines.scm} is in place. As 950There is one last thing to do once @file{machines.scm} is in place. As
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 33d141e7eff..327c99dfeaf 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -17,6 +17,10 @@
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. 17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18 18
19(define-module (guix scripts offload) 19(define-module (guix scripts offload)
20 #:use-module (ssh key)
21 #:use-module (ssh auth)
22 #:use-module (ssh session)
23 #:use-module (ssh channel)
20 #:use-module (guix config) 24 #:use-module (guix config)
21 #:use-module (guix records) 25 #:use-module (guix records)
22 #:use-module (guix store) 26 #:use-module (guix store)
@@ -65,14 +69,13 @@
65 (system build-machine-system) ; string 69 (system build-machine-system) ; string
66 (user build-machine-user) ; string 70 (user build-machine-user) ; string
67 (private-key build-machine-private-key ; file name 71 (private-key build-machine-private-key ; file name
68 (default (user-lsh-private-key))) 72 (default (user-openssh-private-key)))
73 (host-key build-machine-host-key) ; string
69 (parallel-builds build-machine-parallel-builds ; number 74 (parallel-builds build-machine-parallel-builds ; number
70 (default 1)) 75 (default 1))
71 (speed build-machine-speed ; inexact real 76 (speed build-machine-speed ; inexact real
72 (default 1.0)) 77 (default 1.0))
73 (features build-machine-features ; list of strings 78 (features build-machine-features ; list of strings
74 (default '()))
75 (ssh-options build-machine-ssh-options ; list of strings
76 (default '()))) 79 (default '())))
77 80
78(define-record-type* <build-requirements> 81(define-record-type* <build-requirements>
@@ -86,19 +89,11 @@
86 ;; File that lists machines available as build slaves. 89 ;; File that lists machines available as build slaves.
87 (string-append %config-directory "/machines.scm")) 90 (string-append %config-directory "/machines.scm"))
88 91
89(define %lsh-command 92(define (user-openssh-private-key)
90 "lsh") 93 "Return the user's default SSH private key, or #f if it could not be
91
92(define %lshg-command
93 ;; FIXME: 'lshg' fails to pass large amounts of data, see
94 ;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>.
95 "lsh")
96
97(define (user-lsh-private-key)
98 "Return the user's default lsh private key, or #f if it could not be
99determined." 94determined."
100 (and=> (getenv "HOME") 95 (and=> (getenv "HOME")
101 (cut string-append <> "/.lsh/identity"))) 96 (cut string-append <> "/.ssh/id_rsa")))
102 97
103(define %user-module 98(define %user-module
104 ;; Module in which the machine description file is loaded. 99 ;; Module in which the machine description file is loaded.
@@ -134,60 +129,79 @@ determined."
134 (leave (_ "failed to load machine file '~a': ~s~%") 129 (leave (_ "failed to load machine file '~a': ~s~%")
135 file args)))))) 130 file args))))))
136 131
137;;; FIXME: The idea was to open the connection to MACHINE once for all, but 132(define (host-key->type+key host-key)
138;;; lshg is currently non-functional. 133 "Destructure HOST-KEY, an OpenSSH host key string, and return two values:
139;; (define (open-ssh-gateway machine) 134its key type as a symbol, and the actual base64-encoded string."
140;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the 135 (define (type->symbol type)
141;; running lsh gateway upon success, or #f on failure." 136 (and (string-prefix? "ssh-" type)
142;; (catch 'system-error 137 (string->symbol (string-drop type 4))))
143;; (lambda () 138
144;; (let* ((port (open-pipe* OPEN_READ %lsh-command 139 (match (string-tokenize host-key)
145;; "-l" (build-machine-user machine) 140 ((type key _)
146;; "-i" (build-machine-private-key machine) 141 (values (type->symbol type) key))
147;; ;; XXX: With lsh 2.1, passing '--write-pid' 142 ((type key)
148;; ;; last causes the PID not to be printed. 143 (values (type->symbol type) key))))
149;; "--write-pid" "--gateway" "--background" 144
150;; (build-machine-name machine))) 145(define (private-key-from-file* file)
151;; (line (read-line port)) 146 "Like 'private-key-from-file', but raise an error that 'with-error-handling'
152;; (status (close-pipe port))) 147can interpret meaningfully."
153;; (if (zero? status) 148 (catch 'guile-ssh-error
154;; (let ((pid (string->number line))) 149 (lambda ()
155;; (if (integer? pid) 150 (private-key-from-file file))
156;; pid 151 (lambda (key proc str . rest)
157;; (begin 152 (raise (condition
158;; (warning (_ "'~a' did not write its PID on stdout: ~s~%") 153 (&message (message (format #f (_ "failed to load SSH \
159;; %lsh-command line) 154private key from '~a': ~a")
160;; #f))) 155 file str))))))))
161;; (begin 156
162;; (warning (_ "failed to initiate SSH connection to '~a':\ 157(define (open-ssh-session machine)
163;; '~a' exited with ~a~%") 158 "Open an SSH session for MACHINE and return it. Throw an error on failure."
164;; (build-machine-name machine) 159 (let ((private (private-key-from-file* (build-machine-private-key machine)))
165;; %lsh-command 160 (public (public-key-from-file
166;; (status:exit-val status)) 161 (string-append (build-machine-private-key machine)
167;; #f)))) 162 ".pub")))
168;; (lambda args 163 (session (make-session #:user (build-machine-user machine)
169;; (leave (_ "failed to execute '~a': ~a~%") 164 #:host (build-machine-name machine)
170;; %lsh-command (strerror (system-error-errno args)))))) 165 #:port (build-machine-port machine)
171 166 #:timeout 5 ;seconds
172(define-syntax with-error-to-port 167 ;; #:log-verbosity 'protocol
173 (syntax-rules () 168 #:identity (build-machine-private-key machine)
174 ((_ port exp0 exp ...) 169
175 (let ((new port) 170 ;; We need lightweight compression when
176 (old (current-error-port))) 171 ;; exchanging full archives.
177 (dynamic-wind 172 #:compression "zlib"
178 (lambda () 173 #:compression-level 3)))
179 (set-current-error-port new)) 174 (connect! session)
180 (lambda () 175
181 exp0 exp ...) 176 ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about
182 (lambda () 177 ;; ed25519 keys and 'get-key-type' returns #f in that case.
183 (set-current-error-port old))))))) 178 (let-values (((server) (get-server-public-key session))
184 179 ((type key) (host-key->type+key
185(define* (remote-pipe machine mode command 180 (build-machine-host-key machine))))
186 #:key (error-port (current-error-port)) (quote? #t)) 181 (unless (and (or (not (get-key-type server))
187 "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been 182 (eq? (get-key-type server) type))
188set up. When QUOTE? is true, perform shell-quotation of all the elements of 183 (string=? (public-key->string server) key))
189COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could 184 ;; Key mismatch: something's wrong. XXX: It could be that the server
190not be started." 185 ;; provided its Ed25519 key when we where expecting its RSA key.
186 (leave (_ "server at '~a' returned host key '~a' of type '~a' \
187instead of '~a' of type '~a'~%")
188 (build-machine-name machine)
189 (public-key->string server) (get-key-type server)
190 key type)))
191
192 (let ((auth (userauth-public-key! session private)))
193 (unless (eq? 'success auth)
194 (disconnect! session)
195 (leave (_ "SSH public key authentication failed for '~a': ~a~%")
196 (build-machine-name machine) (get-error session))))
197
198 session))
199
200(define* (remote-pipe machine command
201 #:key (quote? #t))
202 "Run COMMAND (a list) on MACHINE, and return an open input/output port,
203which is also an SSH channel. When QUOTE? is true, perform shell-quotation of
204all the elements of COMMAND."
191 (define (shell-quote str) 205 (define (shell-quote str)
192 ;; Sort-of shell-quote STR so it can be passed as an argument to the 206 ;; Sort-of shell-quote STR so it can be passed as an argument to the
193 ;; shell. 207 ;; shell.
@@ -195,20 +209,15 @@ not be started."
195 (lambda () 209 (lambda ()
196 (write str)))) 210 (write str))))
197 211
198 ;; Let the child inherit ERROR-PORT. 212 ;; TODO: Use (ssh popen) instead.
199 (with-error-to-port error-port 213 (let* ((session (open-ssh-session machine))
200 (apply open-pipe* mode %lshg-command 214 (channel (make-channel session)))
201 "-l" (build-machine-user machine) 215 (channel-open-session channel)
202 "-p" (number->string (build-machine-port machine)) 216 (channel-request-exec channel
203 217 (string-join (if quote?
204 ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. 218 (map shell-quote command)
205 "-i" (build-machine-private-key machine) 219 command)))
206 220 channel))
207 (append (build-machine-ssh-options machine)
208 (list (build-machine-name machine))
209 (if quote?
210 (map shell-quote command)
211 command)))))
212 221
213 222
214;;; 223;;;
@@ -335,10 +344,11 @@ hook."
335 (unless (= EEXIST (system-error-errno args)) 344 (unless (= EEXIST (system-error-errno args))
336 (apply throw args))))))) 345 (apply throw args)))))))
337 346
338 (let ((pipe (remote-pipe machine OPEN_READ 347 (let ((pipe (remote-pipe machine
339 `("guile" "-c" ,(object->string script))))) 348 `("guile" "-c" ,(object->string script)))))
340 (read-string pipe) 349 (read-string pipe)
341 (let ((status (close-pipe pipe))) 350 (let ((status (channel-get-exit-status pipe)))
351 (close-port pipe)
342 (unless (zero? status) 352 (unless (zero? status)
343 ;; Better be safe than sorry: if we ignore the error here, then FILE 353 ;; Better be safe than sorry: if we ignore the error here, then FILE
344 ;; may be GC'd just before we start using it. 354 ;; may be GC'd just before we start using it.
@@ -367,10 +377,10 @@ hook."
367 (false-if-exception (delete-file file))) 377 (false-if-exception (delete-file file)))
368 roots))))) 378 roots)))))
369 379
370 (let ((pipe (remote-pipe machine OPEN_READ 380 (let ((pipe (remote-pipe machine
371 `("guile" "-c" ,(object->string script))))) 381 `("guile" "-c" ,(object->string script)))))
372 (read-string pipe) 382 (read-string pipe)
373 (close-pipe pipe))) 383 (close-port pipe)))
374 384
375(define* (offload drv machine 385(define* (offload drv machine
376 #:key print-build-trace? (max-silent-time 3600) 386 #:key print-build-trace? (max-silent-time 3600)
@@ -384,7 +394,7 @@ there, and write the build log to LOG-PORT. Return the exit status."
384 394
385 ;; Normally DRV has already been protected from GC when it was transferred. 395 ;; Normally DRV has already been protected from GC when it was transferred.
386 ;; The '-r' flag below prevents the build result from being GC'd. 396 ;; The '-r' flag below prevents the build result from being GC'd.
387 (let ((pipe (remote-pipe machine OPEN_READ 397 (let ((pipe (remote-pipe machine
388 `("guix" "build" 398 `("guix" "build"
389 "-r" ,%gc-root-file 399 "-r" ,%gc-root-file
390 ,(format #f "--max-silent-time=~a" 400 ,(format #f "--max-silent-time=~a"
@@ -397,14 +407,20 @@ there, and write the build log to LOG-PORT. Return the exit status."
397 407
398 ;; Since 'guix build' writes the build log to its 408 ;; Since 'guix build' writes the build log to its
399 ;; stderr, everything will go directly to LOG-PORT. 409 ;; stderr, everything will go directly to LOG-PORT.
400 #:error-port log-port))) 410 ;; #:error-port log-port ;; FIXME
411 )))
412 ;; Make standard error visible.
413 (channel-set-stream! pipe 'stderr)
414
401 (let loop ((line (read-line pipe))) 415 (let loop ((line (read-line pipe)))
402 (unless (eof-object? line) 416 (unless (eof-object? line)
403 (display line log-port) 417 (display line log-port)
404 (newline log-port) 418 (newline log-port)
405 (loop (read-line pipe)))) 419 (loop (read-line pipe))))
406 420
407 (close-pipe pipe))) 421 (let loop ((status (channel-get-exit-status pipe)))
422 (close-port pipe)
423 status)))
408 424
409(define* (transfer-and-offload drv machine 425(define* (transfer-and-offload drv machine
410 #:key 426 #:key
@@ -438,7 +454,7 @@ MACHINE."
438with exit code ~a~%" 454with exit code ~a~%"
439 (derivation-file-name drv) 455 (derivation-file-name drv)
440 (build-machine-name machine) 456 (build-machine-name machine)
441 (status:exit-val status)) 457 status)
442 458
443 ;; Use exit code 100 for a permanent build failure. The daemon 459 ;; Use exit code 100 for a permanent build failure. The daemon
444 ;; interprets other non-zero codes as transient build failures. 460 ;; interprets other non-zero codes as transient build failures.
@@ -448,24 +464,14 @@ with exit code ~a~%"
448 "Send the subset of FILES that's missing to MACHINE's store. Return #t on 464 "Send the subset of FILES that's missing to MACHINE's store. Return #t on
449success, #f otherwise." 465success, #f otherwise."
450 (define (missing-files files) 466 (define (missing-files files)
451 ;; Return the subset of FILES not already on MACHINE. 467 ;; Return the subset of FILES not already on MACHINE. Use 'head' as a
452 (let*-values (((files) 468 ;; hack to make sure the remote end stops reading when we're done.
453 (format #f "~{~a~%~}" files)) 469 (let* ((pipe (remote-pipe machine
454 ((missing pids) 470 `("guix" "archive" "--missing")
455 (filtered-port 471 #:quote? #f)))
456 (append (list (which %lshg-command) 472 (format pipe "~{~a~%~}" files)
457 "-l" (build-machine-user machine) 473 (channel-send-eof pipe)
458 "-p" (number->string 474 (string-tokenize (read-string pipe))))
459 (build-machine-port machine))
460 "-i" (build-machine-private-key machine))
461 (build-machine-ssh-options machine)
462 (cons (build-machine-name machine)
463 '("guix" "archive" "--missing")))
464 (open-input-string files)))
465 ((result)
466 (read-string missing)))
467 (for-each waitpid pids)
468 (string-tokenize result)))
469 475
470 (with-store store 476 (with-store store
471 (guard (c ((nix-protocol-error? c) 477 (guard (c ((nix-protocol-error? c)
@@ -476,40 +482,28 @@ success, #f otherwise."
476 482
477 ;; Compute the subset of FILES missing on MACHINE, and send them in 483 ;; Compute the subset of FILES missing on MACHINE, and send them in
478 ;; topologically sorted order so that they can actually be imported. 484 ;; topologically sorted order so that they can actually be imported.
479 ;;
480 ;; To reduce load on the machine that's offloading (since it's typically
481 ;; already quite busy, see hydra.gnu.org), compress with gzip rather
482 ;; than xz: For a compression ratio 2 times larger, it is 20 times
483 ;; faster.
484 (let* ((files (missing-files (topologically-sorted store files))) 485 (let* ((files (missing-files (topologically-sorted store files)))
485 (pipe (remote-pipe machine OPEN_WRITE 486 (pipe (remote-pipe machine
486 '("gzip" "-dc" "|" 487 '("guix" "archive" "--import")
487 "guix" "archive" "--import")
488 #:quote? #f))) 488 #:quote? #f)))
489 (format #t (_ "sending ~a store files to '~a'...~%") 489 (format #t (_ "sending ~a store files to '~a'...~%")
490 (length files) (build-machine-name machine)) 490 (length files) (build-machine-name machine))
491 (call-with-compressed-output-port 'gzip pipe 491
492 (lambda (compressed) 492 (export-paths store files pipe)
493 (catch 'system-error 493 (channel-send-eof pipe)
494 (lambda () 494
495 (export-paths store files compressed)) 495 ;; Wait for the remote process to complete.
496 (lambda args 496 (let ((status (channel-get-exit-status pipe)))
497 (warning (_ "failed while exporting files to '~a': ~a~%") 497 (close pipe)
498 (build-machine-name machine) 498 status)))))
499 (strerror (system-error-errno args))))))
500 #:options '("--fast"))
501
502 ;; Wait for the 'lsh' process to complete.
503 (zero? (close-pipe pipe))))))
504 499
505(define (retrieve-files files machine) 500(define (retrieve-files files machine)
506 "Retrieve FILES from MACHINE's store, and import them." 501 "Retrieve FILES from MACHINE's store, and import them."
507 (define host 502 (define host
508 (build-machine-name machine)) 503 (build-machine-name machine))
509 504
510 (let ((pipe (remote-pipe machine OPEN_READ 505 (let ((pipe (remote-pipe machine
511 `("guix" "archive" "--export" ,@files 506 `("guix" "archive" "--export" ,@files)
512 "|" "xz" "-c")
513 #:quote? #f))) 507 #:quote? #f)))
514 (and pipe 508 (and pipe
515 (with-store store 509 (with-store store
@@ -522,14 +516,11 @@ success, #f otherwise."
522 516
523 ;; We cannot use the 'import-paths' RPC here because we already 517 ;; We cannot use the 'import-paths' RPC here because we already
524 ;; hold the locks for FILES. 518 ;; hold the locks for FILES.
525 (call-with-decompressed-port 'xz pipe 519 (restore-file-set pipe
526 (lambda (decompressed) 520 #:log-port (current-error-port)
527 (restore-file-set decompressed 521 #:lock? #f)
528 #:log-port (current-error-port)
529 #:lock? #f)))
530 522
531 ;; Wait for the 'lsh' process to complete. 523 (close-port pipe))))))
532 (zero? (close-pipe pipe)))))))
533 524
534 525
535;;; 526;;;
@@ -547,13 +538,9 @@ success, #f otherwise."
547(define (machine-load machine) 538(define (machine-load machine)
548 "Return the load of MACHINE, divided by the number of parallel builds 539 "Return the load of MACHINE, divided by the number of parallel builds
549allowed on MACHINE." 540allowed on MACHINE."
550 (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg"))) 541 (let* ((pipe (remote-pipe machine '("cat" "/proc/loadavg")))
551 (line (read-line pipe)) 542 (line (read-line pipe)))
552 (status (close-pipe pipe))) 543 (close-port pipe)
553 (unless (eqv? 0 (status:exit-val status))
554 (warning (_ "failed to obtain load of '~a': SSH client exited with ~a~%")
555 (build-machine-name machine)
556 (status:exit-val status)))
557 544
558 (if (eof-object? line) 545 (if (eof-object? line)
559 +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded 546 +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
diff --git a/m4/guix.m4 b/m4/guix.m4
index 6d8ec2e4e04..6630598416b 100644
--- a/m4/guix.m4
+++ b/m4/guix.m4
@@ -171,6 +171,24 @@ AC_DEFUN([GUIX_CHECK_UNBUFFERED_CBIP], [
171 fi]) 171 fi])
172]) 172])
173 173
174dnl GUIX_CHECK_GUILE_SSH
175dnl
176dnl Check whether a recent-enough Guile-SSH is available.
177AC_DEFUN([GUIX_CHECK_GUILE_SSH], [
178 dnl Check whether 'channel-send-eof' (introduced in 0.10.2) is present.
179 AC_CACHE_CHECK([whether Guile-SSH is available and recent enough],
180 [guix_cv_have_recent_guile_ssh],
181 [GUILE_CHECK([retval],
182 [(and (@ (ssh channel) channel-send-eof)
183 (@ (ssh popen) open-remote-pipe)
184 (@ (ssh dist node) node-eval))])
185 if test "$retval" = 0; then
186 guix_cv_have_recent_guile_ssh="yes"
187 else
188 guix_cv_have_recent_guile_ssh="no"
189 fi])
190])
191
174dnl GUIX_TEST_ROOT_DIRECTORY 192dnl GUIX_TEST_ROOT_DIRECTORY
175AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [ 193AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [
176 AC_CACHE_CHECK([for unit test root directory], 194 AC_CACHE_CHECK([for unit test root directory],