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) | |
9d8ab803 LC |
34 | #:use-module (ice-9 match) |
35 | #:export (remote-eval)) | |
36 | ||
37 | ;;; Commentary: | |
38 | ;;; | |
39 | ;;; Note: This API is experimental and subject to change! | |
40 | ;;; | |
41 | ;;; Evaluate a gexp on a remote machine, over SSH, ensuring that all the | |
42 | ;;; elements the gexp refers to are deployed beforehand. This is useful for | |
43 | ;;; expressions that have side effects; for pure expressions, you would rather | |
44 | ;;; build a derivation remotely or offload it. | |
45 | ;;; | |
46 | ;;; Code: | |
47 | ||
5ea7537b JK |
48 | (define* (remote-pipe-for-gexp lowered session #:optional become-command) |
49 | "Return a remote pipe for the given SESSION to evaluate LOWERED. If | |
50 | BECOME-COMMAND is given, use that to invoke the remote Guile REPL." | |
9d8ab803 LC |
51 | (define shell-quote |
52 | (compose object->string object->string)) | |
53 | ||
5ea7537b JK |
54 | (define repl-command |
55 | (append (or become-command '()) | |
56 | (list | |
57 | (string-append (derivation-input-output-path | |
58 | (lowered-gexp-guile lowered)) | |
59 | "/bin/guile") | |
60 | "--no-auto-compile") | |
61 | (append-map (lambda (directory) | |
62 | `("-L" ,directory)) | |
63 | (lowered-gexp-load-path lowered)) | |
64 | (append-map (lambda (directory) | |
65 | `("-C" ,directory)) | |
66 | (lowered-gexp-load-path lowered)) | |
67 | `("-c" | |
68 | ,(shell-quote (lowered-gexp-sexp lowered))))) | |
9d8ab803 | 69 | |
5ea7537b JK |
70 | (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command))) |
71 | (when (eof-object? (peek-char pipe)) | |
e09c7f4a LC |
72 | (let ((status (channel-get-exit-status pipe))) |
73 | (close-port pipe) | |
74 | (raise (condition | |
75 | (&message | |
76 | (message (format #f (G_ "remote command '~{~a~^ ~}' failed \ | |
77 | with status ~a") | |
78 | repl-command status))))))) | |
5ea7537b JK |
79 | pipe)) |
80 | ||
81 | (define* (%remote-eval lowered session #:optional become-command) | |
9d8ab803 | 82 | "Evaluate LOWERED, a lowered gexp, in SESSION. This assumes that all the |
5ea7537b JK |
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)) | |
9d8ab803 LC |
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 | |
2c8e04f1 | 94 | (program-file "remote-exp.scm" exp)) |
9d8ab803 LC |
95 | |
96 | (with-imported-modules (source-module-closure '((guix repl))) | |
97 | #~(begin | |
98 | (use-modules (guix repl)) | |
6f8eb9f1 LC |
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))) | |
9d8ab803 | 105 | (current-output-port)) |
6f8eb9f1 | 106 | |
9d8ab803 LC |
107 | (force-output)))) |
108 | ||
109 | (define* (remote-eval exp session | |
110 | #:key | |
111 | (build-locally? #t) | |
2c8e04f1 | 112 | (system (%current-system)) |
9d8ab803 | 113 | (module-path %load-path) |
5f325317 | 114 | (socket-name (%daemon-socket-uri)) |
5ea7537b | 115 | (become-command #f)) |
9d8ab803 LC |
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." | |
2c8e04f1 JK |
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))) | |
9d8ab803 | 127 | (define inputs |
b9373e26 | 128 | (cons (lowered-gexp-guile lowered) |
9d8ab803 LC |
129 | (lowered-gexp-inputs lowered))) |
130 | ||
38685774 LC |
131 | (define sources |
132 | (lowered-gexp-sources lowered)) | |
9d8ab803 LC |
133 | |
134 | (if build-locally? | |
5db07b97 LC |
135 | (let ((to-send (append (append-map derivation-input-output-paths |
136 | inputs) | |
38685774 | 137 | sources))) |
9d8ab803 | 138 | (mbegin %store-monad |
38685774 | 139 | (built-derivations inputs) |
9d8ab803 LC |
140 | ((store-lift send-files) to-send remote #:recursive? #t) |
141 | (return (close-connection remote)) | |
5ea7537b | 142 | (return (%remote-eval lowered session become-command)))) |
38685774 LC |
143 | (let ((to-send (append (map (compose derivation-file-name |
144 | derivation-input-derivation) | |
145 | inputs) | |
146 | sources))) | |
9d8ab803 LC |
147 | (mbegin %store-monad |
148 | ((store-lift send-files) to-send remote #:recursive? #t) | |
38685774 | 149 | (return (build-derivations remote inputs)) |
9d8ab803 | 150 | (return (close-connection remote)) |
5ea7537b | 151 | (return (%remote-eval lowered session become-command))))))) |