guix/remote.scm

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