[bug#36162] [PATCH 4/4] Add (guix remote).

["Ludovic Courtès" <ludo@gnu.org>]

* guix/remote.scm: New file.
* Makefile.am (MODULES): Add it.
---
 Makefile.am     |   1 +
 guix/remote.scm | 130 ++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 131 insertions(+)
 create mode 100644 guix/remote.scm

diff --git a/Makefile.am b/Makefile.am
index 0aa92ecfb9..42307abaed 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -274,6 +274,7 @@ if HAVE_GUILE_SSH
 
 MODULES +=					\
   guix/ssh.scm					\
+  guix/remote.scm				\
   guix/scripts/copy.scm				\
   guix/store/ssh.scm
 
diff --git a/guix/remote.scm b/guix/remote.scm
new file mode 100644
index 0000000000..cc051dee8a
--- /dev/null
+++ b/guix/remote.scm
@@ -0,0 +1,130 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix remote)
+  #:use-module (guix ssh)
+  #:use-module (guix gexp)
+  #:use-module (guix inferior)
+  #:use-module (guix store)
+  #:use-module (guix monads)
+  #:use-module (guix modules)
+  #:use-module (guix derivations)
+  #:use-module (ssh popen)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
+  #:export (remote-eval))
+
+;;; Commentary:
+;;;
+;;; Evaluate a gexp on a remote machine, over SSH, ensuring that all the
+;;; elements the gexp refers to are deployed beforehand.  This is useful for
+;;; expressions that have side effects; for pure expressions, you would rather
+;;; build a derivation remotely or offload it.
+;;;
+;;; Code:
+
+(define (remote-pipe-for-gexp lowered session)
+  "Return a remote pipe for the given SESSION to evaluate LOWERED."
+  (define shell-quote
+    (compose object->string object->string))
+
+  (apply open-remote-pipe* session OPEN_READ
+         (string-append (derivation->output-path
+                         (lowered-gexp-guile lowered))
+                        "/bin/guile")
+         "--no-auto-compile"
+         (append (append-map (lambda (directory)
+                               `("-L" ,directory))
+                             (lowered-gexp-load-path lowered))
+                 (append-map (lambda (directory)
+                               `("-C" ,directory))
+                             (lowered-gexp-load-path lowered))
+                 `("-c"
+                   ,(shell-quote (lowered-gexp-sexp lowered))))))
+
+(define (%remote-eval lowered session)
+  "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
+prerequisites of EXP are already available on the host at SESSION."
+  (let* ((pipe   (remote-pipe-for-gexp lowered session))
+         (result (read-repl-response pipe)))
+    (close-port pipe)
+    result))
+
+(define (trampoline exp)
+  "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))
+
+  (with-imported-modules (source-module-closure '((guix repl)))
+    #~(begin
+        (use-modules (guix repl))
+        (send-repl-response '(primitive-load #$program)
+                            (current-output-port))
+        (force-output))))
+
+(define* (remote-eval exp session
+                      #:key
+                      (build-locally? #t)
+                      (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
+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)))
+    (define inputs
+      (cons (gexp-input (lowered-gexp-guile lowered))
+            (lowered-gexp-inputs lowered)))
+
+    (define to-build
+      (map (lambda (input)
+             (if (derivation? (gexp-input-thing input))
+                 (cons (gexp-input-thing input)
+                       (gexp-input-output input))
+                 (gexp-input-thing input)))
+           inputs))
+
+    (if build-locally?
+        (let ((to-send (map (lambda (input)
+                              (match (gexp-input-thing input)
+                                ((? derivation? drv)
+                                 (derivation->output-path
+                                  drv (gexp-input-output input)))
+                                ((? store-path? item)
+                                 item)))
+                            inputs)))
+          (mbegin %store-monad
+            (built-derivations to-build)
+            ((store-lift send-files) to-send remote #:recursive? #t)
+            (return (%remote-eval lowered session))))
+        (let ((to-send (map (lambda (input)
+                              (match (gexp-input-thing input)
+                                ((? derivation? drv)
+                                 (derivation-file-name drv))
+                                ((? store-path? item)
+                                 item)))
+                            inputs)))
+          (mbegin %store-monad
+            ((store-lift send-files) to-send remote #:recursive? #t)
+            (return (build-derivations remote to-build))
+            (return (%remote-eval lowered session)))))))
-- 
2.21.0