From 21531add3205e400707c8fbfd841845f9a71863a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 2 Mar 2014 22:39:48 +0100 Subject: offload: Use Guile-SSH instead of GNU lsh. * guix/scripts/offload.scm ()[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. --- guix/scripts/offload.scm | 279 ++++++++++++++++++++++------------------------- 1 file changed, 133 insertions(+), 146 deletions(-) (limited to 'guix/scripts/offload.scm') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 33d141e7e..327c99dfe 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -17,6 +17,10 @@ ;;; along with GNU Guix. If not, see . (define-module (guix scripts offload) + #:use-module (ssh key) + #:use-module (ssh auth) + #:use-module (ssh session) + #:use-module (ssh channel) #:use-module (guix config) #:use-module (guix records) #:use-module (guix store) @@ -65,14 +69,13 @@ (system build-machine-system) ; string (user build-machine-user) ; string (private-key build-machine-private-key ; file name - (default (user-lsh-private-key))) + (default (user-openssh-private-key))) + (host-key build-machine-host-key) ; string (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real (default 1.0)) (features build-machine-features ; list of strings - (default '())) - (ssh-options build-machine-ssh-options ; list of strings (default '()))) (define-record-type* @@ -86,19 +89,11 @@ ;; File that lists machines available as build slaves. (string-append %config-directory "/machines.scm")) -(define %lsh-command - "lsh") - -(define %lshg-command - ;; FIXME: 'lshg' fails to pass large amounts of data, see - ;; . - "lsh") - -(define (user-lsh-private-key) - "Return the user's default lsh private key, or #f if it could not be +(define (user-openssh-private-key) + "Return the user's default SSH private key, or #f if it could not be determined." (and=> (getenv "HOME") - (cut string-append <> "/.lsh/identity"))) + (cut string-append <> "/.ssh/id_rsa"))) (define %user-module ;; Module in which the machine description file is loaded. @@ -134,60 +129,79 @@ determined." (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) -;;; FIXME: The idea was to open the connection to MACHINE once for all, but -;;; lshg is currently non-functional. -;; (define (open-ssh-gateway machine) -;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the -;; running lsh gateway upon success, or #f on failure." -;; (catch 'system-error -;; (lambda () -;; (let* ((port (open-pipe* OPEN_READ %lsh-command -;; "-l" (build-machine-user machine) -;; "-i" (build-machine-private-key machine) -;; ;; XXX: With lsh 2.1, passing '--write-pid' -;; ;; last causes the PID not to be printed. -;; "--write-pid" "--gateway" "--background" -;; (build-machine-name machine))) -;; (line (read-line port)) -;; (status (close-pipe port))) -;; (if (zero? status) -;; (let ((pid (string->number line))) -;; (if (integer? pid) -;; pid -;; (begin -;; (warning (_ "'~a' did not write its PID on stdout: ~s~%") -;; %lsh-command line) -;; #f))) -;; (begin -;; (warning (_ "failed to initiate SSH connection to '~a':\ -;; '~a' exited with ~a~%") -;; (build-machine-name machine) -;; %lsh-command -;; (status:exit-val status)) -;; #f)))) -;; (lambda args -;; (leave (_ "failed to execute '~a': ~a~%") -;; %lsh-command (strerror (system-error-errno args)))))) - -(define-syntax with-error-to-port - (syntax-rules () - ((_ port exp0 exp ...) - (let ((new port) - (old (current-error-port))) - (dynamic-wind - (lambda () - (set-current-error-port new)) - (lambda () - exp0 exp ...) - (lambda () - (set-current-error-port old))))))) - -(define* (remote-pipe machine mode command - #:key (error-port (current-error-port)) (quote? #t)) - "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been -set up. When QUOTE? is true, perform shell-quotation of all the elements of -COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could -not be started." +(define (host-key->type+key host-key) + "Destructure HOST-KEY, an OpenSSH host key string, and return two values: +its key type as a symbol, and the actual base64-encoded string." + (define (type->symbol type) + (and (string-prefix? "ssh-" type) + (string->symbol (string-drop type 4)))) + + (match (string-tokenize host-key) + ((type key _) + (values (type->symbol type) key)) + ((type key) + (values (type->symbol type) key)))) + +(define (private-key-from-file* file) + "Like 'private-key-from-file', but raise an error that 'with-error-handling' +can interpret meaningfully." + (catch 'guile-ssh-error + (lambda () + (private-key-from-file file)) + (lambda (key proc str . rest) + (raise (condition + (&message (message (format #f (_ "failed to load SSH \ +private key from '~a': ~a") + file str)))))))) + +(define (open-ssh-session machine) + "Open an SSH session for MACHINE and return it. Throw an error on failure." + (let ((private (private-key-from-file* (build-machine-private-key machine))) + (public (public-key-from-file + (string-append (build-machine-private-key machine) + ".pub"))) + (session (make-session #:user (build-machine-user machine) + #:host (build-machine-name machine) + #:port (build-machine-port machine) + #:timeout 5 ;seconds + ;; #:log-verbosity 'protocol + #:identity (build-machine-private-key machine) + + ;; We need lightweight compression when + ;; 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' \ +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)) + +(define* (remote-pipe machine command + #:key (quote? #t)) + "Run COMMAND (a list) on MACHINE, 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) ;; Sort-of shell-quote STR so it can be passed as an argument to the ;; shell. @@ -195,20 +209,15 @@ not be started." (lambda () (write str)))) - ;; Let the child inherit ERROR-PORT. - (with-error-to-port error-port - (apply open-pipe* mode %lshg-command - "-l" (build-machine-user machine) - "-p" (number->string (build-machine-port machine)) - - ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg. - "-i" (build-machine-private-key machine) - - (append (build-machine-ssh-options machine) - (list (build-machine-name machine)) - (if quote? - (map shell-quote command) - command))))) + ;; TODO: Use (ssh popen) instead. + (let* ((session (open-ssh-session machine)) + (channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec channel + (string-join (if quote? + (map shell-quote command) + command))) + channel)) ;;; @@ -335,10 +344,11 @@ hook." (unless (= EEXIST (system-error-errno args)) (apply throw args))))))) - (let ((pipe (remote-pipe machine OPEN_READ + (let ((pipe (remote-pipe machine `("guile" "-c" ,(object->string script))))) (read-string pipe) - (let ((status (close-pipe pipe))) + (let ((status (channel-get-exit-status pipe))) + (close-port pipe) (unless (zero? status) ;; Better be safe than sorry: if we ignore the error here, then FILE ;; may be GC'd just before we start using it. @@ -367,10 +377,10 @@ hook." (false-if-exception (delete-file file))) roots))))) - (let ((pipe (remote-pipe machine OPEN_READ + (let ((pipe (remote-pipe machine `("guile" "-c" ,(object->string script))))) (read-string pipe) - (close-pipe pipe))) + (close-port pipe))) (define* (offload drv machine #: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." ;; 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 OPEN_READ + (let ((pipe (remote-pipe machine `("guix" "build" "-r" ,%gc-root-file ,(format #f "--max-silent-time=~a" @@ -397,14 +407,20 @@ there, and write the build log to LOG-PORT. Return the exit status." ;; Since 'guix build' writes the build log to its ;; stderr, everything will go directly to LOG-PORT. - #:error-port log-port))) + ;; #:error-port log-port ;; FIXME + ))) + ;; Make standard error visible. + (channel-set-stream! pipe 'stderr) + (let loop ((line (read-line pipe))) (unless (eof-object? line) (display line log-port) (newline log-port) (loop (read-line pipe)))) - (close-pipe pipe))) + (let loop ((status (channel-get-exit-status pipe))) + (close-port pipe) + status))) (define* (transfer-and-offload drv machine #:key @@ -438,7 +454,7 @@ MACHINE." with exit code ~a~%" (derivation-file-name drv) (build-machine-name machine) - (status:exit-val status)) + status) ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. @@ -448,24 +464,14 @@ with exit code ~a~%" "Send the subset of FILES that's missing to MACHINE's store. Return #t on success, #f otherwise." (define (missing-files files) - ;; Return the subset of FILES not already on MACHINE. - (let*-values (((files) - (format #f "~{~a~%~}" files)) - ((missing pids) - (filtered-port - (append (list (which %lshg-command) - "-l" (build-machine-user machine) - "-p" (number->string - (build-machine-port machine)) - "-i" (build-machine-private-key machine)) - (build-machine-ssh-options machine) - (cons (build-machine-name machine) - '("guix" "archive" "--missing"))) - (open-input-string files))) - ((result) - (read-string missing))) - (for-each waitpid pids) - (string-tokenize result))) + ;; Return the subset of FILES not already on MACHINE. Use 'head' as a + ;; hack to make sure the remote end stops reading when we're done. + (let* ((pipe (remote-pipe machine + `("guix" "archive" "--missing") + #:quote? #f))) + (format pipe "~{~a~%~}" files) + (channel-send-eof pipe) + (string-tokenize (read-string pipe)))) (with-store store (guard (c ((nix-protocol-error? c) @@ -476,40 +482,28 @@ success, #f otherwise." ;; Compute the subset of FILES missing on MACHINE, and send them in ;; topologically sorted order so that they can actually be imported. - ;; - ;; To reduce load on the machine that's offloading (since it's typically - ;; already quite busy, see hydra.gnu.org), compress with gzip rather - ;; than xz: For a compression ratio 2 times larger, it is 20 times - ;; faster. (let* ((files (missing-files (topologically-sorted store files))) - (pipe (remote-pipe machine OPEN_WRITE - '("gzip" "-dc" "|" - "guix" "archive" "--import") + (pipe (remote-pipe machine + '("guix" "archive" "--import") #:quote? #f))) (format #t (_ "sending ~a store files to '~a'...~%") (length files) (build-machine-name machine)) - (call-with-compressed-output-port 'gzip pipe - (lambda (compressed) - (catch 'system-error - (lambda () - (export-paths store files compressed)) - (lambda args - (warning (_ "failed while exporting files to '~a': ~a~%") - (build-machine-name machine) - (strerror (system-error-errno args)))))) - #:options '("--fast")) - - ;; Wait for the 'lsh' process to complete. - (zero? (close-pipe pipe)))))) + + (export-paths store files pipe) + (channel-send-eof pipe) + + ;; Wait for the remote process to complete. + (let ((status (channel-get-exit-status pipe))) + (close pipe) + status))))) (define (retrieve-files files machine) "Retrieve FILES from MACHINE's store, and import them." (define host (build-machine-name machine)) - (let ((pipe (remote-pipe machine OPEN_READ - `("guix" "archive" "--export" ,@files - "|" "xz" "-c") + (let ((pipe (remote-pipe machine + `("guix" "archive" "--export" ,@files) #:quote? #f))) (and pipe (with-store store @@ -522,14 +516,11 @@ success, #f otherwise." ;; We cannot use the 'import-paths' RPC here because we already ;; hold the locks for FILES. - (call-with-decompressed-port 'xz pipe - (lambda (decompressed) - (restore-file-set decompressed - #:log-port (current-error-port) - #:lock? #f))) + (restore-file-set pipe + #:log-port (current-error-port) + #:lock? #f) - ;; Wait for the 'lsh' process to complete. - (zero? (close-pipe pipe))))))) + (close-port pipe)))))) ;;; @@ -547,13 +538,9 @@ success, #f otherwise." (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." - (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg"))) - (line (read-line pipe)) - (status (close-pipe pipe))) - (unless (eqv? 0 (status:exit-val status)) - (warning (_ "failed to obtain load of '~a': SSH client exited with ~a~%") - (build-machine-name machine) - (status:exit-val status))) + (let* ((pipe (remote-pipe machine '("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 -- cgit v1.3 From 9e76eed37fc4cb0f70c1cc1441dfba92b25c33eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 2 Nov 2016 12:00:47 +0100 Subject: 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'. --- guix/scripts/offload.scm | 84 +++++++++++++++++++++++++----------------------- 1 file changed, 43 insertions(+), 41 deletions(-) (limited to 'guix/scripts/offload.scm') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 327c99dfe..8704743a7 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -197,9 +197,9 @@ instead of '~a' of type '~a'~%") 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 @@ all the elements of COMMAND." (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 @@ hook." ;; 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 @@ hook." (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 @@ hook." ;; 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 @@ hook." (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 @@ 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 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 @@ with exit code ~a~%" ;; 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 @@ success, #f otherwise." (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 @@ success, #f otherwise." (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,8 +539,9 @@ success, #f otherwise." (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"))) - (line (read-line pipe))) + (let* ((session (open-ssh-session machine)) + (pipe (remote-pipe session '("cat" "/proc/loadavg"))) + (line (read-line pipe))) (close-port pipe) (if (eof-object? line) -- cgit v1.3 From e8a5db80d5fe2e603d7b72c3b3cc5ba6ea6d99d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Nov 2016 00:46:04 +0100 Subject: offload: Remove 'with-nar-error-handling' macro. * guix/scripts/offload.scm (with-nar-error-handling): Remove. (guix-offload): Use 'with-error-handling' instead. --- guix/scripts/offload.scm | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) (limited to 'guix/scripts/offload.scm') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 8704743a7..35286ab9d 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -664,17 +664,6 @@ defines a total order on machines.)" ;; Not now, all the machines are busy. (display "# postpone\n"))))))) -(define-syntax-rule (with-nar-error-handling body ...) - "Execute BODY with any &nar-error suitably reported to the user." - (guard (c ((nar-error? c) - (let ((file (nar-error-file c))) - (if (condition-has-type? c &message) - (leave (_ "while importing file '~a': ~a~%") - file (gettext (condition-message c))) - (leave (_ "failed to import file '~a'~%") - file))))) - body ...)) - ;;; ;;; Entry point. @@ -705,7 +694,7 @@ defines a total order on machines.)" (cond ((regexp-exec request-line-rx line) => (lambda (match) - (with-nar-error-handling + (with-error-handling (process-request (equal? (match:substring match 1) "1") (match:substring match 2) ; system (call-with-input-file -- cgit v1.3 From cf283dd92eb5ef2dee4b761bb23f6dca2525cd55 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Nov 2016 00:47:34 +0100 Subject: offload: Rewrite to make direct RPCs to the remote daemon. * guix/scripts/offload.scm ()[daemon-socket]: New field. (connect-to-remote-daemon): New procedure. (%gc-root-file, register-gc-root, remove-gc-roots, offload): Remove. (transfer-and-offload): Rewrite using 'connect-to-remote-daemon' and RPCs over SSH. (store-import-channel, store-export-channel): New procedures. (send-files, retrieve-files): Rewrite using these. --- doc/guix.texi | 4 + guix/scripts/offload.scm | 371 ++++++++++++++++++++++------------------------- 2 files changed, 175 insertions(+), 200 deletions(-) (limited to 'guix/scripts/offload.scm') diff --git a/doc/guix.texi b/doc/guix.texi index f1cb007aa..b8e37055e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -921,6 +921,10 @@ Port number of SSH server on the machine. The SSH private key file to use when connecting to the machine, in OpenSSH format. +@item @code{daemon-socket} (default: @code{"/var/guix/daemon-socket/socket"}) +File name of the Unix-domain socket @command{guix-daemon} is listening +to on that machine. + @item @code{parallel-builds} (default: @code{1}) The number of builds that may run in parallel on the machine. diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 35286ab9d..1821bb5b7 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -21,6 +21,9 @@ #:use-module (ssh auth) #:use-module (ssh session) #:use-module (ssh channel) + #:use-module (ssh popen) + #:use-module (ssh dist) + #:use-module (ssh dist node) #:use-module (guix config) #:use-module (guix records) #:use-module (guix store) @@ -71,6 +74,8 @@ (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) (host-key build-machine-host-key) ; string + (daemon-socket build-machine-daemon-socket ; string + (default "/var/guix/daemon-socket/socket")) (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real @@ -197,6 +202,53 @@ instead of '~a' of type '~a'~%") session)) +(define* (connect-to-remote-daemon session + #:optional + (socket-name "/var/guix/daemon-socket/socket")) + "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, +an SSH session. Return a object." + (define redirect + ;; Code run in SESSION to redirect the remote process' stdin/stdout to the + ;; daemon's socket, à la socat. The SSH protocol supports forwarding to + ;; Unix-domain sockets but libssh doesn't have an API for that, hence this + ;; hack. + `(begin + (use-modules (ice-9 match) (rnrs io ports)) + + (let ((sock (socket AF_UNIX SOCK_STREAM 0)) + (stdin (current-input-port)) + (stdout (current-output-port))) + (setvbuf stdin _IONBF) + (setvbuf stdout _IONBF) + (connect sock AF_UNIX ,socket-name) + + (let loop () + (match (select (list stdin sock) '() (list stdin stdout sock)) + ((reads writes ()) + (when (memq stdin reads) + (match (get-bytevector-some stdin) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector sock bv)))) + (when (memq sock reads) + (match (get-bytevector-some sock) + ((? eof-object?) + (primitive-exit 0)) + (bv + (put-bytevector stdout bv)))) + (loop)) + (_ + (primitive-exit 1))))))) + + (let ((channel + (open-remote-pipe* session OPEN_BOTH + ;; Sort-of shell-quote REDIRECT. + "guile" "-c" + (object->string + (object->string redirect))))) + (open-connection #:port channel))) + (define* (remote-pipe session command #:key (quote? #t)) "Run COMMAND (a list) on SESSION, and return an open input/output port, @@ -306,116 +358,6 @@ hook." (set-port-revealed! port 1) port)) -(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 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)) - - ;; Note: we can't use 'add-indirect-root' because dangling links under - ;; gcroots/auto are automatically deleted by the GC. This strategy - ;; doesn't have this problem, but it requires write access to that - ;; directory. - (let ((root-directory (string-append %state-directory - "/gcroots/tmp"))) - (catch 'system-error - (lambda () - (mkdir root-directory)) - (lambda args - (unless (= EEXIST (system-error-errno args)) - (error "failed to create remote GC root directory" - root-directory (system-error-errno args))))) - - (catch 'system-error - (lambda () - (symlink ,file - (string-append root-directory "/" ,%gc-root-file))) - (lambda args - ;; If FILE already exists, we can assume that either it's a stale - ;; reference (which is fine), or another process is already - ;; building the derivation represented by FILE (which is fine - ;; too.) Thus, do nothing in that case. - (unless (= EEXIST (system-error-errno args)) - (apply throw args))))))) - - (let ((pipe (remote-pipe session - `("guile" "-c" ,(object->string script))))) - (read-string pipe) - (let ((status (channel-get-exit-status pipe))) - (close-port pipe) - (unless (zero? status) - ;; 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 (session-get session 'host) status))))) - -(define (remove-gc-roots session) - "Remove in SESSION the GC roots previously installed with -'register-gc-root'." - (define script - `(begin - (use-modules (guix config) (ice-9 ftw) - (srfi srfi-1) (srfi srfi-26)) - - (let ((root-directory (string-append %state-directory - "/gcroots/tmp"))) - (false-if-exception - (delete-file - (string-append root-directory "/" ,%gc-root-file))) - - ;; These ones were created with 'guix build -r' (there can be more - ;; than one in case of multiple-output derivations.) - (let ((roots (filter (cut string-prefix? ,%gc-root-file <>) - (scandir ".")))) - (for-each (lambda (file) - (false-if-exception (delete-file file))) - roots))))) - - (let ((pipe (remote-pipe session - `("guile" "-c" ,(object->string script))))) - (read-string pipe) - (close-port pipe))) - -(define* (offload drv session - #:key print-build-trace? (max-silent-time 3600) - build-timeout (log-port (build-log-port))) - "Perform DRV in SESSION, assuming DRV and its prerequisites are available -there, and write the build log to LOG-PORT. Return the exit status." - ;; 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 session - `("guix" "build" - "-r" ,%gc-root-file - ,(format #f "--max-silent-time=~a" - max-silent-time) - ,@(if build-timeout - (list (format #f "--timeout=~a" - build-timeout)) - '()) - ,(derivation-file-name drv)) - - ;; Since 'guix build' writes the build log to its - ;; stderr, everything will go directly to LOG-PORT. - ;; #:error-port log-port ;; FIXME - ))) - ;; Make standard error visible. - (channel-set-stream! pipe 'stderr) - - (let loop ((line (read-line pipe))) - (unless (eof-object? line) - (display line log-port) - (newline log-port) - (loop (read-line pipe)))) - - (let loop ((status (channel-get-exit-status pipe))) - (close-port pipe) - status))) - (define* (transfer-and-offload drv machine #:key (inputs '()) @@ -429,99 +371,128 @@ MACHINE." (define session (open-ssh-session machine)) - (when (begin - (register-gc-root (derivation-file-name drv) session) - (send-files (cons (derivation-file-name drv) inputs) - 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 session) - (remove-gc-roots session) - (format (current-error-port) - "done with offloaded '~a'~%" - (derivation-file-name drv))) - (begin - (remove-gc-roots session) - (format (current-error-port) - "derivation '~a' offloaded to '~a' failed \ -with exit code ~a~%" - (derivation-file-name drv) - (build-machine-name machine) - status) - - ;; Use exit code 100 for a permanent build failure. The daemon - ;; interprets other non-zero codes as transient build failures. - (primitive-exit 100)))))) - -(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 SESSION. Use 'head' as a - ;; hack to make sure the remote end stops reading when we're done. - (let* ((pipe (remote-pipe session - `("guix" "archive" "--missing") - #:quote? #f))) - (format pipe "~{~a~%~}" files) - (channel-send-eof pipe) - (string-tokenize (read-string pipe)))) + (define store + (connect-to-remote-daemon session + (build-machine-daemon-socket machine))) + + (set-build-options store + #:print-build-trace print-build-trace? + #:max-silent-time max-silent-time + #:timeout build-timeout) + + ;; Protect DRV from garbage collection. + (add-temp-root store (derivation-file-name drv)) + + (send-files (cons (derivation-file-name drv) inputs) + store) + (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)) + + (guard (c ((nix-protocol-error? c) + (format (current-error-port) + (_ "derivation '~a' offloaded to '~a' failed: ~a~%") + (derivation-file-name drv) + (build-machine-name machine) + (nix-protocol-error-message c)) + ;; Use exit code 100 for a permanent build failure. The daemon + ;; interprets other non-zero codes as transient build failures. + (primitive-exit 100))) + (build-derivations store (list drv))) + + (retrieve-files outputs store) + (format (current-error-port) "done with offloaded '~a'~%" + (derivation-file-name drv))) + +(define (store-import-channel session) + "Return an output port to which archives to be exported to SESSION's store +can be written." + ;; Using the 'import-paths' RPC on a remote store would be slow because it + ;; makes a round trip every time 32 KiB have been transferred. This + ;; procedure instead opens a separate channel to use the remote + ;; 'import-paths' procedure, which consumes all the data in a single round + ;; trip. + (define import + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-input-port) _IONBF) + (import-paths store (current-input-port))))) + + (open-remote-output-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string import)))))) + +(define (store-export-channel session files) + "Return an input port from which an export of FILES from SESSION's store can +be read." + ;; Same as above: this is more efficient than calling 'export-paths' on a + ;; remote store. + (define export + `(begin + (use-modules (guix)) + + (with-store store + (setvbuf (current-output-port) _IONBF) + (export-paths store ',files (current-output-port))))) + + (open-remote-input-pipe session + (string-join + `("guile" "-c" + ,(object->string + (object->string export)))))) +(define (send-files files remote) + "Send the subset of FILES that's missing to REMOTE, a remote store." (with-store store - (guard (c ((nix-protocol-error? c) - (warning (_ "failed to export files for '~a': ~s~%") - (session-get session 'host) c) - #f)) - - ;; 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 session - '("guix" "archive" "--import") - #:quote? #f))) - (format #t (_ "sending ~a store files to '~a'...~%") - (length files) (session-get session 'host)) - - (export-paths store files pipe) - (channel-send-eof pipe) - - ;; Wait for the remote process to complete. - (let ((status (channel-get-exit-status pipe))) - (close pipe) - status))))) - -(define (retrieve-files files session) + ;; 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))) + (node (make-node session)) + (missing (node-eval node + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',sorted))))) + (port (store-import-channel session))) + (format #t (_ "sending ~a store files to '~a'...~%") + (length missing) (session-get session 'host)) + + (export-paths store missing port) + + ;; Tell the remote process that we're done. (In theory the + ;; end-of-archive mark of 'export-paths' would be enough, but in + ;; practice it's not.) + (channel-send-eof port) + + ;; Wait for completion of the remote process. + (let ((result (zero? (channel-get-exit-status port)))) + (close-port port) + result)))) + +(define (retrieve-files files remote) "Retrieve FILES from SESSION's store, and import them." - (define host - (session-get session 'host)) - - (let ((pipe (remote-pipe session - `("guix" "archive" "--export" ,@files) - #:quote? #f))) - (and pipe - (with-store store - (guard (c ((nix-protocol-error? c) - (warning (_ "failed to import files from '~a': ~s~%") - host c) - #f)) - (format (current-error-port) "retrieving ~a files from '~a'...~%" - (length files) host) - - ;; We cannot use the 'import-paths' RPC here because we already - ;; hold the locks for FILES. - (restore-file-set pipe - #:log-port (current-error-port) - #:lock? #f) - - (close-port pipe)))))) + (let* ((session (channel-get-session (nix-server-socket remote))) + (host (session-get session 'host)) + (port (store-export-channel session files))) + (format #t (_ "retrieving ~a files from '~a'...~%") + (length files) host) + + ;; We cannot use the 'import-paths' RPC here because we already + ;; hold the locks for FILES. + (let ((result (restore-file-set port + #:log-port (current-error-port) + #:lock? #f))) + (close-port port) + result))) ;;; -- cgit v1.3 From bc1ad4e334fbf5239ed8d617751e9fa7dbe0ab23 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Nov 2016 22:47:37 +0100 Subject: offload: Drop 'remote-pipe'. * guix/scripts/offload.scm (remote-pipe): Remove. (machine-load): Use 'open-remote-pipe*' instead of 'remote-pipe'. --- guix/scripts/offload.scm | 23 ++--------------------- 1 file changed, 2 insertions(+), 21 deletions(-) (limited to 'guix/scripts/offload.scm') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 1821bb5b7..2e0268020 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -249,26 +249,6 @@ an SSH session. Return a object." (object->string redirect))))) (open-connection #:port channel))) -(define* (remote-pipe session command - #:key (quote? #t)) - "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) - ;; Sort-of shell-quote STR so it can be passed as an argument to the - ;; shell. - (with-output-to-string - (lambda () - (write str)))) - - (let* ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec channel - (string-join (if quote? - (map shell-quote command) - command))) - channel)) - ;;; ;;; Synchronization. @@ -511,7 +491,8 @@ be read." "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." (let* ((session (open-ssh-session machine)) - (pipe (remote-pipe session '("cat" "/proc/loadavg"))) + (pipe (open-remote-pipe* session OPEN_READ + "cat" "/proc/loadavg")) (line (read-line pipe))) (close-port pipe) -- cgit v1.3 From 1cd1d8a7ea43bfb99aa05c74da5430bb3d8a4309 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 26 Nov 2016 23:00:36 +0100 Subject: offload: Call 'machine-load' only once per machine. This fixes a longstanding issue where 'choose-build-machine' would make on average O(N log(N)) calls to 'machine-load', plus an extra call for the selected machine, instead of N calls. * guix/scripts/offload.scm (machine-load): Add comment. (machine-power-factor, machine-less-loaded-or-faster?): Remove. (choose-build-machine)[machines+slots]: Rename to... [machines+slots+loads]: ... this. [undecorate]: Adjust accordingly. [machine-less-loaded-or-faster?]: New procedure. Remove extra 'machine-load' call in body. --- guix/scripts/offload.scm | 46 +++++++++++++++++++++++----------------------- 1 file changed, 23 insertions(+), 23 deletions(-) (limited to 'guix/scripts/offload.scm') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 2e0268020..bc024a870 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -490,6 +490,7 @@ be read." (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." + ;; 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 "cat" "/proc/loadavg")) @@ -510,17 +511,6 @@ allowed on MACHINE." (_ +inf.0))))) ;something's fishy about MACHINE, so avoid it -(define (machine-power-factor m) - "Return a factor that aggregates the speed and load of M. The higher the -better." - (/ (build-machine-speed m) - (+ 1 (machine-load m)))) - -(define (machine-less-loaded-or-faster? m1 m2) - "Return #t if M1 is either less loaded or faster than M2. (This relation -defines a total order on machines.)" - (> (machine-power-factor m1) (machine-power-factor m2))) - (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." (string-append %state-directory "/offload/" @@ -548,29 +538,39 @@ defines a total order on machines.)" ;; 5. Release the global machine-choice lock. (with-file-lock (machine-choice-lock-file) - (define machines+slots + (define machines+slots+loads (filter-map (lambda (machine) + ;; Call 'machine-load' from here to make sure it is called + ;; only once per machine (it is expensive). (let ((slot (acquire-build-slot machine))) - (and slot (list machine slot)))) + (and slot + (list machine slot (machine-load machine))))) machines)) (define (undecorate pred) (lambda (a b) (match a - ((machine1 slot1) + ((machine1 slot1 load1) (match b - ((machine2 slot2) - (pred machine1 machine2))))))) - - (let loop ((machines+slots - (sort machines+slots + ((machine2 slot2 load2) + (pred machine1 load1 machine2 load2))))))) + + (define (machine-less-loaded-or-faster? m1 l1 m2 l2) + ;; Return #t if M1 is either less loaded or faster than M2, with L1 + ;; being the load of M1 and L2 the load of M2. (This relation defines a + ;; total order on machines.) + (> (/ (build-machine-speed m1) (+ 1 l1)) + (/ (build-machine-speed m2) (+ 1 l2)))) + + (let loop ((machines+slots+loads + (sort machines+slots+loads (undecorate machine-less-loaded-or-faster?)))) - (match machines+slots - (((best slot) others ...) + (match machines+slots+loads + (((best slot load) others ...) ;; Return the best machine unless it's already overloaded. - (if (< (machine-load best) 2.) + (if (< load 2.) (match others - (((machines slots) ...) + (((machines slots loads) ...) ;; Release slots from the uninteresting machines. (for-each release-build-slot slots) -- cgit v1.3