projects/guix·blob javascript-team · refs

170 lines · 7.3 KiB

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