Commit | Line | Data |
---|---|---|
9d8ab803 LC |
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) | |
ddef146b | 22 | #:use-module (guix i18n) |
9d8ab803 LC |
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) | |
2c8e04f1 | 28 | #:use-module (guix utils) |
9d8ab803 | 29 | #:use-module (ssh popen) |
e09c7f4a | 30 | #:use-module (ssh channel) |
9d8ab803 | 31 | #:use-module (srfi srfi-1) |
5ea7537b JK |
32 | #:use-module (srfi srfi-34) |
33 | #:use-module (srfi srfi-35) | |
fdbba544 | 34 | #:use-module (ice-9 format) |
9d8ab803 LC |
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 | ||
5ea7537b JK |
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." | |
9d8ab803 LC |
52 | (define shell-quote |
53 | (compose object->string object->string)) | |
54 | ||
5ea7537b JK |
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))))) | |
9d8ab803 | 70 | |
5ea7537b JK |
71 | (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command))) |
72 | (when (eof-object? (peek-char pipe)) | |
e09c7f4a LC |
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))))))) | |
5ea7537b JK |
80 | pipe)) |
81 | ||
82 | (define* (%remote-eval lowered session #:optional become-command) | |
9d8ab803 | 83 | "Evaluate LOWERED, a lowered gexp, in SESSION. This assumes that all the |
5ea7537b JK |
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)) | |
9d8ab803 LC |
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 | |
2c8e04f1 | 95 | (program-file "remote-exp.scm" exp)) |
9d8ab803 LC |
96 | |
97 | (with-imported-modules (source-module-closure '((guix repl))) | |
98 | #~(begin | |
99 | (use-modules (guix repl)) | |
6f8eb9f1 LC |
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))) | |
9d8ab803 | 106 | (current-output-port)) |
6f8eb9f1 | 107 | |
9d8ab803 LC |
108 | (force-output)))) |
109 | ||
110 | (define* (remote-eval exp session | |
111 | #:key | |
112 | (build-locally? #t) | |
2c8e04f1 | 113 | (system (%current-system)) |
9d8ab803 | 114 | (module-path %load-path) |
5f325317 | 115 | (socket-name (%daemon-socket-uri)) |
5ea7537b | 116 | (become-command #f)) |
9d8ab803 LC |
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." | |
2c8e04f1 JK |
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))) | |
9d8ab803 | 128 | (define inputs |
b9373e26 | 129 | (cons (lowered-gexp-guile lowered) |
9d8ab803 LC |
130 | (lowered-gexp-inputs lowered))) |
131 | ||
38685774 LC |
132 | (define sources |
133 | (lowered-gexp-sources lowered)) | |
9d8ab803 LC |
134 | |
135 | (if build-locally? | |
5db07b97 LC |
136 | (let ((to-send (append (append-map derivation-input-output-paths |
137 | inputs) | |
38685774 | 138 | sources))) |
9d8ab803 | 139 | (mbegin %store-monad |
38685774 | 140 | (built-derivations inputs) |
9d8ab803 LC |
141 | ((store-lift send-files) to-send remote #:recursive? #t) |
142 | (return (close-connection remote)) | |
5ea7537b | 143 | (return (%remote-eval lowered session become-command)))) |
38685774 LC |
144 | (let ((to-send (append (map (compose derivation-file-name |
145 | derivation-input-derivation) | |
146 | inputs) | |
147 | sources))) | |
9d8ab803 LC |
148 | (mbegin %store-monad |
149 | ((store-lift send-files) to-send remote #:recursive? #t) | |
38685774 | 150 | (return (build-derivations remote inputs)) |
9d8ab803 | 151 | (return (close-connection remote)) |
5ea7537b | 152 | (return (%remote-eval lowered session become-command))))))) |