From 2c8e04f13670c8c7ad8c7195c305960dd1905363 Mon Sep 17 00:00:00 2001
From: "Jakob L. Kreuze" <zerodaysfordays@sdf.lonestar.org>
Date: Fri, 9 Aug 2019 14:24:57 -0400
Subject: [PATCH] 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>.
---
 doc/guix.texi       |  3 +++
 gnu/machine/ssh.scm | 31 +++++++++++++++++++++++++++----
 guix/remote.scm     | 14 +++++++++-----
 guix/ssh.scm        |  7 +++++++
 4 files changed, 46 insertions(+), 9 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 734206a4b2..a7facf4701 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -25573,6 +25573,9 @@ with an @code{environment} of @code{managed-host-environment-type}.
 
 @table @asis
 @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{user} (default: @code{"root"})
 @item @code{identity} (default: @code{#f})
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index ba3e33c922..670990a633 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -36,6 +36,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (managed-host-environment-type
 
@@ -68,6 +69,7 @@
   machine-ssh-configuration?
   this-machine-ssh-configuration
   (host-name      machine-ssh-configuration-host-name) ; string
+  (system         machine-ssh-configuration-system)    ; string
   (build-locally? machine-ssh-configuration-build-locally?
                   (default #t))
   (port           machine-ssh-configuration-port       ; integer
@@ -103,10 +105,12 @@ one from the configuration's parameters if one was not provided."
   "Internal implementation of 'machine-remote-eval' for MACHINE instances with
 an environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
-  (remote-eval exp (machine-ssh-session machine)
-               #:build-locally?
-               (machine-ssh-configuration-build-locally?
-                (machine-configuration machine))))
+  (let ((config (machine-configuration machine)))
+    (remote-eval exp (machine-ssh-session machine)
+                 #:build-locally?
+                 (machine-ssh-configuration-build-locally? config)
+                 #:system
+                 (machine-ssh-configuration-system config))))
 
 
 ;;;
@@ -240,10 +244,29 @@ MACHINE's 'system' declaration do not exist on the machine."
               device)
     (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)
   "Raise a '&message' error condition if it is clear that deploying MACHINE's
 'system' declaration would fail."
+  ;; Order is important here -- an incorrect value for 'system' will cause
+  ;; invocations of 'remote-eval' to fail.
   (mbegin %store-monad
+    (machine-check-building-for-appropriate-system machine)
     (machine-check-file-system-availability machine)
     (machine-check-initrd-modules machine)))
 
diff --git a/guix/remote.scm b/guix/remote.scm
index 5fecd954e9..bcac64ea7a 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -24,6 +24,7 @@
   #:use-module (guix monads)
   #:use-module (guix modules)
   #:use-module (guix derivations)
+  #:use-module (guix utils)
   #:use-module (ssh popen)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
@@ -71,7 +72,7 @@ prerequisites of EXP are already available on the host at SESSION."
   "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation
 result to the current output port using the (guix repl) protocol."
   (define program
-    (scheme-file "remote-exp.scm" exp))
+    (program-file "remote-exp.scm" exp))
 
   (with-imported-modules (source-module-closure '((guix repl)))
     #~(begin
@@ -89,6 +90,7 @@ result to the current output port using the (guix repl) protocol."
 (define* (remote-eval exp session
                       #:key
                       (build-locally? #t)
+                      (system (%current-system))
                       (module-path %load-path)
                       (socket-name "/var/guix/daemon-socket/socket"))
   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
@@ -96,10 +98,12 @@ all the elements EXP refers to are built and deployed to SESSION beforehand.
 When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
 the remote store afterwards; otherwise, dependencies are built directly on the
 remote store."
-  (mlet %store-monad ((lowered (lower-gexp (trampoline exp)
-                                           #:module-path %load-path))
-                      (remote -> (connect-to-remote-daemon session
-                                                           socket-name)))
+  (mlet* %store-monad ((lowered (lower-gexp (trampoline exp)
+                                            #:system system
+                                            #:guile-for-build #f
+                                            #:module-path %load-path))
+                       (remote -> (connect-to-remote-daemon session
+                                                            socket-name)))
     (define inputs
       (cons (lowered-gexp-guile lowered)
             (lowered-gexp-inputs lowered)))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index ede00133c8..9b5ca68894 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -39,6 +39,7 @@
             remote-inferior
             remote-daemon-channel
             connect-to-remote-daemon
+            remote-system
             send-files
             retrieve-files
             retrieve-files*
@@ -282,6 +283,12 @@ be read.  When RECURSIVE? is true, the closure of FILES is exported."
                              ,(object->string
                                (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
                      #:key
                      recursive?