From f3cf860635841f2a17640d9a65e5f389d56470cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Dec 2016 21:48:20 +0100 Subject: offload: Remove redundant call to 'topologically-sorted' in 'send-file'. * guix/scripts/offload.scm (send-files): Remove call to 'topologically-sorted'. --- guix/scripts/offload.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index bc024a8701..1d60f65b16 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -429,10 +429,8 @@ be read." (define (send-files files remote) "Send the subset of FILES that's missing to REMOTE, a remote store." (with-store store - ;; Compute the subset of FILES missing on SESSION, and send them in - ;; topologically sorted order so that they can actually be imported. - (let* ((sorted (topologically-sorted store files)) - (session (channel-get-session (nix-server-socket remote))) + ;; Compute the subset of FILES missing on SESSION and send them. + (let* ((session (channel-get-session (nix-server-socket remote))) (node (make-node session)) (missing (node-eval node `(begin @@ -441,11 +439,12 @@ be read." (with-store store (remove (cut valid-path? store <>) - ',sorted))))) + ',files))))) (port (store-import-channel session))) (format #t (_ "sending ~a store files to '~a'...~%") (length missing) (session-get session 'host)) + ;; Send MISSING in topological order. (export-paths store missing port) ;; Tell the remote process that we're done. (In theory the -- cgit v1.2.3 From 0b72475301e20521e0dd9fc22881eaab4a7fe170 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Dec 2016 21:49:16 +0100 Subject: offload: Warn about the lack of zlib support. * guix/scripts/offload.scm (guix-offload): Print a warning when 'zlib-support?' returns false. --- guix/scripts/offload.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 1d60f65b16..4f6de0b7a6 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -24,6 +24,7 @@ #:use-module (ssh popen) #:use-module (ssh dist) #:use-module (ssh dist node) + #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) #:use-module (guix store) @@ -634,6 +635,12 @@ allowed on MACHINE." (and=> (passwd:dir (getpw (getuid))) (cut setenv "HOME" <>)) + ;; We rely on protocol-level compression from libssh to optimize large data + ;; transfers. Warn if it's missing. + (unless (zlib-support?) + (warning (_ "Guile-SSH lacks zlib support")) + (warning (_ "data transfers will *not* be compressed!"))) + (match args ((system max-silent-time print-build-trace? build-timeout) (let ((max-silent-time (string->number max-silent-time)) -- cgit v1.2.3 From 6374633b9205f60ad0e7ff42bbf39e441ae2f328 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Dec 2016 23:09:34 +0100 Subject: store: Increase buffering for the '%stderr-write' upcall. * guix/store.scm (process-stderr) <%stderr-write>: Pass #:buffer-size to 'dump-port'. --- guix/store.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 689a94c636..a669011f3a 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -470,7 +470,8 @@ encoding conversion errors." ;; Write a byte stream to USER-PORT. (let* ((len (read-int p)) (m (modulo len 8))) - (dump-port p user-port len) + (dump-port p user-port len + #:buffer-size (if (<= len 16384) 16384 65536)) (unless (zero? m) ;; Consume padding, as for strings. (get-bytevector-n p (- 8 m)))) -- cgit v1.2.3 From 74afca5dcfa6f321b5523e9bae8b1aff30e9c6af Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Dec 2016 23:20:18 +0100 Subject: offload: Gracefully report connection failures. * guix/scripts/offload.scm (open-ssh-session): Check the return value of 'connect!'. Call 'leave' when it's not 'ok. --- guix/scripts/offload.scm | 52 ++++++++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 4f6de0b7a6..04983646eb 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -177,31 +177,35 @@ private key from '~a': ~a") ;; exchanging full archives. #:compression "zlib" #:compression-level 3))) - (connect! session) - - ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about - ;; ed25519 keys and 'get-key-type' returns #f in that case. - (let-values (((server) (get-server-public-key session)) - ((type key) (host-key->type+key - (build-machine-host-key machine)))) - (unless (and (or (not (get-key-type server)) - (eq? (get-key-type server) type)) - (string=? (public-key->string server) key)) - ;; Key mismatch: something's wrong. XXX: It could be that the server - ;; provided its Ed25519 key when we where expecting its RSA key. - (leave (_ "server at '~a' returned host key '~a' of type '~a' \ + (match (connect! session) + ('ok + ;; Authenticate the server. XXX: Guile-SSH 0.10.1 doesn't know about + ;; ed25519 keys and 'get-key-type' returns #f in that case. + (let-values (((server) (get-server-public-key session)) + ((type key) (host-key->type+key + (build-machine-host-key machine)))) + (unless (and (or (not (get-key-type server)) + (eq? (get-key-type server) type)) + (string=? (public-key->string server) key)) + ;; Key mismatch: something's wrong. XXX: It could be that the server + ;; provided its Ed25519 key when we where expecting its RSA key. + (leave (_ "server at '~a' returned host key '~a' of type '~a' \ instead of '~a' of type '~a'~%") - (build-machine-name machine) - (public-key->string server) (get-key-type server) - key type))) - - (let ((auth (userauth-public-key! session private))) - (unless (eq? 'success auth) - (disconnect! session) - (leave (_ "SSH public key authentication failed for '~a': ~a~%") - (build-machine-name machine) (get-error session)))) - - session)) + (build-machine-name machine) + (public-key->string server) (get-key-type server) + key type))) + + (let ((auth (userauth-public-key! session private))) + (unless (eq? 'success auth) + (disconnect! session) + (leave (_ "SSH public key authentication failed for '~a': ~a~%") + (build-machine-name machine) (get-error session)))) + + session) + (x + ;; Connection failed or timeout expired. + (leave (_ "failed to connect to '~a': ~a~%") + (build-machine-name machine) (get-error session)))))) (define* (connect-to-remote-daemon session #:optional -- cgit v1.2.3 From 463fb7d0c86fb9957c527272e6cec5ee23585366 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 1 Dec 2016 23:21:15 +0100 Subject: offload: Do not abort when a machine is unreachable. * guix/scripts/offload.scm (machine-load): Wrap 'open-ssh-session' call in 'false-if-exception'; return +inf.0 if it returns #f. --- guix/scripts/offload.scm | 39 +++++++++++++++++++++------------------ 1 file changed, 21 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 04983646eb..237a9638d3 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -493,27 +493,30 @@ be read." (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds -allowed on MACHINE." +allowed on MACHINE. Return +∞ if MACHINE is unreachable." ;; Note: This procedure is costly since it creates a new SSH session. - (let* ((session (open-ssh-session machine)) - (pipe (open-remote-pipe* session OPEN_READ + (match (false-if-exception (open-ssh-session machine)) + ((? session? session) + (let* ((pipe (open-remote-pipe* session OPEN_READ "cat" "/proc/loadavg")) - (line (read-line pipe))) - (close-port pipe) - - (if (eof-object? line) - +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded - (match (string-tokenize line) - ((one five fifteen . _) - (let* ((raw (string->number five)) - (jobs (build-machine-parallel-builds machine)) - (normalized (/ raw jobs))) - (format (current-error-port) "load on machine '~a' is ~s\ + (line (read-line pipe))) + (close-port pipe) + + (if (eof-object? line) + +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded + (match (string-tokenize line) + ((one five fifteen . _) + (let* ((raw (string->number five)) + (jobs (build-machine-parallel-builds machine)) + (normalized (/ raw jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ (normalized: ~s)~%" - (build-machine-name machine) raw normalized) - normalized)) - (_ - +inf.0))))) ;something's fishy about MACHINE, so avoid it + (build-machine-name machine) raw normalized) + normalized)) + (_ + +inf.0))))) ;something's fishy about MACHINE, so avoid it + (_ + +inf.0))) ;failed to connect to MACHINE, so avoid it (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." -- cgit v1.2.3