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 i18n)
  23   #:use-module (guix inferior)
  24   #:use-module (guix store)
  25   #:use-module (guix monads)
  26   #:use-module (guix modules)
  27   #:use-module (guix derivations)
  28   #:use-module (guix utils)
  29   #:use-module (ssh popen)
  30   #:use-module (srfi srfi-1)
  31   #:use-module (srfi srfi-34)
  32   #:use-module (srfi srfi-35)
  33   #:use-module (ice-9 match)
  34   #:export (remote-eval))
  35
  36 ;;; Commentary:
  37 ;;;
  38 ;;; Note: This API is experimental and subject to change!
  39 ;;;
  40 ;;; Evaluate a gexp on a remote machine, over SSH, ensuring that all the
  41 ;;; elements the gexp refers to are deployed beforehand.  This is useful for
  42 ;;; expressions that have side effects; for pure expressions, you would rather
  43 ;;; build a derivation remotely or offload it.
  44 ;;;
  45 ;;; Code:
  46
  47 (define* (remote-pipe-for-gexp lowered session #:optional become-command)
  48   "Return a remote pipe for the given SESSION to evaluate LOWERED.  If
  49 BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
  50   (define shell-quote
  51     (compose object->string object->string))
  52
  53   (define repl-command
  54     (append (or become-command '())
  55             (list
  56              (string-append (derivation-input-output-path
  57                              (lowered-gexp-guile lowered))
  58                             "/bin/guile")
  59              "--no-auto-compile")
  60             (append-map (lambda (directory)
  61                           `("-L" ,directory))
  62                         (lowered-gexp-load-path lowered))
  63             (append-map (lambda (directory)
  64                           `("-C" ,directory))
  65                         (lowered-gexp-load-path lowered))
  66             `("-c"
  67               ,(shell-quote (lowered-gexp-sexp lowered)))))
  68
  69   (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command)))
  70     (when (eof-object? (peek-char pipe))
  71       (raise (condition
  72               (&message
  73                (message (format #f (G_ "failed to run '~{~a~^ ~}'")
  74                                 repl-command))))))
  75     pipe))
  76
  77 (define* (%remote-eval lowered session #:optional become-command)
  78   "Evaluate LOWERED, a lowered gexp, in SESSION.  This assumes that all the
  79 prerequisites of EXP are already available on the host at SESSION.  If
  80 BECOME-COMMAND is given, use that to invoke the remote Guile REPL."
  81   (let* ((pipe   (remote-pipe-for-gexp lowered session become-command))
  82          (result (read-repl-response pipe)))
  83     (close-port pipe)
  84     result))
  85
  86 (define (trampoline exp)
  87   "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation
  88 result to the current output port using the (guix repl) protocol."
  89   (define program
  90     (program-file "remote-exp.scm" exp))
  91
  92   (with-imported-modules (source-module-closure '((guix repl)))
  93     #~(begin
  94         (use-modules (guix repl))
  95
  96         ;; We use CURRENT-OUTPUT-PORT for REPL messages, so redirect PROGRAM's
  97         ;; output to CURRENT-ERROR-PORT so that it does not interfere.
  98         (send-repl-response '(with-output-to-port (current-error-port)
  99                                (lambda ()
 100                                  (primitive-load #$program)))
 101                             (current-output-port))
 102
 103         (force-output))))
 104
 105 (define* (remote-eval exp session
 106                       #:key
 107                       (build-locally? #t)
 108                       (system (%current-system))
 109                       (module-path %load-path)
 110                       (socket-name (%daemon-socket-uri))
 111                       (become-command #f))
 112   "Evaluate EXP, a gexp, on the host at SESSION, an SSH session.  Ensure that
 113 all the elements EXP refers to are built and deployed to SESSION beforehand.
 114 When BUILD-LOCALLY? is true, said dependencies are built locally and sent to
 115 the remote store afterwards; otherwise, dependencies are built directly on the
 116 remote store."
 117   (mlet* %store-monad ((lowered (lower-gexp (trampoline exp)
 118                                             #:system system
 119                                             #:guile-for-build #f
 120                                             #:module-path %load-path))
 121                        (remote -> (connect-to-remote-daemon session
 122                                                             socket-name)))
 123     (define inputs
 124       (cons (lowered-gexp-guile lowered)
 125             (lowered-gexp-inputs lowered)))
 126
 127     (define sources
 128       (lowered-gexp-sources lowered))
 129
 130     (if build-locally?
 131         (let ((to-send (append (append-map derivation-input-output-paths
 132                                            inputs)
 133                                sources)))
 134           (mbegin %store-monad
 135             (built-derivations inputs)
 136             ((store-lift send-files) to-send remote #:recursive? #t)
 137             (return (close-connection remote))
 138             (return (%remote-eval lowered session become-command))))
 139         (let ((to-send (append (map (compose derivation-file-name
 140                                              derivation-input-derivation)
 141                                     inputs)
 142                                sources)))
 143           (mbegin %store-monad
 144             ((store-lift send-files) to-send remote #:recursive? #t)
 145             (return (build-derivations remote inputs))
 146             (return (close-connection remote))
 147             (return (%remote-eval lowered session become-command)))))))