mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
689cca0c75
Sorry this is a massive commit. It's kinda impossible to split it without either completely breaking basic functionality or making a buggy shim layer that's written just to be immediately removed. But anyway, this is the real body of the bootloader subsystem update. One of my favorite new things possible with this is easy generation of disk images using arbitrary bootloaders, including ones that require one or more data/install partitions, such as p-boot or depthcharge! * gnu/build/image.scm (initialize-root-partition): Don't install bootloader here. (make-iso9660-image): Pull in grub.dir instead of a bootcfg. * gnu/build/install.scm (install-boot-config): Delete procedure. * gnu/machine/ssh.scm (deploy-managed-host, roll-back-managed-host): Use new bootloader system. (operating-system)[bootloader]: Use wrap-element sanitizer and support multiple bootloaders. (operating-system-bootcfg): Rename to... (operating-system-bootmeta): ...this. Rewrite to return relevant information instead of calling the config procedure directly. (operating-system-boot-parameters): Support multiple bootloaders. * gnu/system/boot.scm (read-boot-parameters): Support multiple bootloaders. * gnu/system/image.scm (root-partition-index): Delete procedure. (system-disk-image, system-iso9960-image): Support new bootloader system. (system-disk-image)[targets]: New subprocedure. * guix/scripts/system.scm (install, install-bootloader-from-provenance, perform-action): Support multiple bootloaders and work with new bootloader system instead of bootcfgs. (display-system-generation): Support multiple bootloaders. * guix/scripts/system/reconfigure.scm (install-bootloader-program): Rewrite to simply insert each bootloader's installer in the gexp directly, instead of copying bootcfgs. (install-bootloader): Work with new bootloader system. Just in case, add install-bootloader.scm to the gc roots too. Change-Id: I3654d160f7306bb45a78b82ea6b249ff4281f739
640 lines
26 KiB
Scheme
640 lines
26 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
|
||
;;; Copyright © 2020-2023 Ludovic Courtès <ludo@gnu.org>
|
||
;;; Copyright © 2024 Ricardo <rekado@elephly.net>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (gnu machine ssh)
|
||
#:use-module (gnu bootloader)
|
||
#:use-module (gnu machine)
|
||
#:autoload (gnu packages gnupg) (guile-gcrypt)
|
||
#:use-module (gnu system)
|
||
#:use-module (gnu system boot)
|
||
#:use-module (gnu system file-systems)
|
||
#:use-module (gnu system uuid)
|
||
#:use-module ((gnu services) #:select (sexp->system-provenance))
|
||
#:use-module (guix diagnostics)
|
||
#:use-module (guix memoization)
|
||
#:use-module (guix gexp)
|
||
#:use-module (guix i18n)
|
||
#:use-module (guix modules)
|
||
#:use-module (guix monads)
|
||
#:use-module (guix pki)
|
||
#:use-module (guix records)
|
||
#:use-module (guix remote)
|
||
#:use-module (guix scripts system reconfigure)
|
||
#:use-module (guix ssh)
|
||
#:use-module (guix store)
|
||
#:use-module (guix utils)
|
||
#:use-module ((guix self) #:select (make-config.scm))
|
||
#:use-module ((guix inferior)
|
||
#:select (inferior-exception?
|
||
inferior-exception-arguments))
|
||
#:use-module ((guix platform) #:select (systems))
|
||
#:use-module (gcrypt pk-crypto)
|
||
#:use-module (ice-9 format)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 textual-ports)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-9)
|
||
#:use-module (srfi srfi-19)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (srfi srfi-34)
|
||
#:use-module (srfi srfi-35)
|
||
#:export (managed-host-environment-type
|
||
|
||
machine-ssh-configuration
|
||
machine-ssh-configuration?
|
||
machine-ssh-configuration
|
||
|
||
machine-ssh-configuration-host-name
|
||
machine-ssh-configuration-build-locally?
|
||
machine-ssh-configuration-authorize?
|
||
machine-ssh-configuration-allow-downgrades?
|
||
machine-ssh-configuration-port
|
||
machine-ssh-configuration-user
|
||
machine-ssh-configuration-host-key
|
||
machine-ssh-configuration-session))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; This module implements remote evaluation and system deployment for
|
||
;;; machines that are accessible over SSH and have a known host-name. In the
|
||
;;; sense of the broader "machine" interface, we describe the environment for
|
||
;;; such machines as 'managed-host.
|
||
;;;
|
||
;;; Code:
|
||
|
||
|
||
;;;
|
||
;;; Parameters for the SSH client.
|
||
;;;
|
||
|
||
(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
|
||
make-machine-ssh-configuration
|
||
machine-ssh-configuration?
|
||
this-machine-ssh-configuration
|
||
(host-name machine-ssh-configuration-host-name) ; string
|
||
(system machine-ssh-configuration-system ; string
|
||
(sanitize validate-system-type))
|
||
(build-locally? machine-ssh-configuration-build-locally? ; boolean
|
||
(default #t))
|
||
(authorize? machine-ssh-configuration-authorize? ; boolean
|
||
(default #t))
|
||
(allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean
|
||
(default #f))
|
||
(safety-checks? machine-ssh-configuration-safety-checks? ;boolean
|
||
(default #t))
|
||
(port machine-ssh-configuration-port ; integer
|
||
(default 22))
|
||
(user machine-ssh-configuration-user ; string
|
||
(default "root"))
|
||
(identity machine-ssh-configuration-identity ; path to a private key
|
||
(default #f))
|
||
(session machine-ssh-configuration-session ; session
|
||
(thunked)
|
||
(default
|
||
;; By default, open the session once and cache it.
|
||
(open-machine-ssh-session* this-machine-ssh-configuration)))
|
||
(host-key machine-ssh-configuration-host-key ; #f | string
|
||
(default #f)))
|
||
|
||
(define-with-syntax-properties (validate-system-type (value properties))
|
||
;; Raise an error if VALUE is not a valid system type.
|
||
(unless (string? value)
|
||
(raise (make-compound-condition
|
||
(condition
|
||
(&error-location
|
||
(location (source-properties->location properties))))
|
||
(formatted-message
|
||
(G_ "~a: invalid system type; must be a string")
|
||
value))))
|
||
(unless (member value (systems))
|
||
(raise (apply make-compound-condition
|
||
(condition
|
||
(&error-location
|
||
(location (source-properties->location properties))))
|
||
(formatted-message (G_ "~a: unknown system type") value)
|
||
(let ((closest (string-closest value (systems)
|
||
#:threshold 5)))
|
||
(if closest
|
||
(list (condition
|
||
(&fix-hint
|
||
(hint (format #f (G_ "Did you mean @code{~a}?")
|
||
closest)))))
|
||
'())))))
|
||
value)
|
||
|
||
(define (open-machine-ssh-session config)
|
||
"Open an SSH session for CONFIG, a <machine-ssh-configuration> record."
|
||
(let ((host-name (machine-ssh-configuration-host-name config))
|
||
(user (machine-ssh-configuration-user config))
|
||
(port (machine-ssh-configuration-port config))
|
||
(identity (machine-ssh-configuration-identity config))
|
||
(host-key (machine-ssh-configuration-host-key config)))
|
||
(unless host-key
|
||
(warning (G_ "<machine-ssh-configuration> without a 'host-key' \
|
||
is deprecated~%")))
|
||
(open-ssh-session host-name
|
||
#:user user
|
||
#:port port
|
||
#:identity identity
|
||
#:host-key host-key)))
|
||
|
||
(define open-machine-ssh-session*
|
||
(mlambdaq (config)
|
||
"Memoizing variant of 'open-machine-ssh-session'."
|
||
(open-machine-ssh-session config)))
|
||
|
||
(define (machine-ssh-session machine)
|
||
"Return the SSH session that was given in MACHINE's configuration, or create
|
||
one from the configuration's parameters if one was not provided."
|
||
(maybe-raise-unsupported-configuration-error machine)
|
||
(let ((config (machine-configuration machine)))
|
||
(or (machine-ssh-configuration-session config)
|
||
(open-machine-ssh-session config))))
|
||
|
||
|
||
;;;
|
||
;;; Remote evaluation.
|
||
;;;
|
||
|
||
(define (machine-become-command machine)
|
||
"Return as a list of strings the program and arguments necessary to run a
|
||
shell command with escalated privileges for MACHINE's configuration."
|
||
(if (string= "root" (machine-ssh-configuration-user
|
||
(machine-configuration machine)))
|
||
'()
|
||
;; Use the old setuid-programs location until the remote is likely to
|
||
;; have the new /run/privileged one in place.
|
||
'("/run/setuid-programs/sudo" "-n" "--")))
|
||
|
||
(define (managed-host-remote-eval machine exp)
|
||
"Internal implementation of 'machine-remote-eval' for MACHINE instances with
|
||
an environment type of 'managed-host."
|
||
(maybe-raise-unsupported-configuration-error machine)
|
||
(let ((config (machine-configuration machine)))
|
||
(remote-eval exp (machine-ssh-session machine)
|
||
#:build-locally?
|
||
(machine-ssh-configuration-build-locally? config)
|
||
#:system
|
||
(machine-ssh-configuration-system config)
|
||
#:become-command
|
||
(machine-become-command machine))))
|
||
|
||
|
||
;;;
|
||
;;; Safety checks.
|
||
;;;
|
||
|
||
;; Assertion to be executed remotely. This abstraction exists to allow us to
|
||
;; gather a list of expressions to be evaluated and eventually evaluate them
|
||
;; all at once instead of one by one. (This is pretty much a monad.)
|
||
(define-record-type <remote-assertion>
|
||
(remote-assertion exp proc)
|
||
remote-assertion?
|
||
(exp remote-assertion-expression)
|
||
(proc remote-assertion-procedure))
|
||
|
||
(define-syntax-rule (remote-let ((var exp)) body ...)
|
||
"Return a <remote-assertion> that binds VAR to the result of evaluating EXP,
|
||
a gexp, remotely, and evaluate BODY in that context."
|
||
(remote-assertion exp (lambda (var) body ...)))
|
||
|
||
(define (machine-check-file-system-availability machine)
|
||
"Return a list of <remote-assertion> that raise a '&message' error condition
|
||
if any of the file-systems specified in MACHINE's 'system' declaration do not
|
||
exist on the machine."
|
||
(define file-systems
|
||
(filter (lambda (fs)
|
||
(and (file-system-mount? fs)
|
||
(not (member (file-system-type fs)
|
||
%pseudo-file-system-types))
|
||
;; Don't try to validate network file systems.
|
||
(not (or (string-prefix? "nfs" (file-system-type fs))
|
||
(string-prefix? "cifs" (file-system-type fs))))
|
||
(not (memq 'bind-mount (file-system-flags fs)))))
|
||
(operating-system-file-systems (machine-operating-system machine))))
|
||
|
||
(define (check-literal-file-system fs)
|
||
(remote-let ((errno #~(catch 'system-error
|
||
(lambda ()
|
||
(stat #$(file-system-device fs))
|
||
#t)
|
||
(lambda args
|
||
(system-error-errno args)))))
|
||
(when (number? errno)
|
||
(raise (formatted-message (G_ "device '~a' not found: ~a")
|
||
(file-system-device fs)
|
||
(strerror errno))))))
|
||
|
||
(define (check-labeled-file-system fs)
|
||
(define remote-exp
|
||
(with-imported-modules (source-module-closure
|
||
'((gnu build file-systems)))
|
||
#~(begin
|
||
(use-modules (gnu build file-systems))
|
||
(find-partition-by-label #$(file-system-label->string
|
||
(file-system-device fs))))))
|
||
|
||
(remote-let ((result remote-exp))
|
||
(unless result
|
||
(raise (formatted-message (G_ "no file system with label '~a'")
|
||
(file-system-label->string
|
||
(file-system-device fs)))))))
|
||
|
||
(define (check-uuid-file-system fs)
|
||
(define remote-exp
|
||
(with-imported-modules (source-module-closure
|
||
'((gnu build file-systems)
|
||
(gnu system uuid)))
|
||
#~(begin
|
||
(use-modules (gnu build file-systems)
|
||
(gnu system uuid))
|
||
|
||
(let ((uuid (uuid #$(uuid->string (file-system-device fs))
|
||
'#$(uuid-type (file-system-device fs)))))
|
||
(find-partition-by-uuid uuid)))))
|
||
|
||
(remote-let ((result remote-exp))
|
||
(unless result
|
||
(raise (formatted-message (G_ "no file system with UUID '~a'")
|
||
(uuid->string (file-system-device fs)))))))
|
||
|
||
(if (machine-ssh-configuration-safety-checks?
|
||
(machine-configuration machine))
|
||
(append (map check-literal-file-system
|
||
(filter (lambda (fs)
|
||
(string? (file-system-device fs)))
|
||
file-systems))
|
||
(map check-labeled-file-system
|
||
(filter (lambda (fs)
|
||
(file-system-label? (file-system-device fs)))
|
||
file-systems))
|
||
(map check-uuid-file-system
|
||
(filter (lambda (fs)
|
||
(uuid? (file-system-device fs)))
|
||
file-systems)))
|
||
'()))
|
||
|
||
(define (machine-check-initrd-modules machine)
|
||
"Return a list of <remote-assertion> that raise a '&message' error condition
|
||
if any of the modules needed by 'needed-for-boot' file systems in MACHINE are
|
||
not available in the initrd."
|
||
(define file-systems
|
||
(filter (lambda (file-system)
|
||
(and (file-system-needed-for-boot? file-system)
|
||
(not (member (file-system-type file-system)
|
||
%pseudo-file-system-types))))
|
||
(operating-system-file-systems (machine-operating-system machine))))
|
||
|
||
(define (missing-modules fs)
|
||
(define remote-exp
|
||
(let ((device (file-system-device fs)))
|
||
(with-imported-modules (source-module-closure
|
||
'((gnu build file-systems)
|
||
(gnu build linux-modules)
|
||
(gnu system uuid)))
|
||
#~(begin
|
||
(use-modules (gnu build file-systems)
|
||
(gnu build linux-modules)
|
||
(gnu system uuid))
|
||
|
||
(define dev
|
||
#$(cond ((string? device) device)
|
||
((uuid? device) #~(find-partition-by-uuid
|
||
(string->uuid
|
||
#$(uuid->string device))))
|
||
((file-system-label? device)
|
||
#~(find-partition-by-label
|
||
#$(file-system-label->string device)))))
|
||
|
||
(missing-modules dev '#$(operating-system-initrd-modules
|
||
(machine-operating-system machine)))))))
|
||
|
||
(remote-let ((missing remote-exp))
|
||
(unless (null? missing)
|
||
(raise (formatted-message (G_ "missing modules for ~a:~{ ~a~}~%")
|
||
(file-system-device fs)
|
||
missing)))))
|
||
|
||
(if (machine-ssh-configuration-safety-checks?
|
||
(machine-configuration machine))
|
||
(map missing-modules file-systems)
|
||
'()))
|
||
|
||
(define* (machine-check-forward-update machine)
|
||
"Check whether we are making a forward update for MACHINE. Depending on its
|
||
'allow-upgrades?' field, raise an error or display a warning if we are
|
||
potentially downgrading it."
|
||
(define config
|
||
(machine-configuration machine))
|
||
|
||
(define validate-reconfigure
|
||
(if (machine-ssh-configuration-allow-downgrades? config)
|
||
warn-about-backward-reconfigure
|
||
ensure-forward-reconfigure))
|
||
|
||
(remote-let ((provenance #~(call-with-input-file
|
||
"/run/current-system/provenance"
|
||
read)))
|
||
(define channels
|
||
(sexp->system-provenance provenance))
|
||
|
||
(check-forward-update validate-reconfigure
|
||
#:current-channels channels)))
|
||
|
||
(define (machine-check-building-for-appropriate-system machine)
|
||
"Raise a '&message' error condition if MACHINE is configured to be built
|
||
locally and the 'system' field does not match the '%current-system' reported
|
||
by MACHINE."
|
||
(let ((config (machine-configuration machine))
|
||
(system (remote-system (machine-ssh-session machine))))
|
||
(when (and (machine-ssh-configuration-build-locally? config)
|
||
(not (string= system (machine-ssh-configuration-system config))))
|
||
(raise (formatted-message (G_ "incorrect target system\
|
||
('~a' was given, while the system reports that it is '~a')~%")
|
||
(machine-ssh-configuration-system config)
|
||
system)))))
|
||
|
||
(define (check-deployment-sanity machine)
|
||
"Raise a '&message' error condition if it is clear that deploying MACHINE's
|
||
'system' declaration would fail."
|
||
(define assertions
|
||
(parameterize ((%current-system
|
||
(machine-ssh-configuration-system
|
||
(machine-configuration machine)))
|
||
(%current-target-system #f))
|
||
(append (machine-check-file-system-availability machine)
|
||
(machine-check-initrd-modules machine)
|
||
(list (machine-check-forward-update machine)))))
|
||
|
||
(define aggregate-exp
|
||
;; Gather all the expressions so that a single round-trip is enough to
|
||
;; evaluate all the ASSERTIONS remotely.
|
||
#~(map (lambda (file)
|
||
(false-if-exception (primitive-load file)))
|
||
'#$(map (lambda (assertion)
|
||
(scheme-file "remote-assertion.scm"
|
||
(remote-assertion-expression assertion)))
|
||
assertions)))
|
||
|
||
;; First check MACHINE's system type--an incorrect value for 'system' would
|
||
;; cause subsequent invocations of 'remote-eval' to fail.
|
||
(machine-check-building-for-appropriate-system machine)
|
||
|
||
(mlet %store-monad ((values (machine-remote-eval machine aggregate-exp)))
|
||
(for-each (lambda (proc value)
|
||
(proc value))
|
||
(map remote-assertion-procedure assertions)
|
||
values)
|
||
(return #t)))
|
||
|
||
|
||
;;;
|
||
;;; System deployment.
|
||
;;;
|
||
|
||
(define not-config?
|
||
;; Select (guix …) and (gnu …) modules, except (guix config).
|
||
(match-lambda
|
||
(('guix 'config) #f)
|
||
(('guix _ ...) #t)
|
||
(('gnu _ ...) #t)
|
||
(_ #f)))
|
||
|
||
(define (machine->boot-alternatives machine)
|
||
"Monadic procedure returning a list of <boot-alternative> records for
|
||
the generations of MACHINE's system profile, ordered from most recent to
|
||
oldest."
|
||
(define remote-exp
|
||
(with-extensions (list guile-gcrypt)
|
||
(with-imported-modules `(((guix config) => ,(make-config.scm))
|
||
,@(source-module-closure
|
||
'((guix profiles))
|
||
#:select? not-config?))
|
||
#~(begin
|
||
(use-modules (guix config)
|
||
(guix profiles)
|
||
(ice-9 textual-ports))
|
||
|
||
(define %system-profile
|
||
(string-append %state-directory "/profiles/system"))
|
||
|
||
(define (read-file path)
|
||
(call-with-input-file path
|
||
(lambda (port)
|
||
(get-string-all port))))
|
||
|
||
(map (lambda (generation)
|
||
(let* ((system-path (generation-file-name %system-profile
|
||
generation))
|
||
(boot-parameters-path (string-append system-path
|
||
"/parameters"))
|
||
(epoch (stat:mtime (lstat system-path))))
|
||
(list generation
|
||
system-path
|
||
epoch
|
||
(read-file boot-parameters-path))))
|
||
(reverse (generation-numbers %system-profile)))))))
|
||
|
||
(define remote-result->boot-alternative
|
||
(match-lambda
|
||
((generation system-path epoch serialized-params)
|
||
(boot-alternative
|
||
(generation generation)
|
||
(system-path system-path)
|
||
(epoch epoch)
|
||
(parameters
|
||
(let* ((params (call-with-input-string serialized-params
|
||
read-boot-parameters))
|
||
(root (boot-parameters-root-device params))
|
||
(text (boot-parameters-label params))
|
||
(version (boot-parameters-version params)))
|
||
(boot-parameters
|
||
(inherit params)
|
||
(label (decorated-boot-label text generation epoch))
|
||
(kernel-arguments
|
||
(append
|
||
(bootable-kernel-arguments system-path root version)
|
||
(boot-parameters-kernel-arguments params))))))))))
|
||
|
||
(mlet %store-monad
|
||
((remote-results (machine-remote-eval machine remote-exp)))
|
||
(return (map remote-result->boot-alternative remote-results))))
|
||
|
||
(define-syntax-rule (with-roll-back should-roll-back? mbody ...)
|
||
"Catch exceptions that arise when binding MBODY, a monadic expression in
|
||
%STORE-MONAD, and collect their arguments in a &deploy-error condition, with
|
||
the 'should-roll-back' field set to SHOULD-ROLL-BACK?"
|
||
(catch #t
|
||
(lambda ()
|
||
mbody ...)
|
||
(lambda args
|
||
(raise (condition (&deploy-error
|
||
(should-roll-back should-roll-back?)
|
||
(captured-args args)))))))
|
||
|
||
(define (deploy-managed-host machine)
|
||
"Internal implementation of 'deploy-machine' for MACHINE instances with an
|
||
environment type of 'managed-host."
|
||
(define config (machine-configuration machine))
|
||
(define host (machine-ssh-configuration-host-name config))
|
||
(define system (machine-ssh-configuration-system config))
|
||
|
||
(maybe-raise-unsupported-configuration-error machine)
|
||
(when (machine-ssh-configuration-authorize?
|
||
(machine-configuration machine))
|
||
(unless (file-exists? %public-key-file)
|
||
(raise (formatted-message (G_ "no signing key '~a'. \
|
||
Have you run 'guix archive --generate-key'?")
|
||
%public-key-file)))
|
||
(remote-authorize-signing-key (call-with-input-file %public-key-file
|
||
(lambda (port)
|
||
(string->canonical-sexp
|
||
(get-string-all port))))
|
||
(machine-ssh-session machine)
|
||
(machine-become-command machine)))
|
||
|
||
(mlet %store-monad ((_ (check-deployment-sanity machine)))
|
||
;; Make sure code that check %CURRENT-SYSTEM, such as
|
||
;; %BASE-INITRD-MODULES, gets to see the right value.
|
||
(parameterize ((%current-system system)
|
||
(%current-target-system #f))
|
||
(let* ((os (machine-operating-system machine))
|
||
(eval (cut machine-remote-eval machine <>))
|
||
(bootloader-config (operating-system-bootloader os))
|
||
(bootmeta (operating-system-bootmeta os)))
|
||
(define-syntax-rule (eval/error-handling condition handler ...)
|
||
;; Return a wrapper around EVAL such that HANDLER is evaluated if an
|
||
;; exception is raised.
|
||
(lambda (exp)
|
||
(lambda (store)
|
||
(guard (condition ((inferior-exception? condition)
|
||
(values (begin handler ...) store)))
|
||
(values (run-with-store store (eval exp)
|
||
#:system system)
|
||
store)))))
|
||
|
||
(mbegin %store-monad
|
||
(with-roll-back #f
|
||
(switch-to-system (eval/error-handling c
|
||
(raise (formatted-message
|
||
(G_ "\
|
||
failed to switch systems while deploying '~a':~%~{~s ~}")
|
||
host
|
||
(inferior-exception-arguments c))))
|
||
os))
|
||
(parameterize ((%current-system system)
|
||
(%current-target-system #f))
|
||
(with-roll-back #t
|
||
(mbegin %store-monad
|
||
(upgrade-shepherd-services (eval/error-handling c
|
||
(warning (G_ "\
|
||
an error occurred while upgrading services on '~a':~%~{~s ~}~%")
|
||
host
|
||
(inferior-exception-arguments
|
||
c)))
|
||
os)
|
||
(mlet %store-monad
|
||
((boot-alternatives (machine->boot-alternatives machine)))
|
||
(apply install-bootloader
|
||
(eval/error-handling c
|
||
(raise (formatted-message
|
||
(G_ "\
|
||
failed to install bootloader on '~a':~%~{~s ~}~%")
|
||
host (inferior-exception-arguments c))))
|
||
bootloader-config boot-alternatives bootmeta))))))))))
|
||
|
||
|
||
;;;
|
||
;;; Roll-back.
|
||
;;;
|
||
|
||
(define (roll-back-managed-host machine)
|
||
"Internal implementation of 'roll-back-machine' for MACHINE instances with
|
||
an environment type of 'managed-host."
|
||
(define remote-exp
|
||
(with-extensions (list guile-gcrypt)
|
||
(with-imported-modules (source-module-closure '((guix config)
|
||
(guix profiles)))
|
||
#~(begin
|
||
(use-modules (guix config)
|
||
(guix profiles))
|
||
|
||
(define %system-profile
|
||
(string-append %state-directory "/profiles/system"))
|
||
|
||
(define target-generation
|
||
(relative-generation %system-profile -1))
|
||
|
||
(if target-generation
|
||
(switch-to-generation %system-profile target-generation)
|
||
'error)))))
|
||
|
||
(define roll-back-failure
|
||
(condition (&message (message (G_ "could not roll-back machine")))))
|
||
|
||
(mlet %store-monad
|
||
((boot-alternatives (machine->boot-alternatives machine)))
|
||
(match boot-alternatives
|
||
((first chosen rest ...)
|
||
(mlet %store-monad
|
||
((remote-result (machine-remote-eval machine remote-exp)))
|
||
(when (eqv? 'error remote-result) (raise roll-back-failure)))
|
||
(let ((os (machine-operating-system machine))
|
||
(crypto-dev (boot-parameters-store-crypto-devices chosen))
|
||
(prefix (boot-parameters-store-directory-prefix chosen)))
|
||
(install-bootloader (cute machine-remote-eval machine <>)
|
||
(operating-system-bootloader os)
|
||
(cons* chosen first rest)
|
||
#:locale (boot-parameters-locale chosen)
|
||
#:store-crypto-devices crypto-dev
|
||
#:store-directory-prefix prefix)))
|
||
(_ (raise roll-back-failure)))))
|
||
|
||
|
||
;;;
|
||
;;; Environment type.
|
||
;;;
|
||
|
||
(define managed-host-environment-type
|
||
(environment-type
|
||
(machine-remote-eval managed-host-remote-eval)
|
||
(deploy-machine deploy-managed-host)
|
||
(roll-back-machine roll-back-managed-host)
|
||
(name 'managed-host-environment-type)
|
||
(description "Provisioning for machines that are accessible over SSH
|
||
and have a known host-name. This entails little more than maintaining an SSH
|
||
connection to the host.")))
|
||
|
||
(define (maybe-raise-unsupported-configuration-error machine)
|
||
"Raise an error if MACHINE's configuration is not an instance of
|
||
<machine-ssh-configuration>."
|
||
(let ((config (machine-configuration machine))
|
||
(environment (environment-type-name (machine-environment machine))))
|
||
(unless (and config (machine-ssh-configuration? config))
|
||
(raise (formatted-message (G_ "unsupported machine configuration '~a'
|
||
for environment of type '~a'")
|
||
config
|
||
environment)))))
|
||
|
||
;; Local Variables:
|
||
;; eval: (put 'remote-let 'scheme-indent-function 1)
|
||
;; eval: (put 'with-roll-back 'scheme-indent-function 1)
|
||
;; eval: (put 'eval/error-handling 'scheme-indent-function 1)
|
||
;; End:
|