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