remote: Build derivations appropriate for the remote's

* gnu/machine/ssh.scm (machine-ssh-configuration): Add 'system' field.
(managed-host-remote-eval): Pass 'system' field to 'remote-eval'.
(machine-check-building-for-appropriate-system): New variable.
(check-deployment-sanity): Add call to
'machine-check-building-for-appropriate-system'.
* doc/guix.texi (Invoking guix deploy): Describe new 'system' field.
* guix/ssh.scm (remote-system): New variable.
* guix/remote.scm (remote-eval): Use result of 'remote-system' when
lowering the G-Expression.
(remote-eval): Add 'system' keyword argument.
(trampoline): Return a <program-file> rather than a <scheme-file>.
This commit is contained in:
Jakob L. Kreuze 2019-08-09 14:24:57 -04:00 committed by Christopher Lemmer Webber
parent 67dac6b892
commit 2c8e04f136
No known key found for this signature in database
GPG key ID: 4BC025925FF8F4D3
4 changed files with 46 additions and 9 deletions

View file

@ -25573,6 +25573,9 @@ with an @code{environment} of @code{managed-host-environment-type}.
@table @asis @table @asis
@item @code{host-name} @item @code{host-name}
@item @code{system}
The Nix system type describing the architecture of the machine being deployed
to. This should look something like ``x86_64-linux''.
@item @code{port} (default: @code{22}) @item @code{port} (default: @code{22})
@item @code{user} (default: @code{"root"}) @item @code{user} (default: @code{"root"})
@item @code{identity} (default: @code{#f}) @item @code{identity} (default: @code{#f})

View file

@ -36,6 +36,7 @@ (define-module (gnu machine ssh)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:export (managed-host-environment-type #:export (managed-host-environment-type
@ -68,6 +69,7 @@ (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
machine-ssh-configuration? machine-ssh-configuration?
this-machine-ssh-configuration this-machine-ssh-configuration
(host-name machine-ssh-configuration-host-name) ; string (host-name machine-ssh-configuration-host-name) ; string
(system machine-ssh-configuration-system) ; string
(build-locally? machine-ssh-configuration-build-locally? (build-locally? machine-ssh-configuration-build-locally?
(default #t)) (default #t))
(port machine-ssh-configuration-port ; integer (port machine-ssh-configuration-port ; integer
@ -103,10 +105,12 @@ (define (managed-host-remote-eval machine exp)
"Internal implementation of 'machine-remote-eval' for MACHINE instances with "Internal implementation of 'machine-remote-eval' for MACHINE instances with
an environment type of 'managed-host." an environment type of 'managed-host."
(maybe-raise-unsupported-configuration-error machine) (maybe-raise-unsupported-configuration-error machine)
(let ((config (machine-configuration machine)))
(remote-eval exp (machine-ssh-session machine) (remote-eval exp (machine-ssh-session machine)
#:build-locally? #:build-locally?
(machine-ssh-configuration-build-locally? (machine-ssh-configuration-build-locally? config)
(machine-configuration machine)))) #:system
(machine-ssh-configuration-system config))))
;;; ;;;
@ -240,10 +244,29 @@ (define dev
device) device)
(return #t))) (return #t)))
(define (machine-check-building-for-appropriate-system machine)
"Raise a '&message' error condition if MACHINE is configured to be built
locally and the 'system' field does not match the '%current-system' reported
by MACHINE."
(let ((config (machine-configuration machine))
(system (remote-system (machine-ssh-session machine))))
(when (and (machine-ssh-configuration-build-locally? config)
(not (string= system (machine-ssh-configuration-system config))))
(raise (condition
(&message
(message (format #f (G_ "incorrect target system \
('~a' was given, while the system reports that it is '~a')~%")
(machine-ssh-configuration-system config)
system)))))))
(with-monad %store-monad (return #t)))
(define (check-deployment-sanity machine) (define (check-deployment-sanity machine)
"Raise a '&message' error condition if it is clear that deploying MACHINE's "Raise a '&message' error condition if it is clear that deploying MACHINE's
'system' declaration would fail." 'system' declaration would fail."
;; Order is important here -- an incorrect value for 'system' will cause
;; invocations of 'remote-eval' to fail.
(mbegin %store-monad (mbegin %store-monad
(machine-check-building-for-appropriate-system machine)
(machine-check-file-system-availability machine) (machine-check-file-system-availability machine)
(machine-check-initrd-modules machine))) (machine-check-initrd-modules machine)))

View file

@ -24,6 +24,7 @@ (define-module (guix remote)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix modules) #:use-module (guix modules)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix utils)
#:use-module (ssh popen) #:use-module (ssh popen)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -71,7 +72,7 @@ (define (trampoline exp)
"Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation
result to the current output port using the (guix repl) protocol." result to the current output port using the (guix repl) protocol."
(define program (define program
(scheme-file "remote-exp.scm" exp)) (program-file "remote-exp.scm" exp))
(with-imported-modules (source-module-closure '((guix repl))) (with-imported-modules (source-module-closure '((guix repl)))
#~(begin #~(begin
@ -89,6 +90,7 @@ (define program
(define* (remote-eval exp session (define* (remote-eval exp session
#:key #:key
(build-locally? #t) (build-locally? #t)
(system (%current-system))
(module-path %load-path) (module-path %load-path)
(socket-name "/var/guix/daemon-socket/socket")) (socket-name "/var/guix/daemon-socket/socket"))
"Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that "Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that
@ -96,7 +98,9 @@ (define* (remote-eval exp session
When BUILD-LOCALLY? is true, said dependencies are built locally and sent to When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
the remote store afterwards; otherwise, dependencies are built directly on the the remote store afterwards; otherwise, dependencies are built directly on the
remote store." remote store."
(mlet %store-monad ((lowered (lower-gexp (trampoline exp) (mlet* %store-monad ((lowered (lower-gexp (trampoline exp)
#:system system
#:guile-for-build #f
#:module-path %load-path)) #:module-path %load-path))
(remote -> (connect-to-remote-daemon session (remote -> (connect-to-remote-daemon session
socket-name))) socket-name)))

View file

@ -39,6 +39,7 @@ (define-module (guix ssh)
remote-inferior remote-inferior
remote-daemon-channel remote-daemon-channel
connect-to-remote-daemon connect-to-remote-daemon
remote-system
send-files send-files
retrieve-files retrieve-files
retrieve-files* retrieve-files*
@ -282,6 +283,12 @@ (define export
,(object->string ,(object->string
(object->string export)))))) (object->string export))))))
(define (remote-system session)
"Return the system type as expected by Nix, usually ARCHITECTURE-KERNEL, of
the machine on the other end of SESSION."
(inferior-remote-eval '(begin (use-modules (guix utils)) (%current-system))
session))
(define* (send-files local files remote (define* (send-files local files remote
#:key #:key
recursive? recursive?