projects/guix·blob wip-full-source-bootstrap · refs

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