* 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 . -(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