projects/guix·blob version-1.4.0 · refs

641 lines · 27.0 KiB

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