guix/remote.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix remote)
  20   #:use-module (guix ssh)
  21   #:use-module (guix gexp)
  22   #:use-module (guix inferior)
  23   #:use-module (guix store)
  24   #:use-module (guix monads)
  25   #:use-module (guix modules)
  26   #:use-module (guix derivations)
  27   #:use-module (guix utils)
  28   #:use-module (ssh popen)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-35)
  32   #:use-module (ice-9 match)
  33   #:export (remote-eval))
  34
  35 ;;; Commentary:
  36 ;;;
  37 ;;; Note: This API is experimental and subject to change!
  38 ;;;
  39 ;;; Evaluate a gexp on a remote machine, over SSH, ensuring that all the
  40 ;;; elements the gexp refers to are deployed beforehand.  This is useful for
  41 ;;; expressions that have side effects; for pure expressions, you would rather
  42 ;;; build a derivation remotely or offload it.
  43 ;;;
  44 ;;; Code:
  45
  46 (define* (remote-pipe-for-gexp lowered session #:optional become-command)
  47   "Return a remote pipe for the given SESSION to evaluate LOWERED.  If
  48 BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
  49   (define shell-quote
  50     (compose object->string object->string))
  51
  52   (define repl-command
  53     (append (or become-command '())
  54             (list
  55              (string-append (derivation-input-output-path
  56                              (lowered-gexp-guile lowered))
  57                             "/bin/guile")
  58              "--no-auto-compile")
  59             (append-map (lambda (directory)
  60                           `("-L" ,directory))
  61                         (lowered-gexp-load-path lowered))
  62             (append-map (lambda (directory)
  63                           `("-C" ,directory))
  64                         (lowered-gexp-load-path lowered))
  65             `("-c"
  66               ,(shell-quote (lowered-gexp-sexp lowered)))))
  67
  68   (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
  69     (when (eof-object? (peek-char pipe))
  70       (raise (condition
  71               (&message
  72                (message (format #f (G_ "failed to run '~{~a~^ ~}'")
  73                                 repl-command))))))
  74     pipe))
  75
  76 (define* (%remote-eval lowered session #:optional become-command)
  77   "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
  78 prerequisites of EXP are already available on the host at SESSION.  If
  79 BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
  80   (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
  81          (result (read-repl-response pipe)))
  82     (close-port pipe)
  83     result))
  84
  85 (define (trampoline exp)
  86   "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation
  87 result to the current output port using the (guix repl) protocol."
  88   (define program
  89     (program-file "remote-exp.scm" exp))
  90
  91   (with-imported-modules (source-module-closure '((guix repl)))
  92     #~(begin
  93         (use-modules (guix repl))
  94
  95         ;; We use CURRENT-OUTPUT-PORT for REPL messages, so redirect PROGRAM's
  96         ;; output to CURRENT-ERROR-PORT so that it does not interfere.
  97         (send-repl-response '(with-output-to-port (current-error-port)
  98                                (lambda ()
  99                                  (primitive-load #$program)))
 100                             (current-output-port))
 101
 102         (force-output))))
 103
 104 (define* (remote-eval exp session
 105                       #:key
 106                       (build-locally? #t)
 107                       (system (%current-system))
 108                       (module-path %load-path)
 109                       (socket-name "/var/guix/daemon-socket/socket")
 110                       (become-command #f))
 111   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
 112 all the elements EXP refers to are built and deployed to SESSION beforehand.
 113 When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
 114 the remote store afterwards; otherwise, dependencies are built directly on the
 115 remote store."
 116   (mlet* %store-monad ((lowered (lower-gexp (trampoline exp)
 117                                             #:system system
 118                                             #:guile-for-build #f
 119                                             #:module-path %load-path))
 120                        (remote -> (connect-to-remote-daemon session
 121                                                             socket-name)))
 122     (define inputs
 123       (cons (lowered-gexp-guile lowered)
 124             (lowered-gexp-inputs lowered)))
 125
 126     (define sources
 127       (lowered-gexp-sources lowered))
 128
 129     (if build-locally?
 130         (let ((to-send (append (append-map derivation-input-output-paths
 131                                            inputs)
 132                                sources)))
 133           (mbegin %store-monad
 134             (built-derivations inputs)
 135             ((store-lift send-files) to-send remote #:recursive? #t)
 136             (return (close-connection remote))
 137             (return (%remote-eval lowered session become-command))))
 138         (let ((to-send (append (map (compose derivation-file-name
 139                                              derivation-input-derivation)
 140                                     inputs)
 141                                sources)))
 142           (mbegin %store-monad
 143             ((store-lift send-files) to-send remote #:recursive? #t)
 144             (return (build-derivations remote inputs))
 145             (return (close-connection remote))
 146             (return (%remote-eval lowered session become-command)))))))