Commit | Line | Data |
---|---|---|
fa9edf09 JK |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.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 (gnu machine ssh) | |
20 | #:use-module (gnu bootloader) | |
21 | #:use-module (gnu machine) | |
22 | #:autoload (gnu packages gnupg) (guile-gcrypt) | |
23 | #:use-module (gnu services) | |
24 | #:use-module (gnu services shepherd) | |
25 | #:use-module (gnu system) | |
26 | #:use-module (guix derivations) | |
27 | #:use-module (guix gexp) | |
28 | #:use-module (guix i18n) | |
29 | #:use-module (guix modules) | |
30 | #:use-module (guix monads) | |
31 | #:use-module (guix records) | |
32 | #:use-module (guix remote) | |
33 | #:use-module (guix ssh) | |
34 | #:use-module (guix store) | |
35 | #:use-module (ice-9 match) | |
36 | #:use-module (srfi srfi-19) | |
37 | #:use-module (srfi srfi-35) | |
38 | #:export (managed-host-environment-type | |
39 | ||
40 | machine-ssh-configuration | |
41 | machine-ssh-configuration? | |
42 | machine-ssh-configuration | |
43 | ||
44 | machine-ssh-configuration-host-name | |
45 | machine-ssh-configuration-port | |
46 | machine-ssh-configuration-user | |
47 | machine-ssh-configuration-session)) | |
48 | ||
49 | ;;; Commentary: | |
50 | ;;; | |
51 | ;;; This module implements remote evaluation and system deployment for | |
52 | ;;; machines that are accessable over SSH and have a known host-name. In the | |
53 | ;;; sense of the broader "machine" interface, we describe the environment for | |
54 | ;;; such machines as 'managed-host. | |
55 | ;;; | |
56 | ;;; Code: | |
57 | ||
58 | \f | |
59 | ;;; | |
60 | ;;; Parameters for the SSH client. | |
61 | ;;; | |
62 | ||
63 | (define-record-type* <machine-ssh-configuration> machine-ssh-configuration | |
64 | make-machine-ssh-configuration | |
65 | machine-ssh-configuration? | |
66 | this-machine-ssh-configuration | |
67 | (host-name machine-ssh-configuration-host-name) ; string | |
68 | (port machine-ssh-configuration-port ; integer | |
69 | (default 22)) | |
70 | (user machine-ssh-configuration-user ; string | |
71 | (default "root")) | |
72 | (identity machine-ssh-configuration-identity ; path to a private key | |
73 | (default #f)) | |
74 | (session machine-ssh-configuration-session ; session | |
75 | (default #f))) | |
76 | ||
77 | (define (machine-ssh-session machine) | |
78 | "Return the SSH session that was given in MACHINE's configuration, or create | |
79 | one from the configuration's parameters if one was not provided." | |
80 | (maybe-raise-unsupported-configuration-error machine) | |
81 | (let ((config (machine-configuration machine))) | |
82 | (or (machine-ssh-configuration-session config) | |
83 | (let ((host-name (machine-ssh-configuration-host-name config)) | |
84 | (user (machine-ssh-configuration-user config)) | |
85 | (port (machine-ssh-configuration-port config)) | |
86 | (identity (machine-ssh-configuration-identity config))) | |
87 | (open-ssh-session host-name | |
88 | #:user user | |
89 | #:port port | |
90 | #:identity identity))))) | |
91 | ||
92 | \f | |
93 | ;;; | |
94 | ;;; Remote evaluation. | |
95 | ;;; | |
96 | ||
97 | (define (managed-host-remote-eval machine exp) | |
98 | "Internal implementation of 'machine-remote-eval' for MACHINE instances with | |
99 | an environment type of 'managed-host." | |
100 | (maybe-raise-unsupported-configuration-error machine) | |
101 | (remote-eval exp (machine-ssh-session machine))) | |
102 | ||
103 | \f | |
104 | ;;; | |
105 | ;;; System deployment. | |
106 | ;;; | |
107 | ||
108 | (define (switch-to-system machine) | |
109 | "Monadic procedure creating a new generation on MACHINE and execute the | |
110 | activation script for the new system configuration." | |
111 | (define (remote-exp drv script) | |
112 | (with-extensions (list guile-gcrypt) | |
113 | (with-imported-modules (source-module-closure '((guix config) | |
114 | (guix profiles) | |
115 | (guix utils))) | |
116 | #~(begin | |
117 | (use-modules (guix config) | |
118 | (guix profiles) | |
119 | (guix utils)) | |
120 | ||
121 | (define %system-profile | |
122 | (string-append %state-directory "/profiles/system")) | |
123 | ||
124 | (let* ((system #$drv) | |
125 | (number (1+ (generation-number %system-profile))) | |
126 | (generation (generation-file-name %system-profile number))) | |
127 | (switch-symlinks generation system) | |
128 | (switch-symlinks %system-profile generation) | |
129 | ;; The implementation of 'guix system reconfigure' saves the | |
130 | ;; load path and environment here. This is unnecessary here | |
131 | ;; because each invocation of 'remote-eval' runs in a distinct | |
132 | ;; Guile REPL. | |
133 | (setenv "GUIX_NEW_SYSTEM" system) | |
134 | ;; The activation script may write to stdout, which confuses | |
135 | ;; 'remote-eval' when it attempts to read a result from the | |
136 | ;; remote REPL. We work around this by forcing the output to a | |
137 | ;; string. | |
138 | (with-output-to-string | |
139 | (lambda () | |
140 | (primitive-load #$script)))))))) | |
141 | ||
142 | (let* ((os (machine-system machine)) | |
143 | (script (operating-system-activation-script os))) | |
144 | (mlet* %store-monad ((drv (operating-system-derivation os))) | |
145 | (machine-remote-eval machine (remote-exp drv script))))) | |
146 | ||
147 | ;; XXX: Currently, this does NOT attempt to restart running services. This is | |
148 | ;; also the case with 'guix system reconfigure'. | |
149 | ;; | |
150 | ;; See <https://issues.guix.info/issue/33508>. | |
151 | (define (upgrade-shepherd-services machine) | |
152 | "Monadic procedure unloading and starting services on the remote as needed | |
153 | to realize the MACHINE's system configuration." | |
154 | (define target-services | |
155 | ;; Monadic expression evaluating to a list of (name output-path) pairs for | |
156 | ;; all of MACHINE's services. | |
157 | (mapm %store-monad | |
158 | (lambda (service) | |
159 | (mlet %store-monad ((file ((compose lower-object | |
160 | shepherd-service-file) | |
161 | service))) | |
162 | (return (list (shepherd-service-canonical-name service) | |
163 | (derivation->output-path file))))) | |
164 | (service-value | |
165 | (fold-services (operating-system-services (machine-system machine)) | |
166 | #:target-type shepherd-root-service-type)))) | |
167 | ||
168 | (define (remote-exp target-services) | |
169 | (with-imported-modules '((gnu services herd)) | |
170 | #~(begin | |
171 | (use-modules (gnu services herd) | |
172 | (srfi srfi-1)) | |
173 | ||
174 | (define running | |
175 | (filter live-service-running (current-services))) | |
176 | ||
177 | (define (essential? service) | |
178 | ;; Return #t if SERVICE is essential and should not be unloaded | |
179 | ;; under any circumstance. | |
180 | (memq (first (live-service-provision service)) | |
181 | '(root shepherd))) | |
182 | ||
183 | (define (obsolete? service) | |
184 | ;; Return #t if SERVICE can be safely unloaded. | |
185 | (and (not (essential? service)) | |
186 | (every (lambda (requirements) | |
187 | (not (memq (first (live-service-provision service)) | |
188 | requirements))) | |
189 | (map live-service-requirement running)))) | |
190 | ||
191 | (define to-unload | |
192 | (filter obsolete? | |
193 | (remove (lambda (service) | |
194 | (memq (first (live-service-provision service)) | |
195 | (map first '#$target-services))) | |
196 | running))) | |
197 | ||
198 | (define to-start | |
199 | (remove (lambda (service-pair) | |
200 | (memq (first service-pair) | |
201 | (map (compose first live-service-provision) | |
202 | running))) | |
203 | '#$target-services)) | |
204 | ||
205 | ;; Unload obsolete services. | |
206 | (for-each (lambda (service) | |
207 | (false-if-exception | |
208 | (unload-service service))) | |
209 | to-unload) | |
210 | ||
211 | ;; Load the service files for any new services and start them. | |
212 | (load-services/safe (map second to-start)) | |
213 | (for-each start-service (map first to-start)) | |
214 | ||
215 | #t))) | |
216 | ||
217 | (mlet %store-monad ((target-services target-services)) | |
218 | (machine-remote-eval machine (remote-exp target-services)))) | |
219 | ||
220 | (define (machine-boot-parameters machine) | |
221 | "Monadic procedure returning a list of 'boot-parameters' for the generations | |
222 | of MACHINE's system profile, ordered from most recent to oldest." | |
223 | (define bootable-kernel-arguments | |
224 | (@@ (gnu system) bootable-kernel-arguments)) | |
225 | ||
226 | (define remote-exp | |
227 | (with-extensions (list guile-gcrypt) | |
228 | (with-imported-modules (source-module-closure '((guix config) | |
229 | (guix profiles))) | |
230 | #~(begin | |
231 | (use-modules (guix config) | |
232 | (guix profiles) | |
233 | (ice-9 textual-ports)) | |
234 | ||
235 | (define %system-profile | |
236 | (string-append %state-directory "/profiles/system")) | |
237 | ||
238 | (define (read-file path) | |
239 | (call-with-input-file path | |
240 | (lambda (port) | |
241 | (get-string-all port)))) | |
242 | ||
243 | (map (lambda (generation) | |
244 | (let* ((system-path (generation-file-name %system-profile | |
245 | generation)) | |
246 | (boot-parameters-path (string-append system-path | |
247 | "/parameters")) | |
248 | (time (stat:mtime (lstat system-path)))) | |
249 | (list generation | |
250 | system-path | |
251 | time | |
252 | (read-file boot-parameters-path)))) | |
253 | (reverse (generation-numbers %system-profile))))))) | |
254 | ||
255 | (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp))) | |
256 | (return | |
257 | (map (lambda (generation) | |
258 | (match generation | |
259 | ((generation system-path time serialized-params) | |
260 | (let* ((params (call-with-input-string serialized-params | |
261 | read-boot-parameters)) | |
262 | (root (boot-parameters-root-device params)) | |
263 | (label (boot-parameters-label params))) | |
264 | (boot-parameters | |
265 | (inherit params) | |
266 | (label | |
267 | (string-append label " (#" | |
268 | (number->string generation) ", " | |
269 | (let ((time (make-time time-utc 0 time))) | |
270 | (date->string (time-utc->date time) | |
271 | "~Y-~m-~d ~H:~M")) | |
272 | ")")) | |
273 | (kernel-arguments | |
274 | (append (bootable-kernel-arguments system-path root) | |
275 | (boot-parameters-kernel-arguments params)))))))) | |
276 | generations)))) | |
277 | ||
278 | (define (install-bootloader machine) | |
279 | "Create a bootloader entry for the new system generation on MACHINE, and | |
280 | configure the bootloader to boot that generation by default." | |
281 | (define bootloader-installer-script | |
282 | (@@ (guix scripts system) bootloader-installer-script)) | |
283 | ||
284 | (define (remote-exp installer bootcfg bootcfg-file) | |
285 | (with-extensions (list guile-gcrypt) | |
286 | (with-imported-modules (source-module-closure '((gnu build install) | |
287 | (guix store) | |
288 | (guix utils))) | |
289 | #~(begin | |
290 | (use-modules (gnu build install) | |
291 | (guix store) | |
292 | (guix utils)) | |
293 | (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg")) | |
294 | (temp-gc-root (string-append gc-root ".new"))) | |
295 | ||
296 | (switch-symlinks temp-gc-root gc-root) | |
297 | ||
298 | (unless (false-if-exception | |
299 | (begin | |
300 | ;; The implementation of 'guix system reconfigure' | |
301 | ;; saves the load path here. This is unnecessary here | |
302 | ;; because each invocation of 'remote-eval' runs in a | |
303 | ;; distinct Guile REPL. | |
304 | (install-boot-config #$bootcfg #$bootcfg-file "/") | |
305 | ;; The installation script may write to stdout, which | |
306 | ;; confuses 'remote-eval' when it attempts to read a | |
307 | ;; result from the remote REPL. We work around this | |
308 | ;; by forcing the output to a string. | |
309 | (with-output-to-string | |
310 | (lambda () | |
311 | (primitive-load #$installer))))) | |
312 | (delete-file temp-gc-root) | |
313 | (error "failed to install bootloader")) | |
314 | ||
315 | (rename-file temp-gc-root gc-root) | |
316 | #t))))) | |
317 | ||
318 | (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))) | |
319 | (let* ((os (machine-system machine)) | |
320 | (bootloader ((compose bootloader-configuration-bootloader | |
321 | operating-system-bootloader) | |
322 | os)) | |
323 | (bootloader-target (bootloader-configuration-target | |
324 | (operating-system-bootloader os))) | |
325 | (installer (bootloader-installer-script | |
326 | (bootloader-installer bootloader) | |
327 | (bootloader-package bootloader) | |
328 | bootloader-target | |
329 | "/")) | |
330 | (menu-entries (map boot-parameters->menu-entry boot-parameters)) | |
331 | (bootcfg (operating-system-bootcfg os menu-entries)) | |
332 | (bootcfg-file (bootloader-configuration-file bootloader))) | |
333 | (machine-remote-eval machine (remote-exp installer bootcfg bootcfg-file))))) | |
334 | ||
335 | (define (deploy-managed-host machine) | |
336 | "Internal implementation of 'deploy-machine' for MACHINE instances with an | |
337 | environment type of 'managed-host." | |
338 | (maybe-raise-unsupported-configuration-error machine) | |
339 | (mbegin %store-monad | |
340 | (switch-to-system machine) | |
341 | (upgrade-shepherd-services machine) | |
342 | (install-bootloader machine))) | |
343 | ||
344 | \f | |
345 | ;;; | |
346 | ;;; Environment type. | |
347 | ;;; | |
348 | ||
349 | (define managed-host-environment-type | |
350 | (environment-type | |
351 | (machine-remote-eval managed-host-remote-eval) | |
352 | (deploy-machine deploy-managed-host) | |
353 | (name 'managed-host-environment-type) | |
354 | (description "Provisioning for machines that are accessable over SSH | |
355 | and have a known host-name. This entails little more than maintaining an SSH | |
356 | connection to the host."))) | |
357 | ||
358 | (define (maybe-raise-unsupported-configuration-error machine) | |
359 | "Raise an error if MACHINE's configuration is not an instance of | |
360 | <machine-ssh-configuration>." | |
361 | (let ((config (machine-configuration machine)) | |
362 | (environment (environment-type-name (machine-environment machine)))) | |
363 | (unless (and config (machine-ssh-configuration? config)) | |
364 | (raise (condition | |
365 | (&message | |
366 | (message (format #f (G_ "unsupported machine configuration '~a' | |
367 | for environment of type '~a'") | |
368 | config | |
369 | environment)))))))) |