diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2014-03-02 22:39:48 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2016-11-25 23:44:20 +0100 |
| commit | 21531add3205e400707c8fbfd841845f9a71863a (patch) | |
| tree | 8a88aa7b2fe01f5707bcf130fe09d54c0a95d33f | |
| parent | 6634180f9eabc70cdc5bc8e9ce2ff0f9250625bc (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.ac | 18 | ||||
| -rw-r--r-- | doc/guix.texi | 69 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 279 | ||||
| -rw-r--r-- | m4/guix.m4 | 18 |
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 | |||
| 567 | interest primarily for developers and not for casual users. | 567 | interest 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'. | ||
| 571 | Support for build offloading (@pxref{Daemon Offload Setup}) depends on | ||
| 572 | @uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH}, | ||
| 573 | version 0.10.2 or later. | ||
| 574 | |||
| 575 | @item | ||
| 570 | When @url{http://zlib.net, zlib} is available, @command{guix publish} | 576 | When @url{http://zlib.net, zlib} is available, @command{guix publish} |
| 571 | can compress build byproducts (@pxref{Invoking guix publish}). | 577 | can 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 |
| 817 | When desired, the build daemon can @dfn{offload} | 823 | When desired, the build daemon can @dfn{offload} derivation builds to |
| 818 | derivation builds to other machines | 824 | other machines running Guix, using the @code{offload} @dfn{build |
| 819 | running Guix, using the @code{offload} @dfn{build hook}. When that | 825 | hook}@footnote{This feature is available only when |
| 826 | @uref{https://github.com/artyom-poptsov/guile-ssh, Guile-SSH} is | ||
| 827 | present.}. When that | ||
| 820 | feature is enabled, a list of user-specified build machines is read from | 828 | feature 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 |
| 822 | instance via @code{guix build}, the daemon attempts to offload it to one | 830 | instance 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. | |||
| 875 | Note that the SSH key pair must @emph{not} be passphrase-protected, to | 885 | Note that the SSH key pair must @emph{not} be passphrase-protected, to |
| 876 | allow non-interactive logins. | 886 | allow non-interactive logins. |
| 877 | 887 | ||
| 888 | @item host-key | ||
| 889 | This must be the machine's SSH @dfn{public host key} in OpenSSH format. | ||
| 890 | This is used to authenticate the machine when we connect to it. It is a | ||
| 891 | long string that looks like this: | ||
| 892 | |||
| 893 | @example | ||
| 894 | ssh-ed25519 AAAAC3NzaC@dots{}mde+UhL hint@@example.org | ||
| 895 | @end example | ||
| 896 | |||
| 897 | If the machine is running the OpenSSH daemon, @command{sshd}, the host | ||
| 898 | key can be found in a file such as | ||
| 899 | @file{/etc/ssh/ssh_host_ed25519_key.pub}. | ||
| 900 | |||
| 901 | If 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 | ||
| 903 | similar 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 | ||
| 908 | ssh-rsa AAAAB3NzaC1yc2EAAAAEOp8FoQAAAQEAs1eB46LV@dots{} | ||
| 909 | @end example | ||
| 910 | |||
| 878 | @end table | 911 | @end table |
| 879 | 912 | ||
| 880 | A number of optional fields may be specified: | 913 | A number of optional fields may be specified: |
| 881 | 914 | ||
| 882 | @table @code | 915 | @table @asis |
| 883 | |||
| 884 | @item port | ||
| 885 | Port number of SSH server on the machine (default: 22). | ||
| 886 | 916 | ||
| 887 | @item private-key | 917 | @item @code{port} (default: @code{22}) |
| 888 | The SSH private key file to use when connecting to the machine. | 918 | Port number of SSH server on the machine. |
| 889 | 919 | ||
| 890 | Currently 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 | 921 | The SSH private key file to use when connecting to the machine, in |
| 892 | be an lsh key file. This may change in the future, though. | 922 | OpenSSH format. |
| 893 | 923 | ||
| 894 | @item parallel-builds | 924 | @item @code{parallel-builds} (default: @code{1}) |
| 895 | The number of builds that may run in parallel on the machine (1 by | 925 | The number of builds that may run in parallel on the machine. |
| 896 | default.) | ||
| 897 | 926 | ||
| 898 | @item speed | 927 | @item @code{speed} (default: @code{1.0}) |
| 899 | A ``relative speed factor''. The offload scheduler will tend to prefer | 928 | A ``relative speed factor''. The offload scheduler will tend to prefer |
| 900 | machines with a higher speed factor. | 929 | machines with a higher speed factor. |
| 901 | 930 | ||
| 902 | @item features | 931 | @item @code{features} (default: @code{'()}) |
| 903 | A list of strings denoting specific features supported by the machine. | 932 | A list of strings denoting specific features supported by the machine. |
| 904 | An example is @code{"kvm"} for machines that have the KVM Linux modules | 933 | An example is @code{"kvm"} for machines that have the KVM Linux modules |
| 905 | and corresponding hardware support. Derivations can request features by | 934 | and corresponding hardware support. Derivations can request features by |
| @@ -915,7 +944,7 @@ machines, since offloading works by invoking the @code{guix archive} and | |||
| 915 | this is the case by running: | 944 | this is the case by running: |
| 916 | 945 | ||
| 917 | @example | 946 | @example |
| 918 | lsh build-machine guile -c "'(use-modules (guix config))'" | 947 | ssh build-machine guile -c "'(use-modules (guix config))'" |
| 919 | @end example | 948 | @end example |
| 920 | 949 | ||
| 921 | There is one last thing to do once @file{machines.scm} is in place. As | 950 | There 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 | ||
| 99 | determined." | 94 | determined." |
| 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) | 134 | its 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))) | 147 | can 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) | 154 | private 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)) |
| 188 | set up. When QUOTE? is true, perform shell-quotation of all the elements of | 183 | (string=? (public-key->string server) key)) |
| 189 | COMMAND. 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 |
| 190 | not 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' \ | ||
| 187 | instead 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, | ||
| 203 | which is also an SSH channel. When QUOTE? is true, perform shell-quotation of | ||
| 204 | all 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." | |||
| 438 | with exit code ~a~%" | 454 | with 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 |
| 449 | success, #f otherwise." | 465 | success, #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 |
| 549 | allowed on MACHINE." | 540 | allowed 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 | ||
| 174 | dnl GUIX_CHECK_GUILE_SSH | ||
| 175 | dnl | ||
| 176 | dnl Check whether a recent-enough Guile-SSH is available. | ||
| 177 | AC_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 | |||
| 174 | dnl GUIX_TEST_ROOT_DIRECTORY | 192 | dnl GUIX_TEST_ROOT_DIRECTORY |
| 175 | AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [ | 193 | AC_DEFUN([GUIX_TEST_ROOT_DIRECTORY], [ |
| 176 | AC_CACHE_CHECK([for unit test root directory], | 194 | AC_CACHE_CHECK([for unit test root directory], |
