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) | |
22 | #:use-module (guix inferior) | |
23 | #:use-module (guix store) | |
24 | #:use-module (guix monads) | |
25 | #:use-module (guix modules) | |
26 | #:use-module (guix derivations) | |
27 | #:use-module (ssh popen) | |
28 | #:use-module (srfi srfi-1) | |
29 | #:use-module (ice-9 match) | |
30 | #:export (remote-eval)) | |
31 | ||
32 | ;;; Commentary: | |
33 | ;;; | |
34 | ;;; Note: This API is experimental and subject to change! | |
35 | ;;; | |
36 | ;;; Evaluate a gexp on a remote machine, over SSH, ensuring that all the | |
37 | ;;; elements the gexp refers to are deployed beforehand. This is useful for | |
38 | ;;; expressions that have side effects; for pure expressions, you would rather | |
39 | ;;; build a derivation remotely or offload it. | |
40 | ;;; | |
41 | ;;; Code: | |
42 | ||
43 | (define (remote-pipe-for-gexp lowered session) | |
44 | "Return a remote pipe for the given SESSION to evaluate LOWERED." | |
45 | (define shell-quote | |
46 | (compose object->string object->string)) | |
47 | ||
48 | (apply open-remote-pipe* session OPEN_READ | |
49 | (string-append (derivation->output-path | |
50 | (lowered-gexp-guile lowered)) | |
51 | "/bin/guile") | |
52 | "--no-auto-compile" | |
53 | (append (append-map (lambda (directory) | |
54 | `("-L" ,directory)) | |
55 | (lowered-gexp-load-path lowered)) | |
56 | (append-map (lambda (directory) | |
57 | `("-C" ,directory)) | |
58 | (lowered-gexp-load-path lowered)) | |
59 | `("-c" | |
60 | ,(shell-quote (lowered-gexp-sexp lowered)))))) | |
61 | ||
62 | (define (%remote-eval lowered session) | |
63 | "Evaluate LOWERED, a lowered gexp, in SESSION. This assumes that all the | |
64 | prerequisites of EXP are already available on the host at SESSION." | |
65 | (let* ((pipe (remote-pipe-for-gexp lowered session)) | |
66 | (result (read-repl-response pipe))) | |
67 | (close-port pipe) | |
68 | result)) | |
69 | ||
70 | (define (trampoline exp) | |
71 | "Return a \"trampoline\" gexp that evaluates EXP and writes the evaluation | |
72 | result to the current output port using the (guix repl) protocol." | |
73 | (define program | |
74 | (scheme-file "remote-exp.scm" exp)) | |
75 | ||
76 | (with-imported-modules (source-module-closure '((guix repl))) | |
77 | #~(begin | |
78 | (use-modules (guix repl)) | |
79 | (send-repl-response '(primitive-load #$program) | |
80 | (current-output-port)) | |
81 | (force-output)))) | |
82 | ||
83 | (define* (remote-eval exp session | |
84 | #:key | |
85 | (build-locally? #t) | |
86 | (module-path %load-path) | |
87 | (socket-name "/var/guix/daemon-socket/socket")) | |
88 | "Evaluate EXP, a gexp, on the host at SESSION, an SSH session. Ensure that | |
89 | all the elements EXP refers to are built and deployed to SESSION beforehand. | |
90 | When BUILD-LOCALLY? is true, said dependencies are built locally and sent to | |
91 | the remote store afterwards; otherwise, dependencies are built directly on the | |
92 | remote store." | |
93 | (mlet %store-monad ((lowered (lower-gexp (trampoline exp) | |
94 | #:module-path %load-path)) | |
95 | (remote -> (connect-to-remote-daemon session | |
96 | socket-name))) | |
97 | (define inputs | |
38685774 | 98 | (cons (derivation-input (lowered-gexp-guile lowered)) |
9d8ab803 LC |
99 | (lowered-gexp-inputs lowered))) |
100 | ||
38685774 LC |
101 | (define sources |
102 | (lowered-gexp-sources lowered)) | |
9d8ab803 LC |
103 | |
104 | (if build-locally? | |
38685774 LC |
105 | (let ((to-send (append (map derivation-input-output-paths inputs) |
106 | sources))) | |
9d8ab803 | 107 | (mbegin %store-monad |
38685774 | 108 | (built-derivations inputs) |
9d8ab803 LC |
109 | ((store-lift send-files) to-send remote #:recursive? #t) |
110 | (return (close-connection remote)) | |
111 | (return (%remote-eval lowered session)))) | |
38685774 LC |
112 | (let ((to-send (append (map (compose derivation-file-name |
113 | derivation-input-derivation) | |
114 | inputs) | |
115 | sources))) | |
9d8ab803 LC |
116 | (mbegin %store-monad |
117 | ((store-lift send-files) to-send remote #:recursive? #t) | |
38685774 | 118 | (return (build-derivations remote inputs)) |
9d8ab803 LC |
119 | (return (close-connection remote)) |
120 | (return (%remote-eval lowered session))))))) |