projects/guix·blob javascript-team · refs

659 lines · 28.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019 Jakob L. Kreuze <[email protected]>
3;;; Copyright © 2020-2024 Ludovic Courtès <[email protected]>
4;;; Copyright © 2024 Ricardo <[email protected]>
5;;; Copyright © 2025 Arun Isaac <[email protected]>
6;;;
7;;; This file is part of GNU Guix.
8;;;
9;;; GNU Guix is free software; you can redistribute it and/or modify it
10;;; under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 3 of the License, or (at
12;;; your option) any later version.
13;;;
14;;; GNU Guix is distributed in the hope that it will be useful, but
15;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;;
24;;; This module implements remote evaluation and system deployment for
25;;; machines that are accessible over SSH and have a known host-name. In the
26;;; sense of the broader "machine" interface, we describe the environment for
27;;; such machines as 'managed-host.
28;;;
29;;; Code:
30
31(define-module (gnu machine ssh)
32 #:use-module (gnu bootloader)
33 #:use-module (gnu machine)
34 #:autoload (gnu packages gnupg) (guile-gcrypt)
35 #:use-module (gnu system)
36 #:use-module (gnu system file-systems)
37 #:use-module (gnu system uuid)
38 #:use-module ((gnu services) #:select (sexp->system-provenance))
39 #:use-module (guix diagnostics)
40 #:use-module (guix memoization)
41 #:use-module (guix gexp)
42 #:use-module (guix i18n)
43 #:use-module (guix modules)
44 #:use-module (guix monads)
45 #:use-module (guix pki)
46 #:use-module (guix records)
47 #:use-module (guix remote)
48 #:use-module (guix scripts system reconfigure)
49 #:use-module (guix ssh)
50 #:use-module (guix store)
51 #:use-module (guix utils)
52 #:use-module ((guix self) #:select (make-config.scm))
53 #:use-module ((guix inferior)
54 #:select (inferior-exception?
55 inferior-exception-arguments))
56 #:use-module ((guix platform) #:select (systems))
57 #:use-module (gcrypt pk-crypto)
58 #:use-module (ice-9 format)
59 #:use-module (ice-9 match)
60 #:use-module (ice-9 textual-ports)
61 #:use-module (srfi srfi-1)
62 #:use-module (srfi srfi-9)
63 #:use-module (srfi srfi-19)
64 #:use-module (srfi srfi-26)
65 #:use-module (srfi srfi-34)
66 #:use-module (srfi srfi-35)
67 #:export (managed-host-environment-type
68
69 machine-ssh-configuration
70 machine-ssh-configuration?
71 machine-ssh-configuration
72
73 machine-ssh-configuration-host-name
74 machine-ssh-configuration-build-locally?
75 machine-ssh-configuration-authorize?
76 machine-ssh-configuration-allow-downgrades?
77 machine-ssh-configuration-port
78 machine-ssh-configuration-user
79 machine-ssh-configuration-host-key
80 machine-ssh-configuration-session))
81
82
83;;;
84;;; Parameters for the SSH client.
85;;;
86
87(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
88 make-machine-ssh-configuration
89 machine-ssh-configuration?
90 this-machine-ssh-configuration
91 (host-name machine-ssh-configuration-host-name) ; string
92 (system machine-ssh-configuration-system ; string
93 (sanitize validate-system-type))
94 (build-locally? machine-ssh-configuration-build-locally? ; boolean
95 (default #t))
96 (authorize? machine-ssh-configuration-authorize? ; boolean
97 (default #t))
98 (allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean
99 (default #f))
100 (safety-checks? machine-ssh-configuration-safety-checks? ;boolean
101 (default #t))
102 (port machine-ssh-configuration-port ; integer
103 (default 22))
104 (user machine-ssh-configuration-user ; string
105 (default "root"))
106 (identity machine-ssh-configuration-identity ; path to a private key
107 (default #f))
108 (session machine-ssh-configuration-session ; session
109 (thunked)
110 (default
111 ;; By default, open the session once and cache it.
112 (open-machine-ssh-session* this-machine-ssh-configuration)))
113 (host-key machine-ssh-configuration-host-key ; #f | string
114 (default #f)))
115
116(define-with-syntax-properties (validate-system-type (value properties))
117 ;; Raise an error if VALUE is not a valid system type.
118 (unless (string? value)
119 (raise (make-compound-condition
120 (condition
121 (&error-location
122 (location (source-properties->location properties))))
123 (formatted-message
124 (G_ "~a: invalid system type; must be a string")
125 value))))
126 (unless (member value (systems))
127 (raise (apply make-compound-condition
128 (condition
129 (&error-location
130 (location (source-properties->location properties))))
131 (formatted-message (G_ "~a: unknown system type") value)
132 (let ((closest (string-closest value (systems)
133 #:threshold 5)))
134 (if closest
135 (list (condition
136 (&fix-hint
137 (hint (format #f (G_ "Did you mean @code{~a}?")
138 closest)))))
139 '())))))
140 value)
141
142(define (open-machine-ssh-session config)
143 "Open an SSH session for CONFIG, a <machine-ssh-configuration> record."
144 (let ((host-name (machine-ssh-configuration-host-name config))
145 (user (machine-ssh-configuration-user config))
146 (port (machine-ssh-configuration-port config))
147 (identity (machine-ssh-configuration-identity config))
148 (host-key (machine-ssh-configuration-host-key config)))
149 (unless host-key
150 (warning (G_ "<machine-ssh-configuration> without a 'host-key' \
151is deprecated~%")))
152 (open-ssh-session host-name
153 #:user user
154 #:port port
155 #:identity identity
156 #:host-key host-key)))
157
158(define open-machine-ssh-session*
159 (mlambdaq (config)
160 "Memoizing variant of 'open-machine-ssh-session'."
161 (open-machine-ssh-session config)))
162
163(define (machine-ssh-session machine)
164 "Return the SSH session that was given in MACHINE's configuration, or create
165one from the configuration's parameters if one was not provided."
166 (maybe-raise-unsupported-configuration-error machine)
167 (let ((config (machine-configuration machine)))
168 (or (machine-ssh-configuration-session config)
169 (open-machine-ssh-session config))))
170
171
172;;;
173;;; Remote evaluation.
174;;;
175
176(define (machine-become-command machine)
177 "Return as a list of strings the program and arguments necessary to run a
178shell command with escalated privileges for MACHINE's configuration."
179 (if (string= "root" (machine-ssh-configuration-user
180 (machine-configuration machine)))
181 '()
182 ;; Use the old setuid-programs location until the remote is likely to
183 ;; have the new /run/privileged one in place.
184 '("/run/setuid-programs/sudo" "-n" "--")))
185
186(define (managed-host-remote-eval machine exp)
187 "Internal implementation of 'machine-remote-eval' for MACHINE instances with
188an environment type of 'managed-host."
189 (maybe-raise-unsupported-configuration-error machine)
190 (let ((config (machine-configuration machine)))
191 (remote-eval exp (machine-ssh-session machine)
192 #:build-locally?
193 (machine-ssh-configuration-build-locally? config)
194 #:system
195 (machine-ssh-configuration-system config)
196 #:become-command
197 (machine-become-command machine))))
198
199
200;;;
201;;; Safety checks.
202;;;
203
204;; Assertion to be executed remotely. This abstraction exists to allow us to
205;; gather a list of expressions to be evaluated and eventually evaluate them
206;; all at once instead of one by one. (This is pretty much a monad.)
207(define-record-type <remote-assertion>
208 (remote-assertion exp proc)
209 remote-assertion?
210 (exp remote-assertion-expression)
211 (proc remote-assertion-procedure))
212
213(define-syntax-rule (remote-let ((var exp)) body ...)
214 "Return a <remote-assertion> that binds VAR to the result of evaluating EXP,
215a gexp, remotely, and evaluate BODY in that context."
216 (remote-assertion exp (lambda (var) body ...)))
217
218(define (machine-check-file-system-availability machine)
219 "Return a list of <remote-assertion> that raise a '&message' error condition
220if any of the file-systems specified in MACHINE's 'system' declaration do not
221exist on the machine."
222 (define file-systems
223 (filter (lambda (fs)
224 (and (file-system-mount? fs)
225 (not (member (file-system-type fs)
226 %pseudo-file-system-types))
227 ;; Don't try to validate network file systems.
228 (not (or (string-prefix? "nfs" (file-system-type fs))
229 (string-prefix? "cifs" (file-system-type fs))))
230 (not (memq 'bind-mount (file-system-flags fs)))))
231 (operating-system-file-systems (machine-operating-system machine))))
232
233 (define (check-literal-file-system fs)
234 (remote-let ((errno #~(catch 'system-error
235 (lambda ()
236 (stat #$(file-system-device fs))
237 #t)
238 (lambda args
239 (system-error-errno args)))))
240 (when (number? errno)
241 (raise (formatted-message (G_ "device '~a' not found: ~a")
242 (file-system-device fs)
243 (strerror errno))))))
244
245 (define (check-labeled-file-system fs)
246 (define remote-exp
247 (with-imported-modules (source-module-closure
248 '((gnu build file-systems)))
249 #~(begin
250 (use-modules (gnu build file-systems))
251 (find-partition-by-label #$(file-system-label->string
252 (file-system-device fs))))))
253
254 (remote-let ((result remote-exp))
255 (unless result
256 (raise (formatted-message (G_ "no file system with label '~a'")
257 (file-system-label->string
258 (file-system-device fs)))))))
259
260 (define (check-uuid-file-system fs)
261 (define remote-exp
262 (with-imported-modules (source-module-closure
263 '((gnu build file-systems)
264 (gnu system uuid)))
265 #~(begin
266 (use-modules (gnu build file-systems)
267 (gnu system uuid))
268
269 (let ((uuid (uuid #$(uuid->string (file-system-device fs))
270 '#$(uuid-type (file-system-device fs)))))
271 (find-partition-by-uuid uuid)))))
272
273 (remote-let ((result remote-exp))
274 (unless result
275 (raise (formatted-message (G_ "no file system with UUID '~a'")
276 (uuid->string (file-system-device fs)))))))
277
278 (if (machine-ssh-configuration-safety-checks?
279 (machine-configuration machine))
280 (append (map check-literal-file-system
281 (filter (lambda (fs)
282 (string? (file-system-device fs)))
283 file-systems))
284 (map check-labeled-file-system
285 (filter (lambda (fs)
286 (file-system-label? (file-system-device fs)))
287 file-systems))
288 (map check-uuid-file-system
289 (filter (lambda (fs)
290 (uuid? (file-system-device fs)))
291 file-systems)))
292 '()))
293
294(define (machine-check-initrd-modules machine)
295 "Return a list of <remote-assertion> that raise a '&message' error condition
296if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
297not available in the initrd."
298 (define file-systems
299 (filter (lambda (file-system)
300 (and (file-system-needed-for-boot? file-system)
301 (not (member (file-system-type file-system)
302 %pseudo-file-system-types))))
303 (operating-system-file-systems (machine-operating-system machine))))
304
305 (define (missing-modules fs)
306 (define remote-exp
307 (let ((device (file-system-device fs)))
308 (with-imported-modules (source-module-closure
309 '((gnu build file-systems)
310 (gnu build linux-modules)
311 (gnu system uuid)))
312 #~(begin
313 (use-modules (gnu build file-systems)
314 (gnu build linux-modules)
315 (gnu system uuid))
316
317 (define dev
318 #$(cond ((string? device) device)
319 ((uuid? device) #~(find-partition-by-uuid
320 (string->uuid
321 #$(uuid->string device))))
322 ((file-system-label? device)
323 #~(find-partition-by-label
324 #$(file-system-label->string device)))))
325
326 (missing-modules dev '#$(operating-system-initrd-modules
327 (machine-operating-system machine)))))))
328
329 (remote-let ((missing remote-exp))
330 (unless (null? missing)
331 (raise (formatted-message (G_ "missing modules for ~a:~{ ~a~}~%")
332 (file-system-device fs)
333 missing)))))
334
335 (if (machine-ssh-configuration-safety-checks?
336 (machine-configuration machine))
337 (map missing-modules file-systems)
338 '()))
339
340(define* (machine-check-forward-update machine)
341 "Check whether we are making a forward update for MACHINE. Depending on its
342'allow-upgrades?' field, raise an error or display a warning if we are
343potentially downgrading it."
344 (define config
345 (machine-configuration machine))
346
347 (define validate-reconfigure
348 (if (machine-ssh-configuration-allow-downgrades? config)
349 warn-about-backward-reconfigure
350 ensure-forward-reconfigure))
351
352 (remote-let ((provenance #~(call-with-input-file
353 "/run/current-system/provenance"
354 read)))
355 (define channels
356 (sexp->system-provenance provenance))
357
358 (check-forward-update validate-reconfigure
359 #:current-channels channels)))
360
361(define (machine-check-building-for-appropriate-system machine)
362 "Raise a '&message' error condition if MACHINE is configured to be built
363locally and the 'system' field does not match the '%current-system' reported
364by MACHINE."
365 (let ((config (machine-configuration machine))
366 (system (remote-system (machine-ssh-session machine))))
367 (when (and (machine-ssh-configuration-build-locally? config)
368 (not (string= system (machine-ssh-configuration-system config))))
369 (raise (formatted-message (G_ "incorrect target system\
370 ('~a' was given, while the system reports that it is '~a')~%")
371 (machine-ssh-configuration-system config)
372 system)))))
373
374(define (check-deployment-sanity machine)
375 "Raise a '&message' error condition if it is clear that deploying MACHINE's
376'system' declaration would fail."
377 (define assertions
378 (parameterize ((%current-system
379 (machine-ssh-configuration-system
380 (machine-configuration machine)))
381 (%current-target-system #f))
382 (append (machine-check-file-system-availability machine)
383 (machine-check-initrd-modules machine)
384 (list (machine-check-forward-update machine)))))
385
386 (define aggregate-exp
387 ;; Gather all the expressions so that a single round-trip is enough to
388 ;; evaluate all the ASSERTIONS remotely.
389 #~(map (lambda (file)
390 (false-if-exception (primitive-load file)))
391 '#$(map (lambda (assertion)
392 (scheme-file "remote-assertion.scm"
393 (remote-assertion-expression assertion)))
394 assertions)))
395
396 ;; First check MACHINE's system type--an incorrect value for 'system' would
397 ;; cause subsequent invocations of 'remote-eval' to fail.
398 (machine-check-building-for-appropriate-system machine)
399
400 (mlet %store-monad ((values (machine-remote-eval machine aggregate-exp)))
401 (for-each (lambda (proc value)
402 (proc value))
403 (map remote-assertion-procedure assertions)
404 values)
405 (return #t)))
406
407
408;;;
409;;; System deployment.
410;;;
411
412(define not-config?
413 ;; Select (guix …) and (gnu …) modules, except (guix config).
414 (match-lambda
415 (('guix 'config) #f)
416 (('guix _ ...) #t)
417 (('gnu _ ...) #t)
418 (_ #f)))
419
420(define (machine-boot-parameters machine)
421 "Monadic procedure returning a list of 'boot-parameters' for the generations
422of MACHINE's system profile, ordered from most recent to oldest."
423 (define bootable-kernel-arguments
424 (@@ (gnu system) bootable-kernel-arguments))
425
426 (define remote-exp
427 (with-extensions (list guile-gcrypt)
428 (with-imported-modules `(((guix config) => ,(make-config.scm))
429 ,@(source-module-closure
430 '((guix profiles))
431 #:select? not-config?))
432 #~(begin
433 (use-modules (guix config)
434 (guix profiles)
435 (ice-9 textual-ports))
436
437 (define %system-profile
438 (string-append %state-directory "/profiles/system"))
439
440 (define (read-file path)
441 (call-with-input-file path
442 (lambda (port)
443 (get-string-all port))))
444
445 (map (lambda (generation)
446 (let* ((system-path (generation-file-name %system-profile
447 generation))
448 (boot-parameters-path (string-append system-path
449 "/parameters"))
450 (time (stat:mtime (lstat system-path))))
451 (list generation
452 system-path
453 time
454 (read-file boot-parameters-path))))
455 (reverse (generation-numbers %system-profile)))))))
456
457 (mlet* %store-monad ((generations (machine-remote-eval machine remote-exp)))
458 (return
459 (map (lambda (generation)
460 (match generation
461 ((generation system-path time serialized-params)
462 (let* ((params (call-with-input-string serialized-params
463 read-boot-parameters))
464 (root (boot-parameters-root-device params))
465 (label (boot-parameters-label params))
466 (version (boot-parameters-version params)))
467 (boot-parameters
468 (inherit params)
469 (label
470 (string-append label " (#"
471 (number->string generation) ", "
472 (let ((time (make-time time-utc 0 time)))
473 (date->string (time-utc->date time)
474 "~Y-~m-~d ~H:~M"))
475 ")"))
476 (kernel-arguments
477 (append (bootable-kernel-arguments system-path root version)
478 (boot-parameters-kernel-arguments params))))))))
479 generations))))
480
481(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
482 "Catch exceptions that arise when binding MBODY, a monadic expression in
483%STORE-MONAD, and collect their arguments in a &deploy-error condition, with
484the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
485 (catch #t
486 (lambda ()
487 mbody ...)
488 (lambda args
489 (raise (condition (&deploy-error
490 (should-roll-back should-roll-back?)
491 (captured-args args)))))))
492
493(define (deploy-managed-host machine)
494 "Internal implementation of 'deploy-machine' for MACHINE instances with an
495environment type of 'managed-host."
496 (define config (machine-configuration machine))
497 (define host (machine-ssh-configuration-host-name config))
498 (define system (machine-ssh-configuration-system config))
499
500 (maybe-raise-unsupported-configuration-error machine)
501 (when (machine-ssh-configuration-authorize?
502 (machine-configuration machine))
503 (unless (file-exists? %public-key-file)
504 (raise (formatted-message (G_ "no signing key '~a'. \
505Have you run 'guix archive --generate-key'?")
506 %public-key-file)))
507 (remote-authorize-signing-key (call-with-input-file %public-key-file
508 (lambda (port)
509 (string->canonical-sexp
510 (get-string-all port))))
511 (machine-ssh-session machine)
512 (machine-become-command machine)))
513
514 (mlet %store-monad ((_ (check-deployment-sanity machine))
515 (boot-parameters (machine-boot-parameters machine)))
516 ;; Make sure code that check %CURRENT-SYSTEM, such as
517 ;; %BASE-INITRD-MODULES, gets to see the right value.
518 (parameterize ((%current-system system)
519 (%current-target-system #f))
520 (let* ((os (machine-operating-system machine))
521 (eval (cut machine-remote-eval machine <>))
522 (menu-entries (map boot-parameters->menu-entry boot-parameters))
523 (bootloader-configuration (operating-system-bootloader os))
524 (bootcfg (operating-system-bootcfg os menu-entries)))
525 (define-syntax-rule (eval/error-handling condition handler ...)
526 ;; Return a wrapper around EVAL such that HANDLER is evaluated if an
527 ;; exception is raised.
528 (lambda (exp)
529 (lambda (store)
530 (guard (condition ((inferior-exception? condition)
531 (values (begin handler ...) store)))
532 (values (run-with-store store (eval exp)
533 #:system system)
534 store)))))
535
536 (mbegin %store-monad
537 (with-roll-back #f
538 (switch-to-system (eval/error-handling c
539 (raise (formatted-message
540 (G_ "\
541failed to switch systems while deploying '~a':~%~{~s ~}")
542 host
543 (inferior-exception-arguments c))))
544 os))
545 (store-parameterize ((%current-system system)
546 (%current-target-system #f))
547 (with-roll-back #t
548 (mbegin %store-monad
549 (upgrade-shepherd-services (eval/error-handling c
550 (warning (G_ "\
551an error occurred while upgrading services on '~a':~%~{~s ~}~%")
552 host
553 (inferior-exception-arguments
554 c)))
555 os)
556 (load-system-for-kexec (eval/error-handling c
557 (warning (G_ "\
558failed to load system of '~a' for kexec reboot:~%~{~s~^ ~}~%")
559 host
560 (inferior-exception-arguments
561 c)))
562 os)
563 (install-bootloader (eval/error-handling c
564 (raise (formatted-message
565 (G_ "\
566failed to install bootloader on '~a':~%~{~s ~}~%")
567 host
568 (inferior-exception-arguments c))))
569 bootloader-configuration bootcfg)))))))))
570
571
572;;;
573;;; Roll-back.
574;;;
575
576(define (roll-back-managed-host machine)
577 "Internal implementation of 'roll-back-machine' for MACHINE instances with
578an environment type of 'managed-host."
579 (define remote-exp
580 (with-extensions (list guile-gcrypt)
581 (with-imported-modules (source-module-closure '((guix config)
582 (guix profiles)))
583 #~(begin
584 (use-modules (guix config)
585 (guix profiles))
586
587 (define %system-profile
588 (string-append %state-directory "/profiles/system"))
589
590 (define target-generation
591 (relative-generation %system-profile -1))
592
593 (if target-generation
594 (switch-to-generation %system-profile target-generation)
595 'error)))))
596
597 (define roll-back-failure
598 (condition (&message (message (G_ "could not roll-back machine")))))
599
600 (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine))
601 (_ -> (if (< (length boot-parameters) 2)
602 (raise roll-back-failure)))
603 (entries -> (map boot-parameters->menu-entry
604 (list (second boot-parameters))))
605 (locale -> (boot-parameters-locale
606 (second boot-parameters)))
607 (crypto-dev -> (boot-parameters-store-crypto-devices
608 (second boot-parameters)))
609 (store-dir -> (boot-parameters-store-directory-prefix
610 (second boot-parameters)))
611 (old-entries -> (map boot-parameters->menu-entry
612 (drop boot-parameters 2)))
613 (bootloader -> (operating-system-bootloader
614 (machine-operating-system machine)))
615 (bootcfg (lower-object
616 ((bootloader-configuration-file-generator
617 (bootloader-configuration-bootloader
618 bootloader))
619 bootloader entries
620 #:locale locale
621 #:store-crypto-devices crypto-dev
622 #:store-directory-prefix store-dir
623 #:old-entries old-entries)))
624 (remote-result (machine-remote-eval machine remote-exp)))
625 (if (eqv? 'error remote-result)
626 (raise roll-back-failure)
627 (return remote-result))))
628
629
630;;;
631;;; Environment type.
632;;;
633
634(define managed-host-environment-type
635 (environment-type
636 (machine-remote-eval managed-host-remote-eval)
637 (deploy-machine deploy-managed-host)
638 (roll-back-machine roll-back-managed-host)
639 (name 'managed-host-environment-type)
640 (description "Provisioning for machines that are accessible over SSH
641and have a known host-name. This entails little more than maintaining an SSH
642connection to the host.")))
643
644(define (maybe-raise-unsupported-configuration-error machine)
645 "Raise an error if MACHINE's configuration is not an instance of
646<machine-ssh-configuration>."
647 (let ((config (machine-configuration machine))
648 (environment (environment-type-name (machine-environment machine))))
649 (unless (and config (machine-ssh-configuration? config))
650 (raise (formatted-message (G_ "unsupported machine configuration '~a'
651for environment of type '~a'")
652 config
653 environment)))))
654
655;; Local Variables:
656;; eval: (put 'remote-let 'scheme-indent-function 1)
657;; eval: (put 'with-roll-back 'scheme-indent-function 1)
658;; eval: (put 'eval/error-handling 'scheme-indent-function 1)
659;; End: