[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-t
From: |
Jakob L. Kreuze |
Subject: |
[bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment. |
Date: |
Fri, 05 Jul 2019 19:47:50 -0400 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) |
* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
---
gnu/machine/ssh.scm | 235 ++++++++++++--------------------------------
1 file changed, 61 insertions(+), 174 deletions(-)
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index a7d1a967a..72e6407f0 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -30,10 +30,13 @@
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix remote)
+ #:use-module (guix scripts system)
+ #:use-module (guix scripts system reconfigure)
#:use-module (guix ssh)
#:use-module (guix store)
#:use-module (ice-9 match)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:export (managed-host-environment-type
@@ -105,118 +108,6 @@ an environment type of 'managed-host."
;;; System deployment.
;;;
-(define (switch-to-system machine)
- "Monadic procedure creating a new generation on MACHINE and execute the
-activation script for the new system configuration."
- (define (remote-exp drv script)
- (with-extensions (list guile-gcrypt)
- (with-imported-modules (source-module-closure '((guix config)
- (guix profiles)
- (guix utils)))
- #~(begin
- (use-modules (guix config)
- (guix profiles)
- (guix utils))
-
- (define %system-profile
- (string-append %state-directory "/profiles/system"))
-
- (let* ((system #$drv)
- (number (1+ (generation-number %system-profile)))
- (generation (generation-file-name %system-profile number)))
- (switch-symlinks generation system)
- (switch-symlinks %system-profile generation)
- ;; The implementation of 'guix system reconfigure' saves the
- ;; load path and environment here. This is unnecessary here
- ;; because each invocation of 'remote-eval' runs in a distinct
- ;; Guile REPL.
- (setenv "GUIX_NEW_SYSTEM" system)
- ;; The activation script may write to stdout, which confuses
- ;; 'remote-eval' when it attempts to read a result from the
- ;; remote REPL. We work around this by forcing the output to a
- ;; string.
- (with-output-to-string
- (lambda ()
- (primitive-load #$script))))))))
-
- (let* ((os (machine-system machine))
- (script (operating-system-activation-script os)))
- (mlet* %store-monad ((drv (operating-system-derivation os)))
- (machine-remote-eval machine (remote-exp drv script)))))
-
-;; XXX: Currently, this does NOT attempt to restart running services. This is
-;; also the case with 'guix system reconfigure'.
-;;
-;; See <https://issues.guix.info/issue/33508>.
-(define (upgrade-shepherd-services machine)
- "Monadic procedure unloading and starting services on the remote as needed
-to realize the MACHINE's system configuration."
- (define target-services
- ;; Monadic expression evaluating to a list of (name output-path) pairs for
- ;; all of MACHINE's services.
- (mapm %store-monad
- (lambda (service)
- (mlet %store-monad ((file ((compose lower-object
- shepherd-service-file)
- service)))
- (return (list (shepherd-service-canonical-name service)
- (derivation->output-path file)))))
- (service-value
- (fold-services (operating-system-services (machine-system machine))
- #:target-type shepherd-root-service-type))))
-
- (define (remote-exp target-services)
- (with-imported-modules '((gnu services herd))
- #~(begin
- (use-modules (gnu services herd)
- (srfi srfi-1))
-
- (define running
- (filter live-service-running (current-services)))
-
- (define (essential? service)
- ;; Return #t if SERVICE is essential and should not be unloaded
- ;; under any circumstance.
- (memq (first (live-service-provision service))
- '(root shepherd)))
-
- (define (obsolete? service)
- ;; Return #t if SERVICE can be safely unloaded.
- (and (not (essential? service))
- (every (lambda (requirements)
- (not (memq (first (live-service-provision service))
- requirements)))
- (map live-service-requirement running))))
-
- (define to-unload
- (filter obsolete?
- (remove (lambda (service)
- (memq (first (live-service-provision service))
- (map first '#$target-services)))
- running)))
-
- (define to-start
- (remove (lambda (service-pair)
- (memq (first service-pair)
- (map (compose first live-service-provision)
- running)))
- '#$target-services))
-
- ;; Unload obsolete services.
- (for-each (lambda (service)
- (false-if-exception
- (unload-service service)))
- to-unload)
-
- ;; Load the service files for any new services and start them.
- (load-services/safe (map second to-start))
- (for-each start-service (map first to-start))
-
- #t)))
-
- (mlet %store-monad ((target-services target-services))
- (machine-remote-eval machine (remote-exp target-services))))
-
(define (machine-boot-parameters machine)
"Monadic procedure returning a list of 'boot-parameters' for the generations
of MACHINE's system profile, ordered from most recent to oldest."
@@ -275,71 +166,67 @@ of MACHINE's system profile, ordered from most recent to
oldest."
(boot-parameters-kernel-arguments params))))))))
generations))))
-(define (install-bootloader machine)
- "Create a bootloader entry for the new system generation on MACHINE, and
-configure the bootloader to boot that generation by default."
- (define bootloader-installer-script
- (@@ (guix scripts system) bootloader-installer-script))
-
- (define (remote-exp installer bootcfg bootcfg-file)
- (with-extensions (list guile-gcrypt)
- (with-imported-modules (source-module-closure '((gnu build install)
- (guix store)
- (guix utils)))
- #~(begin
- (use-modules (gnu build install)
- (guix store)
- (guix utils))
- (let* ((gc-root (string-append "/" %gc-roots-directory "/bootcfg"))
- (temp-gc-root (string-append gc-root ".new")))
-
- (switch-symlinks temp-gc-root gc-root)
-
- (unless (false-if-exception
- (begin
- ;; The implementation of 'guix system reconfigure'
- ;; saves the load path here. This is unnecessary here
- ;; because each invocation of 'remote-eval' runs in a
- ;; distinct Guile REPL.
- (install-boot-config #$bootcfg #$bootcfg-file "/")
- ;; The installation script may write to stdout, which
- ;; confuses 'remote-eval' when it attempts to read a
- ;; result from the remote REPL. We work around this
- ;; by forcing the output to a string.
- (with-output-to-string
- (lambda ()
- (primitive-load #$installer)))))
- (delete-file temp-gc-root)
- (error "failed to install bootloader"))
-
- (rename-file temp-gc-root gc-root)
- #t)))))
-
- (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
- (let* ((os (machine-system machine))
- (bootloader ((compose bootloader-configuration-bootloader
- operating-system-bootloader)
- os))
- (bootloader-target (bootloader-configuration-target
- (operating-system-bootloader os)))
- (installer (bootloader-installer-script
- (bootloader-installer bootloader)
- (bootloader-package bootloader)
- bootloader-target
- "/"))
- (menu-entries (map boot-parameters->menu-entry boot-parameters))
- (bootcfg (operating-system-bootcfg os menu-entries))
- (bootcfg-file (bootloader-configuration-file bootloader)))
- (machine-remote-eval machine (remote-exp installer bootcfg
bootcfg-file)))))
-
(define (deploy-managed-host machine)
"Internal implementation of 'deploy-machine' for MACHINE instances with an
environment type of 'managed-host."
- (maybe-raise-unsupported-configuration-error machine)
- (mbegin %store-monad
- (switch-to-system machine)
- (upgrade-shepherd-services machine)
- (install-bootloader machine)))
+ (define target-services
+ ;; Monadic expression evaluating to a list of
+ ;; (shepherd-service-canonical-name, shepherd-service-file) pairs for the
+ ;; services in MACHINE's operating system configuration.
+ (mapm %store-monad
+ (lambda (service)
+ (mlet %store-monad ((file ((compose lower-object
+ shepherd-service-file)
+ service)))
+ (return (list (shepherd-service-canonical-name service)
+ (derivation->output-path file)))))
+ (service-value
+ (fold-services (operating-system-services (machine-system machine))
+ #:target-type shepherd-root-service-type))))
+
+ (define (run-switch-to-system machine)
+ "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'switch-to-system'."
+ (let* ((os (machine-system machine))
+ (activation-script (operating-system-activation-script os)))
+ (mlet %store-monad ((osdrv (operating-system-derivation os)))
+ (machine-remote-eval machine
+ (switch-to-system osdrv activation-script)))))
+
+ (define (run-upgrade-shepherd-services machine)
+ "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'upgrade-shepherd-services'."
+ (mlet %store-monad ((target-services target-services))
+ (machine-remote-eval machine
+ (upgrade-shepherd-services target-services))))
+
+ (define (run-install-bootloader machine)
+ "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'install-bootloader'."
+ (mlet* %store-monad ((boot-parameters (machine-boot-parameters machine)))
+ (let* ((os (machine-system machine))
+ (bootloader ((compose bootloader-configuration-bootloader
+ operating-system-bootloader)
+ os))
+ (target (bootloader-configuration-target
+ (operating-system-bootloader os)))
+ (installer (bootloader-installer-script
+ (bootloader-installer bootloader)
+ (bootloader-package bootloader)
+ target
+ "/"))
+ (menu-entries (map boot-parameters->menu-entry boot-parameters))
+ (bootcfg (operating-system-bootcfg os menu-entries))
+ (bootcfg-file (bootloader-configuration-file bootloader)))
+ (machine-remote-eval machine
+ (install-bootloader installer bootcfg
+ bootcfg-file "/")))))
+
+ (maybe-raise-missing-configuration-error machine)
+ (mapm %store-monad (cut <> machine)
+ (list run-switch-to-system
+ run-upgrade-shepherd-services
+ run-install-bootloader)))
;;;
--
2.22.0
signature.asc
Description: PGP signature
- [bug#36404] [PATCH 0/6] Add 'guix deploy'., Ricardo Wurmus, 2019/07/01
- [bug#36404] [PATCH 0/6] Add 'guix deploy'., Ludovic Courtès, 2019/07/01
- [bug#36404] [PATCH 0/6] Add 'guix deploy'., Ludovic Courtès, 2019/07/01
- [bug#36404] [PATCH 0/6] Add 'guix deploy'., Ludovic Courtès, 2019/07/01
- [bug#36404] [PATCH 0/6] Add 'guix deploy'., Jakob L. Kreuze, 2019/07/01
- [bug#36404] [PATCH 0/6] Add 'guix deploy'., Jakob L. Kreuze, 2019/07/02
- [bug#36404] [PATCH 0/6] Add 'guix deploy'., Jakob L. Kreuze, 2019/07/04
- [bug#36404] [PATCH 0/6] Add 'guix deploy'., Ludovic Courtès, 2019/07/05
- [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration., Jakob L. Kreuze, 2019/07/05
- [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module., Jakob L. Kreuze, 2019/07/05
- [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment.,
Jakob L. Kreuze <=
- [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure'., Jakob L. Kreuze, 2019/07/05
- [bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure'., Ludovic Courtès, 2019/07/06
- [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment., Ludovic Courtès, 2019/07/06
- [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment., Christopher Lemmer Webber, 2019/07/07
- [bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment., Ludovic Courtès, 2019/07/07
- [bug#36404] [PATCH 1/3] guix system: Add 'reconfigure' module., Ludovic Courtès, 2019/07/06
- [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration., Ludovic Courtès, 2019/07/06
- [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration., Christopher Lemmer Webber, 2019/07/07
- [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration., Ludovic Courtès, 2019/07/07
- [bug#36404] [PATCH 0/3] Refactor out common behavior for system reconfiguration., Jakob L. Kreuze, 2019/07/08