[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: DRAFT offload: Use Guile-SSH instead of GNU lsh.
|
From: |
Ludovic Courtès |
|
Subject: |
01/01: DRAFT offload: Use Guile-SSH instead of GNU lsh. |
|
Date: |
Tue, 1 Nov 2016 23:17:29 +0000 (UTC) |
civodul pushed a commit to branch wip-guile-ssh
in repository guix.
commit ff4a2636039ae7347494e8594e8511a69f29ae45
Author: Ludovic Courtès <address@hidden>
Date: Sun Mar 2 22:39:48 2014 +0100
DRAFT offload: Use Guile-SSH instead of GNU lsh.
* guix/scripts/offload.scm (%lsh-command, %lshg-command)
user-lsh-private-key): Remove.
(user-openssh-private-key): New procedure.
(open-ssh-session): New procedure.
(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.
---
guix/scripts/offload.scm | 254 ++++++++++++++++++++--------------------------
1 file changed, 111 insertions(+), 143 deletions(-)
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 33d141e..59bbdf6 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -17,6 +17,10 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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,7 +69,7 @@
(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)))
(parallel-builds build-machine-parallel-builds ; number
(default 1))
(speed build-machine-speed ; inexact real
@@ -86,19 +90,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
- ;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>.
- "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 +130,55 @@ 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 (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)
+ ;; #:log-verbosity 'protocol
+ #:identity (build-machine-private-key machine)
+
+ ;; We need lightweight compression when
+ ;; exchanging full archives.
+ #:compression "zlib"
+ #:compression-level 3)))
+ (connect! session)
+
+ ;; TODO: Use of known_hosts currently seems to be failing, and we'd prefer
+ ;; a 'server-public-key' field in 'build-machine'.
+ (let* ((auth (authenticate-server session))
+ (server (get-server-public-key session))
+ (digest (get-public-key-hash server 'sha1)))
+ (unless (eq? 'ok auth)
+ ;; FIXME: This should be an error we sometimes get 'found-other'
+ ;; because 'known_hosts' contains an ecdh-sha2-nistp256 key for the
+ ;; server whereas here we receive an ssh-rsa key, the reason being
+ ;; that libssh supports fewer algorithms than OpenSSH. It's OKish to
+ ;; ignore the error because we have a higher-level authentication
+ ;; layer for archives anyway.
+ (warning (_ "failed to authenticate server at '~a' with key ~a: ~s~%")
+ (build-machine-name machine)
+ (bytevector->base16-string digest)
+ auth)))
+ (let ((auth (userauth-public-key! session private)))
+ (unless (eq? 'success auth)
+ (leave (_ "SSH public key authentication failed: ~a~%")
+ (get-error session))))
+
+ session))
+
+(define %channel->session
+ ;; Mapping of SSH channels to their corresponding session.
+ (make-weak-key-hash-table))
+
+(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 +186,19 @@ 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)
+ ;; TODO: Use (ssh popen) instead.
+ (let* ((session (open-ssh-session machine))
+ (channel (make-channel session)))
+ ;; XXX: Work around a GC bug with Guile-SSH 0.6.0: make sure SESSION
+ ;; remains alive as long as CHANNEL is alive.
+ ;; (hashq-set! %channel->session channel session)
- (append (build-machine-ssh-options machine)
- (list (build-machine-name machine))
- (if quote?
- (map shell-quote command)
- command)))))
+ (channel-open-session channel)
+ (channel-request-exec channel
+ (string-join (if quote?
+ (map shell-quote command)
+ command)))
+ channel))
;;;
@@ -335,10 +325,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 +358,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 +375,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 +388,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 +435,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 +445,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 +463,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 +497,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 +519,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