[bug#36404] [PATCH 2/3] machine: Reimplement 'managed-host-environment-type' deployment.

[Christopher Lemmer Webber]

In some ways it looks like a portion of the previous patch and a portion
of this patch are a "move and modify" of what are sort-of the same
chunks of code.  But it's a bit weird to me that the code is added in
the previous commit and removed in this one?  It might be clearer to the
reader that this is what is happening if it's in the same commit.

Jakob L. Kreuze writes:

> * 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)))
>  
>  
>  ;;;