[bug#36555] [PATCH 0/2] Refactor out common behavior for system reconfiguration.

[bug#36555] [PATCH 0/2] Refactor out common behavior for system reconfiguration.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 2140 bytes --]

Hello, Guix!

This is the preliminary version of a patch series to turn the behavior
common between 'guix deploy' and 'guix system reconfigure' into a module
that both can use. I am submitting it as-is both for comments and for
tracking the refactoring effort.

Note that this is _not_ ready to be merged. There are several things
that I need to do before I would consider it ready for upstream Guix:

- This passes my old test suite for 'guix deploy', but I haven't dared
  to run the new 'guix system reconfigure'. I'll set up a new virtual
  machine so I don't put myself out of a working laptop.
- 'switch-system-program', 'upgrade-services-program', and
  'install-bootloader-program' omit some of the features that were
  present in the procedures they replace. For example,
  'install-bootloader' previously supported installing the bootloader
  configuration without actually running the installation script. This
  was fine for 'guix deploy', but I'll need to add it back in for
  'guix system reconfigure'.
- I plan to implement system tests for '(guix scripts system
  reconfigure)'. I suppose I can always submit them as a separate patch,
  but I'll likely finish them before we're through with code review, so
  it may make sense to include them with as part of this patch series,
  albeit as a distinct commit.
- I suspect that some of the effectful procedures in 'system.scm' could
  be refactored out in a similar fashion. Not that 'guix deploy' would
  necessarily be using them, but it would be more consistent to have
  them as 'program-file' objects, and those procedures could then also
  be tested.

I look forward to your comments.

Regards,
Jakob


Jakob L. Kreuze (2):
  guix system: Add 'reconfigure' module.
  guix system: Reimplement 'reconfigure'.

 Makefile.am                         |   1 +
 gnu/machine/ssh.scm                 | 235 ++++++++--------------------
 guix/scripts/system.scm             | 140 +++++------------
 guix/scripts/system/reconfigure.scm | 158 +++++++++++++++++++
 4 files changed, 255 insertions(+), 279 deletions(-)
 create mode 100644 guix/scripts/system/reconfigure.scm

--
2.22.0

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 21494 bytes --]

* guix/scripts/system/reconfigure.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/system.scm (bootloader-installer-script): Export variable.
* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
---
 Makefile.am                         |   1 +
 gnu/machine/ssh.scm                 | 232 +++++++---------------------
 guix/scripts/system.scm             |   1 +
 guix/scripts/system/reconfigure.scm | 158 +++++++++++++++++++
 4 files changed, 219 insertions(+), 173 deletions(-)
 create mode 100644 guix/scripts/system/reconfigure.scm

diff --git a/Makefile.am b/Makefile.am
index dd7720e87..58a96d348 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -245,6 +245,7 @@ MODULES =					\
   guix/scripts/describe.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
+  guix/scripts/system/reconfigure.scm		\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index a7d1a967a..95198bb2a 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,66 @@ 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."
+  (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'."
+    (mlet %store-monad ((script (switch-system-program (machine-system machine))))
+        (machine-remote-eval machine #~(primitive-load #$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)
+                         (script (upgrade-services-program target-services)))
+      (machine-remote-eval machine #~(primitive-load #$script))))
+
+  (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)))
+        (mlet %store-monad ((script (install-bootloader-program installer
+                                                                bootcfg
+                                                                bootcfg-file
+                                                                "/")))
+          (machine-remote-eval machine #~(primitive-load #$script))))))
+
   (maybe-raise-unsupported-configuration-error machine)
-  (mbegin %store-monad
-    (switch-to-system machine)
-    (upgrade-shepherd-services machine)
-    (install-bootloader machine)))
+  (mapm %store-monad (cut <> machine)
+        (list run-switch-to-system
+              run-upgrade-shepherd-services
+              run-install-bootloader)))
 
 \f
 ;;;
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 60c1ca5c9..21858ee7d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -70,6 +70,7 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:export (guix-system
+            bootloader-installer-script
             read-operating-system))
 
 \f
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 000000000..e14ea4f2f
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,158 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 (guix scripts system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu system)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:export (switch-system-program
+            upgrade-services-program
+            install-bootloader-program))
+
+;;; Commentary:
+;;;
+;;; This module implements the "effectful" parts of system
+;;; reconfiguration. Although building a system derivation is a pure
+;;; operation, a number of impure operations must be carried out for the
+;;; system configuration to be realized -- chiefly, creation of generation
+;;; symlinks and invocation of activation scripts.
+;;;
+;;; Code:
+
+(define (switch-system-program os)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will create a new generation for SYSTEM-DERIVATION and
+execute ACTIVATION-SCRIPT."
+  (gexp->script
+   "switch-to-system.scm"
+   (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* ((number (1+ (generation-number %system-profile)))
+                  (generation (generation-file-name %system-profile number)))
+             (switch-symlinks generation #$os)
+             (switch-symlinks %system-profile generation)
+             (setenv "GUIX_NEW_SYSTEM" #$os)
+             (with-output-to-string
+               (lambda ()
+                 (primitive-load
+                  #$(operating-system-activation-script os))))))))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program target-services)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will use TARGET-SERVICES, a list
+of (shepherd-service-canonical-name, shepherd-service-file) pairs to determine
+which services are obsolete and need to be unloaded, as well as which services
+are new and need to be started."
+  (gexp->script
+   "upgrade-shepherd-services.scm"
+   (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))))))
+
+(define (install-bootloader-program installer-script bootcfg bootcfg-file target)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target path, on
+TARGET, a mount point, and subsequently run INSTALLER-SCRIPT."
+  (gexp->script
+   "install-bootloader.scm"
+   (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)
+
+             (let ((installer-result
+                    (false-if-exception
+                     (begin
+                       (install-boot-config #$bootcfg #$bootcfg-file #$target)
+                       (with-output-to-string
+                         (lambda ()
+                           (primitive-load #$installer-script)))))))
+               (unless installer-result
+                 (delete-file temp-gc-root)
+                 (error "failed to install bootloader"))
+               (rename-file temp-gc-root gc-root)
+               installer-result)))))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH 2/2] guix system: Reimplement 'reconfigure'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 9627 bytes --]

* guix/scripts/system.scm (switch-to-system)
(upgrade-shepherd-services, install-bootloader): Delete variable.
* guix/scripts/system.scm (%switch-to-system)
(%upgrade-shepherd-services, %install-bootloader): New variable.
---
 guix/scripts/system.scm | 139 ++++++++++------------------------------
 1 file changed, 34 insertions(+), 105 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 21858ee7d..c58fc0284 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,7 @@
                                        delete-matching-generations)
   #:use-module (guix graph)
   #:use-module (guix scripts graph)
+  #:use-module (guix scripts system reconfigure)
   #:use-module (guix build utils)
   #:use-module (guix progress)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -179,38 +180,14 @@ TARGET, and register them."
 
     (return *unspecified*)))
 
-(define* (install-bootloader installer
-                             #:key
-                             bootcfg bootcfg-file
-                             target)
+(define (install-bootloader installer bootcfg bootcfg-file target)
   "Run INSTALLER, a bootloader installation script, with error handling, in
 %STORE-MONAD."
-  (mlet %store-monad ((installer-drv (if installer
-                                         (lower-object installer)
-                                         (return #f)))
-                      (bootcfg       (lower-object bootcfg)))
-    (let* ((gc-root      (string-append target %gc-roots-directory
-                                        "/bootcfg"))
-           (temp-gc-root (string-append gc-root ".new"))
-           (install (and installer-drv
-                         (derivation->output-path installer-drv)))
-           (bootcfg (derivation->output-path bootcfg)))
-      ;; Prepare the symlink to bootloader config file to make sure that it's
-      ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
-      (switch-symlinks temp-gc-root bootcfg)
-
-      (unless (false-if-exception
-               (begin
-                 (install-boot-config bootcfg bootcfg-file target)
-                 (when install
-                   (save-load-path-excursion (primitive-load install)))))
-        (delete-file temp-gc-root)
-        (leave (G_ "failed to install bootloader ~a~%") install))
-
-      ;; Register bootloader config file as a GC root so that its dependencies
-      ;; (background image, font, etc.) are not reclaimed.
-      (rename-file temp-gc-root gc-root)
-      (return #t))))
+  (mlet* %store-monad ((script (install-bootloader-program installer bootcfg
+                                                           bootcfg-file target))
+                       (file (lower-object script))
+                       (_ (built-derivations (list file))))
+    (primitive-load (derivation->output-path file))))
 
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
@@ -266,10 +243,8 @@ the ownership of '~a' may be incorrect!~%")
         (populate os-dir target)
 
         (mwhen install-bootloader?
-          (install-bootloader bootloader-installer
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader bootloader-installer bootcfg
+                              bootcfg-file target))))))
 
 \f
 ;;;
@@ -348,69 +323,27 @@ bring the system down."
      (fold-services (operating-system-services os)
                     #:target-type shepherd-root-service-type)))
 
-  ;; Arrange to simply emit a warning if the service upgrade fails.
-  (with-shepherd-error-handling
-   (call-with-service-upgrade-info new-services
-     (lambda (to-restart to-unload)
-        (for-each (lambda (unload)
-                    (info (G_ "unloading service '~a'...~%") unload)
-                    (unload-service unload))
-                  to-unload)
-
-        (with-monad %store-monad
-          (munless (null? new-services)
-            (let ((new-service-names  (map shepherd-service-canonical-name new-services))
-                  (to-restart-names   (map shepherd-service-canonical-name to-restart))
-                  (to-start           (filter shepherd-service-auto-start? new-services)))
-              (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
-              (unless (null? to-restart-names)
-                ;; Listing TO-RESTART-NAMES in the message below wouldn't help
-                ;; because many essential services cannot be meaningfully
-                ;; restarted.  See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
-                (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n")))
-              (mlet %store-monad ((files (mapm %store-monad
-                                               (compose lower-object
-                                                        shepherd-service-file)
-                                               new-services)))
-                ;; Here we assume that FILES are exactly those that were computed
-                ;; as part of the derivation that built OS, which is normally the
-                ;; case.
-                (load-services/safe (map derivation->output-path files))
-
-                (for-each start-service
-                          (map shepherd-service-canonical-name to-start))
-                (return #t)))))))))
-
-(define* (switch-to-system os
-                           #:optional (profile %system-profile))
-  "Make a new generation of PROFILE pointing to the directory of OS, switch to
-it atomically, and then run OS's activation script."
-  (mlet* %store-monad ((drv (operating-system-derivation os))
-                       (script (lower-object (operating-system-activation-script os))))
-    (let* ((system     (derivation->output-path drv))
-           (number     (+ 1 (generation-number profile)))
-           (generation (generation-file-name profile number)))
-      (switch-symlinks generation system)
-      (switch-symlinks profile generation)
-
-      (format #t (G_ "activating system...~%"))
-
-      ;; The activation script may change $PATH, among others, so protect
-      ;; against that.
-      (save-environment-excursion
-       ;; Tell 'activate-current-system' what the new system is.
-       (setenv "GUIX_NEW_SYSTEM" system)
-
-       ;; The activation script may modify '%load-path' & co., so protect
-       ;; against that.  This is necessary to ensure that
-       ;; 'upgrade-shepherd-services' gets to see the right modules when it
-       ;; computes derivations with 'gexp->derivation'.
-       (save-load-path-excursion
-        (primitive-load (derivation->output-path script))))
-
-      ;; Finally, try to update system services.
-      (upgrade-shepherd-services os))))
+  (define (serialize-service service)
+    (mlet %store-monad ((file (lower-object (shepherd-service-file service))))
+      (return (list (shepherd-service-canonical-name service)
+                    (derivation->output-path file)))))
+
+  (call-with-service-upgrade-info new-services
+    (lambda (new-services)
+      (mlet* %store-monad ((target-services (mapm %store-monad serialize-service
+                                                  new-services))
+                           (script (upgrade-services-program target-services))
+                           (file (lower-object script))
+                           (_ (built-derivations (list file))))
+        (primitive-load (derivation->output-path file))))))
+
+(define (switch-to-system os)
+  "Make a new generation of PROFILE pointing to the directory of OS, switch
+to it atomically, and then run OS's activation script."
+  (mlet* %store-monad ((script (switch-system-program os))
+                       (file (lower-object script))
+                       (_ (built-derivations (list file))))
+    (primitive-load (derivation->output-path file))))
 
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
@@ -514,10 +447,7 @@ STORE is an open connection to the store."
           (built-derivations drvs)
           ;; Only install bootloader configuration file. Thus, no installer is
           ;; provided here.
-          (install-bootloader #f
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader #f bootcfg bootcfg-file target))))))
 
 \f
 ;;;
@@ -920,11 +850,10 @@ static checks."
             ((reconfigure)
              (mbegin %store-monad
                (switch-to-system os)
+               (upgrade-shepherd-services os)
                (mwhen install-bootloader?
-                 (install-bootloader bootloader-script
-                                     #:bootcfg bootcfg
-                                     #:bootcfg-file bootcfg-file
-                                     #:target "/"))))
+                 (install-bootloader bootloader-script bootcfg
+                                     bootcfg-file (or target "/")))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module.

[Ludovic Courtès]

Hello!

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> * guix/scripts/system/reconfigure.scm: New file.
> * Makefile.am (MODULES): Add it.
> * guix/scripts/system.scm (bootloader-installer-script): Export variable.
> * gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
> (install-bootloader): Delete variable.
> * gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.

[...]

> +  (define (run-switch-to-system machine)
> +    "Monadic procedure serializing the items in MACHINE necessary to build a
> +G-Expression with 'switch-to-system'."
> +    (mlet %store-monad ((script (switch-system-program (machine-system machine))))
> +        (machine-remote-eval machine #~(primitive-load #$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)
> +                         (script (upgrade-services-program target-services)))
> +      (machine-remote-eval machine #~(primitive-load #$script))))

These would look nicer if ‘switch-system-program’ and
‘upgrade-services-program’ returns a <program-file> because you could
just write:

  (machine-remote-eval #~(primitive-load #$(switch-system-program …))
                       machine)

(I realize the order of arguments is reversed; to stick to what ‘eval’
does, I’d tend to put the ‘machine’ argument second—but that’s a
separate issue.  :-))

> +(define (switch-system-program os)
> +  "Return as a monadic value a derivation to build a scheme file that, upon
> +being evaluated, will create a new generation for SYSTEM-DERIVATION and
> +execute ACTIVATION-SCRIPT."
> +  (gexp->script
> +   "switch-to-system.scm"
> +   (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* ((number (1+ (generation-number %system-profile)))
> +                  (generation (generation-file-name %system-profile number)))
> +             (switch-symlinks generation #$os)
> +             (switch-symlinks %system-profile generation)
> +             (setenv "GUIX_NEW_SYSTEM" #$os)
> +             (with-output-to-string
> +               (lambda ()
> +                 (primitive-load
> +                  #$(operating-system-activation-script os))))))))))

Can we remove ‘with-output-to-string’?  I’d rather see what’s going on.
:-)

If that’s too verbose, we can use ‘invoke/quiet’.

> +;; XXX: Currently, this does NOT attempt to restart running services. See
> +;; <https://issues.guix.info/issue/33508> for details.
> +(define (upgrade-services-program target-services)
> +  "Return as a monadic value a derivation to build a scheme file that, upon
> +being evaluated, will use TARGET-SERVICES, a list
> +of (shepherd-service-canonical-name, shepherd-service-file) pairs to determine
> +which services are obsolete and need to be unloaded, as well as which services
> +are new and need to be started."
> +  (gexp->script
> +   "upgrade-shepherd-services.scm"
> +   (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))))))

It seems that this sort-of inlines parts of ‘shepherd-service-upgrade’
but without traversing the service dependency graph to determine the
compilete set of obsolete services, no?  I feel that we should be
reusing ‘shepherd-service-upgrade’ or similar bits.  (I realize this is
already in ‘master’ for ‘guix deploy’, but since this is going to be
shared with ‘guix system’, we’d rather be extra cautious.)

Also, I think we should remove ‘false-if-exception’ around
‘unload-service’.

> +(define (install-bootloader-program installer-script bootcfg bootcfg-file target)
> +  "Return as a monadic value a derivation to build a scheme file that, upon
> +being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target path, on
> +TARGET, a mount point, and subsequently run INSTALLER-SCRIPT."
> +  (gexp->script
> +   "install-bootloader.scm"
> +   (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)
> +
> +             (let ((installer-result
> +                    (false-if-exception
> +                     (begin
> +                       (install-boot-config #$bootcfg #$bootcfg-file #$target)
> +                       (with-output-to-string
> +                         (lambda ()
> +                           (primitive-load #$installer-script)))))))
> +               (unless installer-result
> +                 (delete-file temp-gc-root)
> +                 (error "failed to install bootloader"))
> +               (rename-file temp-gc-root gc-root)
> +               installer-result)))))))

I’d rather not swallow stdout and not use ‘error’.  Or at least, code
that runs ‘install-bootloader-program’ should be able to produce a
meaningful (and i18n’d) error message.  So the caller could do something
like:

  (define result
    (machine-eval #~(…
                     (guard (c ((message-condition? c)
                                (cons 'error (condition-message c))))
                       (invoke/quiet #$(install-bootloader-program …))
                       '(success)))
                  machine))

  (match result
    (('error message)
     (leave (G_ "failed to install bootloader:~%~a~%") message))
    (('success)
     #t))

Does that make sense?

That’s quite some boilerplate to the challenge will be to factorize it.

Ultimately, the code in (guix scripts system reconfigure) should be
parameterized by an evaluation procedure that would be either
‘machine-eval’ or some hypothetical ‘local-eval’ procedure to evaluate
things locally.

Thanks,
Ludo’.

[bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 3422 bytes --]

Hi, Ludovic!

Ludovic Courtès <ludo@gnu.org> writes:

> These would look nicer if ‘switch-system-program’ and
> ‘upgrade-services-program’ returns a <program-file> because you could
> just write:
>
>   (machine-remote-eval #~(primitive-load #$(switch-system-program …))
>                        machine)
>
> (I realize the order of arguments is reversed; to stick to what ‘eval’
> does, I’d tend to put the ‘machine’ argument second—but that’s a
> separate issue.  :-))

I'm using 'gexp->script', so they should be returning a 'program-file'.
I've just neglected the conveniences I'm afforded with ungexp, it seems.
#~(primitive-load #$(switch-system-program …)) is, indeed, quite a bit
cleaner :)

> Can we remove ‘with-output-to-string’? I’d rather see what’s going on.
> :-)
>
> If that’s too verbose, we can use ‘invoke/quiet’.

I'm not too concerned with verbosity; rather, in the case for 'guix
deploy', the script's output mixes with the REPL output and that causes
'remote-eval' to fail with a match error. I think it would be better to
continue using 'with-output-to-string', but to preseve its return value
so we can show it to the user from 'guix deploy' or 'guix system
reconfigure'. Users of 'guix deploy' would also be able to see the
script's output this way.

> It seems that this sort-of inlines parts of ‘shepherd-service-upgrade’
> but without traversing the service dependency graph to determine the
> compilete set of obsolete services, no? I feel that we should be
> reusing ‘shepherd-service-upgrade’ or similar bits. (I realize this is
> already in ‘master’ for ‘guix deploy’, but since this is going to be
> shared with ‘guix system’, we’d rather be extra cautious.)

Does 'live-service-requirement' not encompass the full service
dependency graph? Regardless, I'll look into reusing
'shepherd-service-upgrade' as it's well-testsed.

> Also, I think we should remove ‘false-if-exception’ around
> ‘unload-service’.

Agreed. When you have time to look at it, I've raised a few questions
about this in v2 of this series.

> I’d rather not swallow stdout and not use ‘error’. Or at least, code
> that runs ‘install-bootloader-program’ should be able to produce a
> meaningful (and i18n’d) error message. So the caller could do
> something like:
>
>   (define result
>     (machine-eval #~(…
>                      (guard (c ((message-condition? c)
>                                 (cons 'error (condition-message c))))
>                        (invoke/quiet #$(install-bootloader-program …))
>                        '(success)))
>                   machine))
>
>   (match result
>     (('error message)
>      (leave (G_ "failed to install bootloader:~%~a~%") message))
>     (('success)
>      #t))
>
> Does that make sense?

Yes, and thank you for providing that snippet :)

> That’s quite some boilerplate to the challenge will be to factorize
> it.
>
> Ultimately, the code in (guix scripts system reconfigure) should be
> parameterized by an evaluation procedure that would be either
> ‘machine-eval’ or some hypothetical ‘local-eval’ procedure to evaluate
> things locally.

Noted. That should be a relatively small change, so I'll see about
tackling that in my next revision for this series.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module.

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 1074 bytes --]

Hello!

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> Ludovic Courtès <ludo@gnu.org> writes:

[...]

>> Can we remove ‘with-output-to-string’? I’d rather see what’s going on.
>> :-)
>>
>> If that’s too verbose, we can use ‘invoke/quiet’.
>
> I'm not too concerned with verbosity; rather, in the case for 'guix
> deploy', the script's output mixes with the REPL output and that causes
> 'remote-eval' to fail with a match error. I think it would be better to
> continue using 'with-output-to-string', but to preseve its return value
> so we can show it to the user from 'guix deploy' or 'guix system
> reconfigure'. Users of 'guix deploy' would also be able to see the
> script's output this way.

Oh, I see.  So in a way the problem is that ‘remote-eval’ doesn’t do
anything sensible with the output and error ports of that remote
evaluation.

Ultimately we should probably fix (guix inferior) and (guix remote) so
that stdout and stderr are properly transmitted.

In the meantime, what about this patch?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 834 bytes --]

diff --git a/guix/remote.scm b/guix/remote.scm
index e503c76167..8ada5c0957 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -76,8 +76,14 @@ result to the current output port using the (guix repl) protocol."
   (with-imported-modules (source-module-closure '((guix repl)))
     #~(begin
         (use-modules (guix repl))
-        (send-repl-response '(primitive-load #$program)
+
+        ;; We use CURRENT-OUTPUT-PORT for REPL messages, so redirect PROGRAM's
+        ;; output to CURRENT-ERROR-PORT so that it does not interfere.
+        (send-repl-response '(with-output-to-port (current-error-port)
+                               (lambda ()
+                                 (primitive-load #$program)))
                             (current-output-port))
+
         (force-output))))
 
 (define* (remote-eval exp session

[-- Attachment #3: Type: text/plain, Size: 849 bytes --]


>> It seems that this sort-of inlines parts of ‘shepherd-service-upgrade’
>> but without traversing the service dependency graph to determine the
>> compilete set of obsolete services, no? I feel that we should be
>> reusing ‘shepherd-service-upgrade’ or similar bits. (I realize this is
>> already in ‘master’ for ‘guix deploy’, but since this is going to be
>> shared with ‘guix system’, we’d rather be extra cautious.)
>
> Does 'live-service-requirement' not encompass the full service
> dependency graph? Regardless, I'll look into reusing
> 'shepherd-service-upgrade' as it's well-testsed.

‘live-service-requirement’ gives you the graph of the currently loaded
services, but you also need the target service graph to determine what
to upgrade; that seems to be missing currently.

Thanks,
Ludo’.

[bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 1799 bytes --]

Ludovic Courtès <ludo@gnu.org> writes:

> Oh, I see. So in a way the problem is that ‘remote-eval’ doesn’t do
> anything sensible with the output and error ports of that remote
> evaluation.
>
> Ultimately we should probably fix (guix inferior) and (guix remote) so
> that stdout and stderr are properly transmitted.

Thinking about it now, that could make error reporting for 'guix deploy'
less complicated. We'd be able to output the remote's stdout/stderr to
the host's stdout/stderr and be done with it.

> In the meantime, what about this patch?
>
> diff --git a/guix/remote.scm b/guix/remote.scm
> index e503c76167..8ada5c0957 100644
> --- a/guix/remote.scm
> +++ b/guix/remote.scm
> @@ -76,8 +76,14 @@ result to the current output port using the (guix repl) protocol."
>    (with-imported-modules (source-module-closure '((guix repl)))
>      #~(begin
>          (use-modules (guix repl))
> -        (send-repl-response '(primitive-load #$program)
> +
> +        ;; We use CURRENT-OUTPUT-PORT for REPL messages, so redirect PROGRAM's
> +        ;; output to CURRENT-ERROR-PORT so that it does not interfere.
> +        (send-repl-response '(with-output-to-port (current-error-port)
> +                               (lambda ()
> +                                 (primitive-load #$program)))
>                              (current-output-port))
> +
>          (force-output))))
>  
>  (define* (remote-eval exp session

LGTM, thanks!

> ‘live-service-requirement’ gives you the graph of the currently loaded
> services, but you also need the target service graph to determine what
> to upgrade; that seems to be missing currently.

Oh, good catch. Reusing 'shepherd-service-upgrade' is certainly the way
to go, then.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module.

[Ludovic Courtès]

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> Ludovic Courtès <ludo@gnu.org> writes:

[...]

>> In the meantime, what about this patch?
>>
>> diff --git a/guix/remote.scm b/guix/remote.scm
>> index e503c76167..8ada5c0957 100644
>> --- a/guix/remote.scm
>> +++ b/guix/remote.scm
>> @@ -76,8 +76,14 @@ result to the current output port using the (guix repl) protocol."
>>    (with-imported-modules (source-module-closure '((guix repl)))
>>      #~(begin
>>          (use-modules (guix repl))
>> -        (send-repl-response '(primitive-load #$program)
>> +
>> +        ;; We use CURRENT-OUTPUT-PORT for REPL messages, so redirect PROGRAM's
>> +        ;; output to CURRENT-ERROR-PORT so that it does not interfere.
>> +        (send-repl-response '(with-output-to-port (current-error-port)
>> +                               (lambda ()
>> +                                 (primitive-load #$program)))
>>                              (current-output-port))
>> +
>>          (force-output))))
>>  
>>  (define* (remote-eval exp session
>
> LGTM, thanks!

Cool, pushed as 6f8eb9f1d8bc8660349658602698db36965bba5d.

>> ‘live-service-requirement’ gives you the graph of the currently loaded
>> services, but you also need the target service graph to determine what
>> to upgrade; that seems to be missing currently.
>
> Oh, good catch. Reusing 'shepherd-service-upgrade' is certainly the way
> to go, then.

I think so, which brings us back to the need to de-monadify (guix graph).
:-)

Ludo’.

[bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 386 bytes --]

Ludovic Courtès <ludo@gnu.org> writes:

> I think so, which brings us back to the need to de-monadify (guix
> graph). :-)

Good news, I came up with a way of using 'shepherd-service-upgrade' on
the host side. Stay tuned for v3 of this patch series ;)

Though, I suppose cleaning up the dependencies of '(guix graph)' may be
a good goal to have regardless.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v3 0/3] Refactor out common behavior for system reconfiguration.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 5395 bytes --]

Hi, all.

Submitting this reroll to ask for some further feedback. Here's a
summary of the more significant changes since v2:

- All of the system tests for the reconfiguration procedures have been
  implemented.
- 'upgrade-services-program' has been completely reimplemented; '(gnu
  machine ssh)' is now capable of (partially) serializing the
  <live-service> objects returned by 'current-services', so we can use
  'shepherd-service-upgrade' to traverse the service dependency graph.
- Procedures in '(guix scripts system reconfigure)' now use
  'program-file' instead of 'gexp->script'. I hadn't realized the
  difference, but this makes invocations of 'remote-eval' a bit cleaner.
- Thanks to Ludovic's patches to '(guix remote)', the reconfiguration
  procedures no longer need to capture output from the
  activation/installation scripts.
- I've removed my awful hack of a solution for handling Shepherd errors
  in 'upgrade-services-program' in favor of handling exceptions on the
  host side. I have some questions about this.
- 'upgrade-services-program' comes after 'install-bootloader-program' in
  'guix deploy' and 'guix system reconfigure' now, as it's the procedure
  most likely to fail trivially.

I still need to handle failed deployments in 'guix deploy'. I suspect
that, for now, it would make sense to implement remote roll-backs and
just roll-back the system on failure, at least until we've have some
dialog about the proper way to do atomic deployments.

My biggest concern at the moment is error handling reporting in the new
'guix system reconfigure'. I'd like to emulate what was done with the
previous version, but I'm at somewhat of a loss for how I'd go about
that, since the error reporting was mixed with the reconfiguration code.
So I'd like to ask for some suggestions: is the best way to catch errors
in '%store-monad' to do what 'with-shepherd-error-handling' does, and
then 'leave' on failure?

Ludovic suggested guarding against 'message-condition' and having the
expression I send to 'remote-eval' return either ('error message) or
('success). Would it make sense to just do this in all of the
reconfiguration procedures? Or is raising exceptions in the
reconfiguration procedures and catching them in the scripts' code the
way to go?

There's also a slight bug in the new 'guix system reconfigure' that I'll
need to figure out. At the moment, it installs a bootloader entry for
all but the newest generation.

Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org> writes:

> Noted. That should be a relatively small change, so I'll see about
> tackling that in my next revision for this series.

Oh, how naïve I was four days ago. This reroll doesn't address this.
Having the procedures "parameterized by an evaluation procedure" can be
done in so many ways, and I think it would be best I put some serious
thought into which of those ways would be the best. A 'local-eval' would
clearly be much better than what I'm doing at the present in
'system.scm', but the solution I came up with today involved three
layers of 'primitive-load', which I doubt is the way to go about it. I
had the idea to parameterize on a procedure that takes a
'<program-file>' rather than a G-Expression as I was making dinner
tonight, which seems to me like a sound idea, but we'll see if it works
tomorrow when I try to implement it.

Also, it hit me today that the safety checks done in 'guix system
reconfigure' -- 'check-mapped-devices',
'check-file-system-availability', and 'check-initrd-modules' -- should
also be done in 'guix deploy'. It might make sense for me to submit that
change as a separate patch series so the code review for this doesn't
get too complicated, but since we're on the topic of unifying the code
between 'guix deploy' and 'guix system reconfigure', should I perhaps
reimplement those procedures as '<program-file>' objects like everything
else in '(guix scripts system reconfigure)'? They aren't really
effectful, but they concern system reconfiguration.

And, on the same note, should I go ahead and refactor the rest of the
reconfiguration code in 'system.scm' out into '(guix scripts system
reconfigure)'? I mean, this will probably be a separate patch series for
the same reason that the safety checks would be a separate patch series,
and I'll likely do this _after_ I come up with a decent way to
parameterize on an evaluation procedure, but I'd like to know if it's a
good idea or not before going ahead and ripping apart 'system.scm'.

Regards, and TYIA for reviewing this.
Jakob

Jakob L. Kreuze (3):
  guix system: Add 'reconfigure' module.
  guix system: Reimplement 'reconfigure'.
  tests: Add reconfigure system test.

 Makefile.am                         |   1 +
 gnu/local.mk                        |   1 +
 gnu/machine/ssh.scm                 | 266 ++++++++++-----------------
 gnu/services/herd.scm               |   6 +
 gnu/tests/reconfigure.scm           | 268 ++++++++++++++++++++++++++++
 guix/scripts/system.scm             | 152 +++++-----------
 guix/scripts/system/reconfigure.scm | 122 +++++++++++++
 tests/services.scm                  |   4 -
 8 files changed, 538 insertions(+), 282 deletions(-)
 create mode 100644 gnu/tests/reconfigure.scm
 create mode 100644 guix/scripts/system/reconfigure.scm

-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v3 1/3] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 25961 bytes --]

* guix/scripts/system/reconfigure.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/system.scm (bootloader-installer-script): Export variable.
* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
* gnu/services/herd.scm (live-service): Export variable.
* gnu/services/herd.scm (live-service-canonical-name): New variable.
* tests/services.scm (live-service): Delete variable.
---
 Makefile.am                         |   1 +
 gnu/machine/ssh.scm                 | 266 ++++++++++------------------
 gnu/services/herd.scm               |   6 +
 guix/scripts/system.scm             |   1 +
 guix/scripts/system/reconfigure.scm | 170 ++++++++++++++++++
 tests/services.scm                  |   4 -
 6 files changed, 272 insertions(+), 176 deletions(-)
 create mode 100644 guix/scripts/system/reconfigure.scm

diff --git a/Makefile.am b/Makefile.am
index dd7720e87..58a96d348 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -245,6 +245,7 @@ MODULES =					\
   guix/scripts/describe.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
+  guix/scripts/system/reconfigure.scm		\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index a7d1a967a..a5c5c6b39 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -21,6 +21,7 @@
   #:use-module (gnu machine)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu services)
+  #:use-module (gnu services herd)
   #:use-module (gnu services shepherd)
   #:use-module (gnu system)
   #:use-module (guix derivations)
@@ -30,10 +31,15 @@
   #: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-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-35)
   #:export (managed-host-environment-type
 
@@ -105,118 +111,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 +169,99 @@ 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 (machine-current-services machine)
+  "Return the <live-service> objects that are currently running on MACHINE."
+  (define remote-exp
+    (with-imported-modules '((gnu services herd))
+      #~(begin
+          (use-modules (gnu services herd))
+          (let ((services (current-services)))
+            (and services
+                 ;; 'live-service-running' is ignored, as we can't necessarily
+                 ;; serialize arbitrary objects. This should be fine for now,
+                 ;; since 'machine-current-services' is not exposed publicly,
+                 ;; and the resultant <live-service> objects are only used for
+                 ;; resolving service dependencies.
+                 (map (lambda (service)
+                        (list (live-service-provision service)
+                              (live-service-requirement service)))
+                      services))))))
+  (mlet %store-monad ((services (machine-remote-eval machine remote-exp)))
+    (return (map (match-lambda
+                   ((provision requirement)
+                    (live-service provision requirement #f)))
+                 services))))
 
 (define (deploy-managed-host machine)
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
+  (define target-services
+    (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'."
+    (machine-remote-eval machine #~(primitive-load
+                                    #$(switch-system-program
+                                       (machine-system machine)))))
+
+  (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 ((live-services (machine-current-services machine)))
+      (let-values (((to-unload to-restart)
+                    (shepherd-service-upgrade live-services target-services)))
+        (let* ((to-unload (map live-service-canonical-name to-unload))
+               (to-restart (map shepherd-service-canonical-name to-restart))
+               (to-start (lset-difference
+                          eqv?
+                          (map shepherd-service-canonical-name target-services)
+                          (map live-service-canonical-name live-services)))
+               (service-files
+                (map shepherd-service-file
+                     (filter (lambda (service)
+                               (memq (shepherd-service-canonical-name service)
+                                     to-start))
+                             target-services))))
+          (machine-remote-eval machine
+                               #~(primitive-load
+                                  #$(upgrade-services-program service-files
+                                                              to-start
+                                                              to-unload
+                                                              to-restart)))))))
+
+  (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
+                             #~(primitive-load
+                                #$(install-bootloader-program installer
+                                                              bootcfg
+                                                              bootcfg-file
+                                                              "/"))))))
+
   (maybe-raise-unsupported-configuration-error machine)
-  (mbegin %store-monad
-    (switch-to-system machine)
-    (upgrade-shepherd-services machine)
-    (install-bootloader machine)))
+  (mapm %store-monad (cut <> machine)
+        (list run-switch-to-system
+              run-install-bootloader
+              run-upgrade-shepherd-services)))
 
 \f
 ;;;
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 0008746fe..2207b2d34 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -40,10 +40,12 @@
             unknown-shepherd-error?
             unknown-shepherd-error-sexp
 
+            live-service
             live-service?
             live-service-provision
             live-service-requirement
             live-service-running
+            live-service-canonical-name
 
             with-shepherd-action
             current-services
@@ -192,6 +194,10 @@ of pairs."
   (requirement  live-service-requirement)         ;list of symbols
   (running      live-service-running))            ;#f | object
 
+(define (live-service-canonical-name service)
+  "Return the 'canonical name' of SERVICE."
+  (first (live-service-provision service)))
+
 (define (current-services)
   "Return the list of currently defined Shepherd services, represented as
 <live-service> objects.  Return #f if the list of services could not be
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 60c1ca5c9..21858ee7d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -70,6 +70,7 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:export (guix-system
+            bootloader-installer-script
             read-operating-system))
 
 \f
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 000000000..9491bde34
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,170 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 (guix scripts system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu system)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:export (switch-system-program
+            upgrade-services-program
+            install-bootloader-program))
+
+;;; Commentary:
+;;;
+;;; This module implements the "effectful" parts of system
+;;; reconfiguration. Although building a system derivation is a pure
+;;; operation, a number of impure operations must be carried out for the
+;;; system configuration to be realized -- chiefly, creation of generation
+;;; symlinks and invocation of activation scripts.
+;;;
+;;; Code:
+
+(define* (switch-system-program os #:optional profile)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will create a new generation of PROFILE pointing to the
+directory of OS, switch to it atomically, and run OS's activation script,
+returning any textual output produced by the activation script as a string."
+  (gexp->script
+   "switch-to-system.scm"
+   (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 profile
+             (or #$profile (string-append %state-directory "/profiles/system")))
+
+           (let* ((number (1+ (generation-number profile)))
+                  (generation (generation-file-name profile number)))
+             (switch-symlinks generation #$os)
+             (switch-symlinks profile generation)
+             (setenv "GUIX_NEW_SYSTEM" #$os)
+             (with-output-to-string
+               (lambda ()
+                 (primitive-load
+                  #$(operating-system-activation-script os))))))))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program target-services)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will upgrade the Shepherd (PID 1) by unloading obsolete
+services and loading new services. TARGET-SERVICES is a list
+of (shepherd-service-canonical-name, shepherd-service-file) pairs used for
+determining which services are obsolete, as well as which are new."
+  (gexp->script
+   "upgrade-shepherd-services.scm"
+   (with-imported-modules '((gnu services herd))
+    #~(begin
+        (use-modules (gnu services herd)
+                     (srfi srfi-1))
+
+        (define (call-with-shepherd-error-handling proc)
+          (lambda (service)
+            (catch 'system-error
+              (lambda ()
+                (proc service)
+                #f)
+              (lambda (key proc format-string format-args errno . rest)
+                (apply format #f format-string format-args)))))
+
+        (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))
+
+        ;; Load the service files for any new services.
+        (load-services/safe (map second to-start))
+
+        ;; Unload obsolete services and start new services.
+        (filter string?
+                (append (map (call-with-shepherd-error-handling unload-service)
+                             to-unload)
+                        (map (call-with-shepherd-error-handling start-service)
+                             (map first to-start))))))))
+
+(define (install-bootloader-program installer-script bootcfg bootcfg-file target)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target file name, on
+TARGET, a mount point, and subsequently run INSTALLER-SCRIPT, returning any
+textual output produced by the installer script as a string."
+  (gexp->script
+   "install-bootloader.scm"
+   (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 #$target %gc-roots-directory "/bootcfg"))
+                  (temp-gc-root (string-append gc-root ".new")))
+
+             (switch-symlinks temp-gc-root gc-root)
+
+             (let ((installer-result
+                    (false-if-exception
+                     (begin
+                       (install-boot-config #$bootcfg #$bootcfg-file #$target)
+                       (with-output-to-string
+                         (lambda ()
+                           (when #$installer-script
+                             (primitive-load #$installer-script))))))))
+               (unless installer-result
+                 (delete-file temp-gc-root)
+                 (error "failed to install bootloader"))
+               (rename-file temp-gc-root gc-root)
+               installer-result)))))))
diff --git a/tests/services.scm b/tests/services.scm
index 44ad0022c..572fe3816 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -26,10 +26,6 @@
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
-(define live-service
-  (@@ (gnu services herd) live-service))
-
-\f
 (test-begin "services")
 
 (test-equal "services, default value"
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v3 2/3] guix system: Reimplement 'reconfigure'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 18139 bytes --]

* guix/scripts/system.scm (switch-to-system)
(upgrade-shepherd-services, install-bootloader): Delete variable.
* guix/scripts/system.scm (%switch-to-system)
(%upgrade-shepherd-services, %install-bootloader): New variable.
---
 guix/scripts/system.scm             | 151 +++++++++-------------------
 guix/scripts/system/reconfigure.scm | 116 +++++++--------------
 2 files changed, 79 insertions(+), 188 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 21858ee7d..b59818577 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,7 @@
                                        delete-matching-generations)
   #:use-module (guix graph)
   #:use-module (guix scripts graph)
+  #:use-module (guix scripts system reconfigure)
   #:use-module (guix build utils)
   #:use-module (guix progress)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -179,38 +180,14 @@ TARGET, and register them."
 
     (return *unspecified*)))
 
-(define* (install-bootloader installer
-                             #:key
-                             bootcfg bootcfg-file
-                             target)
+(define (install-bootloader installer bootcfg bootcfg-file target)
   "Run INSTALLER, a bootloader installation script, with error handling, in
 %STORE-MONAD."
-  (mlet %store-monad ((installer-drv (if installer
-                                         (lower-object installer)
-                                         (return #f)))
-                      (bootcfg       (lower-object bootcfg)))
-    (let* ((gc-root      (string-append target %gc-roots-directory
-                                        "/bootcfg"))
-           (temp-gc-root (string-append gc-root ".new"))
-           (install (and installer-drv
-                         (derivation->output-path installer-drv)))
-           (bootcfg (derivation->output-path bootcfg)))
-      ;; Prepare the symlink to bootloader config file to make sure that it's
-      ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
-      (switch-symlinks temp-gc-root bootcfg)
-
-      (unless (false-if-exception
-               (begin
-                 (install-boot-config bootcfg bootcfg-file target)
-                 (when install
-                   (save-load-path-excursion (primitive-load install)))))
-        (delete-file temp-gc-root)
-        (leave (G_ "failed to install bootloader ~a~%") install))
-
-      ;; Register bootloader config file as a GC root so that its dependencies
-      ;; (background image, font, etc.) are not reclaimed.
-      (rename-file temp-gc-root gc-root)
-      (return #t))))
+  (mlet* %store-monad ((file (lower-object
+                              (install-bootloader-program installer bootcfg
+                                                          bootcfg-file target)))
+                       (_ (built-derivations (list file))))
+    (return (primitive-load (derivation->output-path file)))))
 
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
@@ -266,10 +243,8 @@ the ownership of '~a' may be incorrect!~%")
         (populate os-dir target)
 
         (mwhen install-bootloader?
-          (install-bootloader bootloader-installer
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader bootloader-installer bootcfg
+                              bootcfg-file target))))))
 
 \f
 ;;;
@@ -343,74 +318,39 @@ services specified in OS and not currently running.
 This is currently very conservative in that it does not stop or unload any
 running service.  Unloading or stopping the wrong service ('udev', say) could
 bring the system down."
-  (define new-services
+  (define target-services
     (service-value
      (fold-services (operating-system-services os)
                     #:target-type shepherd-root-service-type)))
 
-  ;; Arrange to simply emit a warning if the service upgrade fails.
-  (with-shepherd-error-handling
-   (call-with-service-upgrade-info new-services
-     (lambda (to-restart to-unload)
-        (for-each (lambda (unload)
-                    (info (G_ "unloading service '~a'...~%") unload)
-                    (unload-service unload))
-                  to-unload)
-
-        (with-monad %store-monad
-          (munless (null? new-services)
-            (let ((new-service-names  (map shepherd-service-canonical-name new-services))
-                  (to-restart-names   (map shepherd-service-canonical-name to-restart))
-                  (to-start           (filter shepherd-service-auto-start? new-services)))
-              (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
-              (unless (null? to-restart-names)
-                ;; Listing TO-RESTART-NAMES in the message below wouldn't help
-                ;; because many essential services cannot be meaningfully
-                ;; restarted.  See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
-                (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n")))
-              (mlet %store-monad ((files (mapm %store-monad
-                                               (compose lower-object
-                                                        shepherd-service-file)
-                                               new-services)))
-                ;; Here we assume that FILES are exactly those that were computed
-                ;; as part of the derivation that built OS, which is normally the
-                ;; case.
-                (load-services/safe (map derivation->output-path files))
-
-                (for-each start-service
-                          (map shepherd-service-canonical-name to-start))
-                (return #t)))))))))
-
-(define* (switch-to-system os
-                           #:optional (profile %system-profile))
-  "Make a new generation of PROFILE pointing to the directory of OS, switch to
-it atomically, and then run OS's activation script."
-  (mlet* %store-monad ((drv (operating-system-derivation os))
-                       (script (lower-object (operating-system-activation-script os))))
-    (let* ((system     (derivation->output-path drv))
-           (number     (+ 1 (generation-number profile)))
-           (generation (generation-file-name profile number)))
-      (switch-symlinks generation system)
-      (switch-symlinks profile generation)
-
-      (format #t (G_ "activating system...~%"))
-
-      ;; The activation script may change $PATH, among others, so protect
-      ;; against that.
-      (save-environment-excursion
-       ;; Tell 'activate-current-system' what the new system is.
-       (setenv "GUIX_NEW_SYSTEM" system)
-
-       ;; The activation script may modify '%load-path' & co., so protect
-       ;; against that.  This is necessary to ensure that
-       ;; 'upgrade-shepherd-services' gets to see the right modules when it
-       ;; computes derivations with 'gexp->derivation'.
-       (save-load-path-excursion
-        (primitive-load (derivation->output-path script))))
-
-      ;; Finally, try to update system services.
-      (upgrade-shepherd-services os))))
+  (let-values (((to-unload to-restart)
+                (shepherd-service-upgrade (current-services) target-services)))
+    (let* ((to-unload (map live-service-canonical-name to-unload))
+           (to-restart (map shepherd-service-canonical-name to-restart))
+           (to-start (lset-difference
+                      eqv?
+                      (map shepherd-service-canonical-name target-services)
+                      (map live-service-canonical-name (current-services))))
+           (service-files
+            (map shepherd-service-file
+                 (filter (lambda (service)
+                           (memq (shepherd-service-canonical-name service)
+                                 to-start))
+                         target-services))))
+      (mlet* %store-monad ((file (lower-object
+                                  (upgrade-services-program service-files
+                                                            to-start
+                                                            to-unload
+                                                            to-restart)))
+                           (_ (built-derivations (list file))))
+        (return (primitive-load (derivation->output-path file)))))))
+
+(define (switch-to-system os)
+  "Make a new generation of PROFILE pointing to the directory of OS, switch
+to it atomically, and then run OS's activation script."
+  (mlet* %store-monad ((file (lower-object (switch-system-program os)))
+                       (_ (built-derivations (list file))))
+    (return (primitive-load (derivation->output-path file)))))
 
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
@@ -514,10 +454,7 @@ STORE is an open connection to the store."
           (built-derivations drvs)
           ;; Only install bootloader configuration file. Thus, no installer is
           ;; provided here.
-          (install-bootloader #f
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader #f bootcfg bootcfg-file target))))))
 
 \f
 ;;;
@@ -918,13 +855,15 @@ static checks."
 
           (case action
             ((reconfigure)
+             (newline)
+             (format #t (G_ "activating system...~%"))
              (mbegin %store-monad
                (switch-to-system os)
                (mwhen install-bootloader?
-                 (install-bootloader bootloader-script
-                                     #:bootcfg bootcfg
-                                     #:bootcfg-file bootcfg-file
-                                     #:target "/"))))
+                 (install-bootloader bootloader-script bootcfg
+                                     bootcfg-file (or target "/")))
+               (with-shepherd-error-handling
+                (upgrade-shepherd-services os))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 9491bde34..1ef656f0c 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -42,11 +42,11 @@
 ;;; Code:
 
 (define* (switch-system-program os #:optional profile)
-  "Return as a monadic value a derivation to build a scheme file that, upon
-being evaluated, will create a new generation of PROFILE pointing to the
-directory of OS, switch to it atomically, and run OS's activation script,
-returning any textual output produced by the activation script as a string."
-  (gexp->script
+  "Return an executable store item that, upon being evaluated, will create a
+new generation of PROFILE pointing to the directory of OS, switch to it
+atomically, and run OS's activation script, returning any textual output
+produced by the activation script as a string."
+  (program-file
    "switch-to-system.scm"
    (with-extensions (list guile-gcrypt)
      (with-imported-modules (source-module-closure '((guix config)
@@ -65,82 +65,36 @@ returning any textual output produced by the activation script as a string."
              (switch-symlinks generation #$os)
              (switch-symlinks profile generation)
              (setenv "GUIX_NEW_SYSTEM" #$os)
-             (with-output-to-string
-               (lambda ()
-                 (primitive-load
-                  #$(operating-system-activation-script os))))))))))
+             (primitive-load #$(operating-system-activation-script os))))))))
 
 ;; XXX: Currently, this does NOT attempt to restart running services. See
 ;; <https://issues.guix.info/issue/33508> for details.
-(define (upgrade-services-program target-services)
-  "Return as a monadic value a derivation to build a scheme file that, upon
-being evaluated, will upgrade the Shepherd (PID 1) by unloading obsolete
-services and loading new services. TARGET-SERVICES is a list
-of (shepherd-service-canonical-name, shepherd-service-file) pairs used for
-determining which services are obsolete, as well as which are new."
-  (gexp->script
+(define (upgrade-services-program service-files to-start to-unload to-restart)
+  "Return an executable store item that, upon being evaluated, will upgrade
+the Shepherd (PID 1) by unloading obsolete services and loading new
+services. SERVICE-FILES is a list of Shepherd service files to load, and
+TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services'
+canonical names (symbols)."
+  (program-file
    "upgrade-shepherd-services.scm"
    (with-imported-modules '((gnu services herd))
     #~(begin
         (use-modules (gnu services herd)
                      (srfi srfi-1))
 
-        (define (call-with-shepherd-error-handling proc)
-          (lambda (service)
-            (catch 'system-error
-              (lambda ()
-                (proc service)
-                #f)
-              (lambda (key proc format-string format-args errno . rest)
-                (apply format #f format-string format-args)))))
-
-        (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))
-
         ;; Load the service files for any new services.
-        (load-services/safe (map second to-start))
+        (load-services/safe '#$service-files)
 
         ;; Unload obsolete services and start new services.
-        (filter string?
-                (append (map (call-with-shepherd-error-handling unload-service)
-                             to-unload)
-                        (map (call-with-shepherd-error-handling start-service)
-                             (map first to-start))))))))
+        (for-each unload-service '#$to-unload)
+        (for-each start-service '#$to-start)))))
 
 (define (install-bootloader-program installer-script bootcfg bootcfg-file target)
-  "Return as a monadic value a derivation to build a scheme file that, upon
-being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target file name, on
-TARGET, a mount point, and subsequently run INSTALLER-SCRIPT, returning any
-textual output produced by the installer script as a string."
-  (gexp->script
+  "Return an executable store item that, upon being evaluated, will install
+BOOTCFG to BOOTCFG-FILE, a target file name, on TARGET, a mount point, and
+subsequently run INSTALLER-SCRIPT, returning any textual output produced by
+the installer script as a string."
+  (program-file
    "install-bootloader.scm"
    (with-extensions (list guile-gcrypt)
      (with-imported-modules (source-module-closure '((gnu build install)
@@ -152,19 +106,17 @@ textual output produced by the installer script as a string."
                         (guix utils))
            (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
                   (temp-gc-root (string-append gc-root ".new")))
-
              (switch-symlinks temp-gc-root gc-root)
-
-             (let ((installer-result
-                    (false-if-exception
-                     (begin
-                       (install-boot-config #$bootcfg #$bootcfg-file #$target)
-                       (with-output-to-string
-                         (lambda ()
-                           (when #$installer-script
-                             (primitive-load #$installer-script))))))))
-               (unless installer-result
-                 (delete-file temp-gc-root)
-                 (error "failed to install bootloader"))
-               (rename-file temp-gc-root gc-root)
-               installer-result)))))))
+             (install-boot-config #$bootcfg #$bootcfg-file #$target)
+             ;; Preserve the previous activation's garbage collector root
+             ;; until the bootloader installer has run, so that a failure in
+             ;; the bootloader's installer script doesn't leave the user with
+             ;; a broken installation.
+             (when #$installer-script
+               (catch #t
+                 (lambda ()
+                   (primitive-load #$installer-script))
+                 (lambda args
+                   (delete-file temp-gc-root)
+                   (apply throw args))))
+             (rename-file temp-gc-root gc-root)))))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v3 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 11637 bytes --]

* gnu/tests/reconfigure.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk              |   1 +
 gnu/tests/reconfigure.scm | 268 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 269 insertions(+)
 create mode 100644 gnu/tests/reconfigure.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 0e17af953..b334d0572 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -592,6 +592,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/mail.scm				\
   %D%/tests/messaging.scm			\
   %D%/tests/networking.scm			\
+  %D%/tests/reconfigure.scm			\
   %D%/tests/rsync.scm				\
   %D%/tests/security-token.scm			\
   %D%/tests/singularity.scm			\
diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm
new file mode 100644
index 000000000..251e96b3e
--- /dev/null
+++ b/gnu/tests/reconfigure.scm
@@ -0,0 +1,268 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 tests reconfigure)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services networking)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu services)
+  #:use-module (gnu system vm)
+  #:use-module (gnu system)
+  #:use-module (gnu tests)
+  #:use-module (guix derivations)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix scripts system)
+  #:use-module (guix scripts system reconfigure)
+  #:use-module (guix store)
+  #:export (%test-switch-to-system
+            %test-upgrade-services
+            %test-install-bootloader))
+
+;;; Commentary:
+;;;
+;;; Test in-place system reconfiguration: advancing the system generation on a
+;;; running instance of the Guix System.
+;;;
+;;; Code:
+
+(define* (run-switch-to-system-test)
+  "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new
+generation of the system profile."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (define (system-generations marionette)
+            "Return the names of the generation symlinks on MARIONETTE."
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 ftw)
+                             (srfi srfi-1))
+                (let* ((profile-dir "/var/guix/profiles/")
+                       (entries (map first (cddr (file-system-tree profile-dir)))))
+                  (remove (lambda (entry)
+                            (member entry '("per-user" "system")))
+                          entries)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "switch-to-system")
+
+          (let ((generations-prior (system-generations marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$script)
+               marionette))
+
+            (test-equal "script created new generation"
+              (length (system-generations marionette))
+              (1+ (length generations-prior))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "switch-to-system" (test (switch-system-program os))))
+
+(define* (run-upgrade-services-test)
+  "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the
+Shepherd (PID 1) by unloading obsolete services and loading new services."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define dummy-service
+    ;; Shepherd service that does nothing, for the sole purpose of ensuring
+    ;; that it is properly installed and started by the script.
+    (shepherd-service (provision '(dummy))
+                      (start #~(const #t))
+                      (stop #~(const #t))
+                      (respawn? #f)))
+
+  (define (ensure-service-file service)
+    "Return the Shepherd service file for SERVICE, after ensuring that it
+exists in the store"
+    (let ((file (shepherd-service-file service)))
+      (mlet* %store-monad ((store-object (lower-object file))
+                           (_ (built-derivations (list store-object))))
+        (return file))))
+
+  (define (test enable-dummy disable-dummy)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (define (running-services marionette)
+            "Return the names of the running services on MARIONETTE."
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (map live-service-canonical-name (current-services)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "upgrade-services")
+
+          (let ((services-prior (running-services marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$enable-dummy)
+               marionette))
+
+            (test-assert "script started new service"
+              (and (not (memq 'dummy services-prior))
+                   (memq 'dummy (running-services marionette))))
+
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$disable-dummy)
+               marionette))
+
+            (test-assert "script stopped new service"
+              (not (memq 'dummy (running-services marionette)))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (mlet* %store-monad ((file (ensure-service-file dummy-service)))
+    (let ((enable (upgrade-services-program (list file) '(dummy) '() '()))
+          (disable (upgrade-services-program '() '() '(dummy) '())))
+      (gexp->derivation "upgrade-services" (test enable disable)))))
+
+(define* (run-install-bootloader-test)
+  "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
+bootloader's configuration file."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (ice-9 regex)
+                       (srfi srfi-1)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (define (generations-in-grub-cfg marionette)
+            "Return the system generation paths that have GRUB menu entries."
+            (let ((grub-cfg (marionette-eval
+                             '(begin
+                                (call-with-input-file "/boot/grub/grub.cfg"
+                                  (lambda (port)
+                                    (get-string-all port))))
+                             marionette)))
+              (map (lambda (parameter)
+                     (second (string-split (match:substring parameter) #\=)))
+                   (list-matches "system=[^ ]*" grub-cfg))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "install-bootloader")
+
+
+          (test-assert "no prior menu entry for system generation"
+            (not (member #$os (generations-in-grub-cfg marionette))))
+
+          (test-assert "script successfully evaluated"
+            (marionette-eval
+             '(primitive-load #$script)
+             marionette))
+
+          (test-assert "menu entry created for system generation"
+            (member #$os (generations-in-grub-cfg marionette)))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (let* ((bootloader ((compose bootloader-configuration-bootloader
+                               operating-system-bootloader)
+                      os))
+         (target (bootloader-configuration-target
+                  (operating-system-bootloader os)))
+         ;; The typical use-case for 'install-bootloader-program' is to read
+         ;; the boot parameters for the existing menu entries on the system,
+         ;; parse them with 'boot-parameters->menu-entry', and pass the
+         ;; results to 'operating-system-bootcfg'. However, to obtain boot
+         ;; parameters, we would need to start the marionette, which we should
+         ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we
+         ;; generate a bootloader configuration for the script as if there
+         ;; were no existing menu entries. In the grand scheme of things, this
+         ;; matters little -- these tests should not make assertions about the
+         ;; behavior of 'operating-system-bootcfg'.
+         (bootcfg (operating-system-bootcfg os '()))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (gexp->derivation
+     "install-bootloader"
+     ;; Due to the read-only nature of the virtual machines used in the system
+     ;; test suite, the bootloader installer script is omitted. 'grub-install'
+     ;; would attempt to write directly to the virtual disk if the
+     ;; installation script were run.
+     (test (install-bootloader-program #f bootcfg bootcfg-file "/")))))
+
+(define %test-switch-to-system
+  (system-test
+   (name "switch-to-system")
+   (description "Create a new generation of the system profile.")
+   (value (run-switch-to-system-test))))
+
+(define %test-upgrade-services
+  (system-test
+   (name "upgrade-services")
+   (description "Upgrade the Shepherd by unloading obsolete services and
+loading new services.")
+   (value (run-upgrade-services-test))))
+
+(define %test-install-bootloader
+  (system-test
+   (name "install-bootloader")
+   (description "Install a bootloader and its configuration file.")
+   (value (run-install-bootloader-test))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v3 1/3] guix system: Add 'reconfigure' module.

[Ludovic Courtès]

Hello!

I’m gladly waiting for v4, having read your latest message.  :-)
It seems to be going in a nice direction!

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> * guix/scripts/system/reconfigure.scm: New file.
> * Makefile.am (MODULES): Add it.
> * guix/scripts/system.scm (bootloader-installer-script): Export variable.
> * gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
> (install-bootloader): Delete variable.
> * gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
> * gnu/services/herd.scm (live-service): Export variable.
> * gnu/services/herd.scm (live-service-canonical-name): New variable.
> * tests/services.scm (live-service): Delete variable.

I should have mentioned it before, but it would be nice if there could
be one commit that moves things to guix/scripts/system/reconfigure.scm,
and a second commit that actually modifies it.  That would make it
easier to visualize the changes made to that code.

Thanks,
Ludo’.

[bug#36555] [PATCH v3 0/3] Refactor out common behavior for system reconfiguration.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 4513 bytes --]

Hello to anyone reviewing this patch,

I probably should've held off on sending this reroll out. After taking
some more time to experiment with possible solutions, I was able to
figure most of this out. Comments would still be appreciated, but the
points I specifically asked for comments on no longer need special
treatment. Also, if you haven't already started reviewing this, v4 will
likely hit the mailing list tomorrow; everything's there, it just needs
to be cleaned up.

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) writes:

> I still need to handle failed deployments in 'guix deploy'. I suspect
> that, for now, it would make sense to implement remote roll-backs and
> just roll-back the system on failure, at least until we've have some
> dialog about the proper way to do atomic deployments.

Well, except for this. I'll submit a separate patch series addressing
this.

> My biggest concern at the moment is error handling reporting in the
> new 'guix system reconfigure'. I'd like to emulate what was done with
> the previous version, but I'm at somewhat of a loss for how I'd go
> about that, since the error reporting was mixed with the
> reconfiguration code. So I'd like to ask for some suggestions: is the
> best way to catch errors in '%store-monad' to do what
> 'with-shepherd-error-handling' does, and then 'leave' on failure?
>
> Ludovic suggested guarding against 'message-condition' and having the
> expression I send to 'remote-eval' return either ('error message) or
> ('success). Would it make sense to just do this in all of the
> reconfiguration procedures? Or is raising exceptions in the
> reconfiguration procedures and catching them in the scripts' code the
> way to go?

Comments, if anyone has them, would be appreciated, but I feel that I'm
in a good spot in terms of error handling now.

> There's also a slight bug in the new 'guix system reconfigure' that
> I'll need to figure out. At the moment, it installs a bootloader entry
> for all but the newest generation.

It wasn't actually a bug, I was misinterpreting the intended behavior of
'guix system reconfigure'. :)

> Oh, how naïve I was four days ago. This reroll doesn't address this.
> Having the procedures "parameterized by an evaluation procedure" can
> be done in so many ways, and I think it would be best I put some
> serious thought into which of those ways would be the best. A
> 'local-eval' would clearly be much better than what I'm doing at the
> present in 'system.scm', but the solution I came up with today
> involved three layers of 'primitive-load', which I doubt is the way to
> go about it. I had the idea to parameterize on a procedure that takes
> a '<program-file>' rather than a G-Expression as I was making dinner
> tonight, which seems to me like a sound idea, but we'll see if it
> works tomorrow when I try to implement it.

Actually, a more generalized 'eval' (taking a G-Expression) was the
better way to go: it allowed me to simplify the interface to the
reconfiguration procedures even further. And, thanks to Ludovic's recent
patches with 'lower-gexp', I was able to collapse the Russian nesting
doll of 'primitive-load' calls.

> Also, it hit me today that the safety checks done in 'guix system
> reconfigure' -- 'check-mapped-devices',
> 'check-file-system-availability', and 'check-initrd-modules' -- should
> also be done in 'guix deploy'. It might make sense for me to submit that
> change as a separate patch series so the code review for this doesn't
> get too complicated, but since we're on the topic of unifying the code
> between 'guix deploy' and 'guix system reconfigure', should I perhaps
> reimplement those procedures as '<program-file>' objects like everything
> else in '(guix scripts system reconfigure)'? They aren't really
> effectful, but they concern system reconfiguration.

Again, separate patch series.

> And, on the same note, should I go ahead and refactor the rest of the
> reconfiguration code in 'system.scm' out into '(guix scripts system
> reconfigure)'? I mean, this will probably be a separate patch series for
> the same reason that the safety checks would be a separate patch series,
> and I'll likely do this _after_ I come up with a decent way to
> parameterize on an evaluation procedure, but I'd like to know if it's a
> good idea or not before going ahead and ripping apart 'system.scm'.

I'd still like comments on this, though.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v4 0/3] Refactor out common behavior for system reconfiguration.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 964 bytes --]

This addresses nearly everything I mentioned in my v3 cover letter;
we're now parameterizing on an 'eval' procedure and we've got error
handling where it counts.

Happy Friday!

Jakob L. Kreuze (3):
  guix system: Add 'reconfigure' module.
  guix system: Reimplement 'reconfigure'.
  tests: Add reconfigure system test.

 Makefile.am                         |   1 +
 gnu/local.mk                        |   1 +
 gnu/machine/ssh.scm                 | 189 ++------------------
 gnu/services/herd.scm               |   6 +
 gnu/tests/reconfigure.scm           | 263 ++++++++++++++++++++++++++++
 guix/scripts/system.scm             | 182 +++++--------------
 guix/scripts/system/reconfigure.scm | 241 +++++++++++++++++++++++++
 tests/services.scm                  |   4 -
 8 files changed, 563 insertions(+), 324 deletions(-)
 create mode 100644 gnu/tests/reconfigure.scm
 create mode 100644 guix/scripts/system/reconfigure.scm

-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v4 1/3] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 24873 bytes --]

* guix/scripts/system/reconfigure.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/system.scm (bootloader-installer-script): Export variable.
* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
* gnu/services/herd.scm (live-service): Export variable.
* gnu/services/herd.scm (live-service-canonical-name): New variable.
* tests/services.scm (live-service): Delete variable.
---
 Makefile.am                         |   1 +
 gnu/machine/ssh.scm                 | 189 ++--------------------
 gnu/services/herd.scm               |   6 +
 guix/scripts/system/reconfigure.scm | 241 ++++++++++++++++++++++++++++
 tests/services.scm                  |   4 -
 5 files changed, 260 insertions(+), 181 deletions(-)
 create mode 100644 guix/scripts/system/reconfigure.scm

diff --git a/Makefile.am b/Makefile.am
index dd7720e87..58a96d348 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -245,6 +245,7 @@ MODULES =					\
   guix/scripts/describe.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
+  guix/scripts/system/reconfigure.scm		\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index a7d1a967a..64d92acc9 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,23 +17,21 @@
 ;;; 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 services)
-  #:use-module (gnu services shepherd)
   #:use-module (gnu system)
-  #:use-module (guix derivations)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix modules)
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix remote)
+  #: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 +103,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 +161,20 @@ 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)))
+  (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
+    (let* ((os (machine-system machine))
+           (eval (cut machine-remote-eval machine <>))
+           (menu-entries (map boot-parameters->menu-entry boot-parameters))
+           (bootloader-configuration (operating-system-bootloader os))
+           (bootcfg (operating-system-bootcfg os menu-entries)))
+      (mbegin %store-monad
+        (switch-to-system eval os)
+        (upgrade-shepherd-services eval os)
+        (install-bootloader eval bootloader-configuration bootcfg)))))
 
 \f
 ;;;
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 0008746fe..2207b2d34 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -40,10 +40,12 @@
             unknown-shepherd-error?
             unknown-shepherd-error-sexp
 
+            live-service
             live-service?
             live-service-provision
             live-service-requirement
             live-service-running
+            live-service-canonical-name
 
             with-shepherd-action
             current-services
@@ -192,6 +194,10 @@ of pairs."
   (requirement  live-service-requirement)         ;list of symbols
   (running      live-service-running))            ;#f | object
 
+(define (live-service-canonical-name service)
+  "Return the 'canonical name' of SERVICE."
+  (first (live-service-provision service)))
+
 (define (current-services)
   "Return the list of currently defined Shepherd services, represented as
 <live-service> objects.  Return #f if the list of services could not be
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 000000000..2c69ea727
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,241 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 (guix scripts system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services)
+  #:use-module (gnu services herd)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:export (switch-system-program
+            switch-to-system
+
+            upgrade-services-program
+            upgrade-shepherd-services
+
+            install-bootloader-program
+            install-bootloader))
+
+;;; Commentary:
+;;;
+;;; This module implements the "effectful" parts of system
+;;; reconfiguration. Although building a system derivation is a pure
+;;; operation, a number of impure operations must be carried out for the
+;;; system configuration to be realized -- chiefly, creation of generation
+;;; symlinks and invocation of activation scripts.
+;;;
+;;; Code:
+
+\f
+;;;
+;;; Profile creation.
+;;;
+
+(define* (switch-system-program os #:optional profile)
+  "Return an executable store item that, upon being evaluated, will create a
+new generation of PROFILE pointing to the directory of OS, switch to it
+atomically, and run OS's activation script."
+  (program-file
+   "switch-to-system.scm"
+   (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 profile
+             (or #$profile (string-append %state-directory "/profiles/system")))
+
+           (let* ((number (1+ (generation-number profile)))
+                  (generation (generation-file-name profile number)))
+             (switch-symlinks generation #$os)
+             (switch-symlinks profile generation)
+             (setenv "GUIX_NEW_SYSTEM" #$os)
+             (primitive-load #$(operating-system-activation-script os))))))))
+
+(define* (switch-to-system eval os #:optional profile)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+create a new generation of PROFILE pointing to the directory of OS, switch to
+it atomically, and run OS's activation script."
+  (eval #~(primitive-load #$(switch-system-program os profile))))
+
+\f
+;;;
+;;; Services.
+;;;
+
+(define (running-services eval)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+return the <live-service> objects that are currently running on MACHINE."
+  (define remote-exp
+    (with-imported-modules '((gnu services herd))
+      #~(begin
+          (use-modules (gnu services herd))
+          (let ((services (current-services)))
+            (and services
+                 ;; 'live-service-running' is ignored, as we can't necessarily
+                 ;; serialize arbitrary objects. This should be fine for now,
+                 ;; since 'machine-current-services' is not exposed publicly,
+                 ;; and the resultant <live-service> objects are only used for
+                 ;; resolving service dependencies.
+                 (map (lambda (service)
+                        (list (live-service-provision service)
+                              (live-service-requirement service)))
+                      services))))))
+  (mlet %store-monad ((services (eval remote-exp)))
+    (return (map (match-lambda
+                   ((provision requirement)
+                    (live-service provision requirement #f)))
+                 services))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program service-files to-start to-unload to-restart)
+  "Return an executable store item that, upon being evaluated, will upgrade
+the Shepherd (PID 1) by unloading obsolete services and loading new
+services. SERVICE-FILES is a list of Shepherd service files to load, and
+TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services'
+canonical names (symbols)."
+  (program-file
+   "upgrade-shepherd-services.scm"
+   (with-imported-modules '((gnu services herd))
+    #~(begin
+        (use-modules (gnu services herd)
+                     (srfi srfi-1))
+
+        ;; Load the service files for any new services.
+        (load-services/safe '#$service-files)
+
+        ;; Unload obsolete services and start new services.
+        (for-each unload-service '#$to-unload)
+        (for-each start-service '#$to-start)))))
+
+(define* (upgrade-shepherd-services eval os)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
+services as defined by OS."
+  (define target-services
+    (service-value
+     (fold-services (operating-system-services os)
+                    #:target-type shepherd-root-service-type)))
+
+  (mlet* %store-monad ((live-services (running-services eval)))
+    (let*-values (((to-unload to-restart)
+                   (shepherd-service-upgrade live-services target-services)))
+      (let* ((to-unload (map live-service-canonical-name to-unload))
+             (to-restart (map shepherd-service-canonical-name to-restart))
+             (to-start (lset-difference eqv?
+                                        (map shepherd-service-canonical-name
+                                             target-services)
+                                        (map live-service-canonical-name
+                                             live-services)))
+             (service-files
+              (map shepherd-service-file
+                   (filter (lambda (service)
+                             (memq (shepherd-service-canonical-name service)
+                                   to-start))
+                           target-services))))
+        (eval #~(primitive-load #$(upgrade-services-program service-files
+                                                            to-start
+                                                            to-unload
+                                                            to-restart)))))))
+
+\f
+;;;
+;;; Bootloader configuration.
+;;;
+
+;; (format (current-error-port) "error: ~a~%" (condition-message c))
+;; (format #t "bootloader successfully installed on '~a'~%"
+;;                              #$device)
+
+(define (install-bootloader-program installer bootloader-package bootcfg
+                                    bootcfg-file device target)
+  "Return an executable store item that, upon being evaluated, will install
+BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device,
+at TARGET, a mount point, and subsequently run INSTALLER from
+BOOTLOADER-PACKAGE."
+  (program-file
+   "install-bootloader.scm"
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules (source-module-closure '((gnu build bootloader)
+                                                     (gnu build install)
+                                                     (guix store)
+                                                     (guix utils)))
+       #~(begin
+           (use-modules (gnu build bootloader)
+                        (gnu build install)
+                        (guix build utils)
+                        (guix store)
+                        (guix utils)
+                        (ice-9 binary-ports)
+                        (srfi srfi-34)
+                        (srfi srfi-35))
+           (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
+                  (temp-gc-root (string-append gc-root ".new")))
+             (switch-symlinks temp-gc-root gc-root)
+             (install-boot-config #$bootcfg #$bootcfg-file #$target)
+             ;; Preserve the previous activation's garbage collector root
+             ;; until the bootloader installer has run, so that a failure in
+             ;; the bootloader's installer script doesn't leave the user with
+             ;; a broken installation.
+             (when #$installer
+               (catch #t
+                 (lambda ()
+                   (#$installer #$bootloader-package #$device #$target))
+                 (lambda args
+                   (delete-file temp-gc-root)
+                   (apply throw args))))
+             (rename-file temp-gc-root gc-root)))))))
+
+(define* (install-bootloader eval configuration bootcfg
+                             #:key
+                             (run-installer? #t)
+                             (target "/"))
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+configure the bootloader on TARGET such that OS will be booted by default and
+additional configurations specified by MENU-ENTRIES can be selected."
+  (let* ((bootloader (bootloader-configuration-bootloader configuration))
+         (installer (and run-installer?
+                         (bootloader-installer bootloader)))
+         (package (bootloader-package bootloader))
+         (device (bootloader-configuration-target configuration))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (eval #~(primitive-load #$(install-bootloader-program installer
+                                                          package
+                                                          bootcfg
+                                                          bootcfg-file
+                                                          device
+                                                          target)))))
diff --git a/tests/services.scm b/tests/services.scm
index 44ad0022c..572fe3816 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -26,10 +26,6 @@
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
-(define live-service
-  (@@ (gnu services herd) live-service))
-
-\f
 (test-begin "services")
 
 (test-equal "services, default value"
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v4 2/3] guix system: Reimplement 'reconfigure'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 13094 bytes --]

* guix/scripts/system.scm (switch-to-system)
(upgrade-shepherd-services, install-bootloader): Delete variable.
* guix/scripts/system.scm (local-eval): New variable.
---
 guix/scripts/system.scm | 182 +++++++++-------------------------------
 1 file changed, 39 insertions(+), 143 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 60c1ca5c9..da515bb79 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,7 @@
                                        delete-matching-generations)
   #:use-module (guix graph)
   #:use-module (guix scripts graph)
+  #:use-module (guix scripts system reconfigure)
   #:use-module (guix build utils)
   #:use-module (guix progress)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -178,43 +179,9 @@ TARGET, and register them."
 
     (return *unspecified*)))
 
-(define* (install-bootloader installer
-                             #:key
-                             bootcfg bootcfg-file
-                             target)
-  "Run INSTALLER, a bootloader installation script, with error handling, in
-%STORE-MONAD."
-  (mlet %store-monad ((installer-drv (if installer
-                                         (lower-object installer)
-                                         (return #f)))
-                      (bootcfg       (lower-object bootcfg)))
-    (let* ((gc-root      (string-append target %gc-roots-directory
-                                        "/bootcfg"))
-           (temp-gc-root (string-append gc-root ".new"))
-           (install (and installer-drv
-                         (derivation->output-path installer-drv)))
-           (bootcfg (derivation->output-path bootcfg)))
-      ;; Prepare the symlink to bootloader config file to make sure that it's
-      ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
-      (switch-symlinks temp-gc-root bootcfg)
-
-      (unless (false-if-exception
-               (begin
-                 (install-boot-config bootcfg bootcfg-file target)
-                 (when install
-                   (save-load-path-excursion (primitive-load install)))))
-        (delete-file temp-gc-root)
-        (leave (G_ "failed to install bootloader ~a~%") install))
-
-      ;; Register bootloader config file as a GC root so that its dependencies
-      ;; (background image, font, etc.) are not reclaimed.
-      (rename-file temp-gc-root gc-root)
-      (return #t))))
-
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
-                  bootloader-installer install-bootloader?
-                  bootcfg bootcfg-file)
+                  install-bootloader? bootloader bootcfg)
   "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
 directory TARGET.  TARGET must be an absolute directory name since that's what
 'register-path' expects.
@@ -265,10 +232,11 @@ the ownership of '~a' may be incorrect!~%")
         (populate os-dir target)
 
         (mwhen install-bootloader?
-          (install-bootloader bootloader-installer
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader local-eval bootloader bootcfg
+                              #:target target)
+          (return
+           (format #t "bootloader successfully installed on '~a'~%"
+                   (bootloader-configuration-target bootloader))))))))
 
 \f
 ;;;
@@ -335,82 +303,6 @@ unload."
        (warning (G_ "failed to obtain list of shepherd services~%"))
        (return #f)))))
 
-(define (upgrade-shepherd-services os)
-  "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
-services specified in OS and not currently running.
-
-This is currently very conservative in that it does not stop or unload any
-running service.  Unloading or stopping the wrong service ('udev', say) could
-bring the system down."
-  (define new-services
-    (service-value
-     (fold-services (operating-system-services os)
-                    #:target-type shepherd-root-service-type)))
-
-  ;; Arrange to simply emit a warning if the service upgrade fails.
-  (with-shepherd-error-handling
-   (call-with-service-upgrade-info new-services
-     (lambda (to-restart to-unload)
-        (for-each (lambda (unload)
-                    (info (G_ "unloading service '~a'...~%") unload)
-                    (unload-service unload))
-                  to-unload)
-
-        (with-monad %store-monad
-          (munless (null? new-services)
-            (let ((new-service-names  (map shepherd-service-canonical-name new-services))
-                  (to-restart-names   (map shepherd-service-canonical-name to-restart))
-                  (to-start           (filter shepherd-service-auto-start? new-services)))
-              (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
-              (unless (null? to-restart-names)
-                ;; Listing TO-RESTART-NAMES in the message below wouldn't help
-                ;; because many essential services cannot be meaningfully
-                ;; restarted.  See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
-                (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n")))
-              (mlet %store-monad ((files (mapm %store-monad
-                                               (compose lower-object
-                                                        shepherd-service-file)
-                                               new-services)))
-                ;; Here we assume that FILES are exactly those that were computed
-                ;; as part of the derivation that built OS, which is normally the
-                ;; case.
-                (load-services/safe (map derivation->output-path files))
-
-                (for-each start-service
-                          (map shepherd-service-canonical-name to-start))
-                (return #t)))))))))
-
-(define* (switch-to-system os
-                           #:optional (profile %system-profile))
-  "Make a new generation of PROFILE pointing to the directory of OS, switch to
-it atomically, and then run OS's activation script."
-  (mlet* %store-monad ((drv (operating-system-derivation os))
-                       (script (lower-object (operating-system-activation-script os))))
-    (let* ((system     (derivation->output-path drv))
-           (number     (+ 1 (generation-number profile)))
-           (generation (generation-file-name profile number)))
-      (switch-symlinks generation system)
-      (switch-symlinks profile generation)
-
-      (format #t (G_ "activating system...~%"))
-
-      ;; The activation script may change $PATH, among others, so protect
-      ;; against that.
-      (save-environment-excursion
-       ;; Tell 'activate-current-system' what the new system is.
-       (setenv "GUIX_NEW_SYSTEM" system)
-
-       ;; The activation script may modify '%load-path' & co., so protect
-       ;; against that.  This is necessary to ensure that
-       ;; 'upgrade-shepherd-services' gets to see the right modules when it
-       ;; computes derivations with 'gexp->derivation'.
-       (save-load-path-excursion
-        (primitive-load (derivation->output-path script))))
-
-      ;; Finally, try to update system services.
-      (upgrade-shepherd-services os))))
-
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
     (lambda ()
@@ -505,18 +397,13 @@ STORE is an open connection to the store."
                      ((bootloader-configuration-file-generator bootloader)
                       bootloader-config entries
                       #:old-entries old-entries)))
-           (bootcfg-file -> (bootloader-configuration-file bootloader))
-           (target -> "/")
            (drvs -> (list bootcfg)))
         (mbegin %store-monad
           (show-what-to-build* drvs)
           (built-derivations drvs)
-          ;; Only install bootloader configuration file. Thus, no installer is
-          ;; provided here.
-          (install-bootloader #f
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          ;; Only install bootloader configuration file.
+          (install-bootloader local-eval bootloader-config bootcfg
+                              #:run-installer? #f))))))
 
 \f
 ;;;
@@ -825,6 +712,20 @@ and TARGET arguments."
                        (format #t "bootloader successfully installed on '~a'~%"
                                #$device))))))
 
+(define (local-eval exp)
+  "Evaluate EXP, a G-Expression, in-place."
+  (mlet* %store-monad ((lowered (lower-gexp exp))
+                       (_ (built-derivations (map gexp-input-thing
+                                                  (lowered-gexp-inputs lowered)))))
+    (save-load-path-excursion
+     (set! %load-path (lowered-gexp-load-path lowered))
+     (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
+     (return
+      (guard (c ((message-condition? c)
+                 (leave (G_ "failed to install bootloader:~%~a~%")
+                        (condition-message c))))
+        (primitive-eval (lowered-gexp-sexp lowered)))))))
+
 (define* (perform-action action os
                          #:key skip-safety-checks?
                          install-bootloader?
@@ -860,19 +761,12 @@ static checks."
         (map boot-parameters->menu-entry (profile-boot-parameters))))
 
   (define bootloader
-    (bootloader-configuration-bootloader (operating-system-bootloader os)))
+    (operating-system-bootloader os))
 
   (define bootcfg
     (and (memq action '(init reconfigure))
          (operating-system-bootcfg os menu-entries)))
 
-  (define bootloader-script
-    (let ((installer (bootloader-installer bootloader))
-          (target    (or target "/")))
-      (bootloader-installer-script installer
-                                   (bootloader-package bootloader)
-                                   bootloader-target target)))
-
   (when (eq? action 'reconfigure)
     (maybe-suggest-running-guix-pull))
 
@@ -899,9 +793,7 @@ static checks."
        ;; See <http://bugs.gnu.org/21068>.
        (drvs      (mapm %store-monad lower-object
                         (if (memq action '(init reconfigure))
-                            (if install-bootloader?
-                                (list sys bootcfg bootloader-script)
-                                (list sys bootcfg))
+                            (list sys bootcfg)
                             (list sys))))
        (%         (if derivations-only?
                       (return (for-each (compose println derivation-file-name)
@@ -911,28 +803,32 @@ static checks."
 
     (if (or dry-run? derivations-only?)
         (return #f)
-        (let ((bootcfg-file (bootloader-configuration-file bootloader)))
+        (begin
           (for-each (compose println derivation->output-path)
                     drvs)
 
           (case action
             ((reconfigure)
+             (newline)
+             (format #t (G_ "activating system...~%"))
              (mbegin %store-monad
-               (switch-to-system os)
+               (switch-to-system local-eval os)
                (mwhen install-bootloader?
-                 (install-bootloader bootloader-script
-                                     #:bootcfg bootcfg
-                                     #:bootcfg-file bootcfg-file
-                                     #:target "/"))))
+                 (install-bootloader local-eval bootloader bootcfg
+                                     #:target (or target "/"))
+                 (return
+                  (format #t "bootloader successfully installed on '~a'~%"
+                          (bootloader-configuration-target bootloader))))
+               (with-shepherd-error-handling
+                (upgrade-shepherd-services local-eval os))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
                      target)
              (install sys (canonicalize-path target)
                       #:install-bootloader? install-bootloader?
-                      #:bootcfg bootcfg
-                      #:bootcfg-file bootcfg-file
-                      #:bootloader-installer bootloader-script))
+                      #:bootloader bootloader
+                      #:bootcfg bootcfg))
             (else
              ;; All we had to do was to build SYS and maybe register an
              ;; indirect GC root.
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 11422 bytes --]

* gnu/tests/reconfigure.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk              |   1 +
 gnu/tests/reconfigure.scm | 263 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 264 insertions(+)
 create mode 100644 gnu/tests/reconfigure.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 0e17af953..b334d0572 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -592,6 +592,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/mail.scm				\
   %D%/tests/messaging.scm			\
   %D%/tests/networking.scm			\
+  %D%/tests/reconfigure.scm			\
   %D%/tests/rsync.scm				\
   %D%/tests/security-token.scm			\
   %D%/tests/singularity.scm			\
diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm
new file mode 100644
index 000000000..022492e05
--- /dev/null
+++ b/gnu/tests/reconfigure.scm
@@ -0,0 +1,263 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 tests reconfigure)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system vm)
+  #:use-module (gnu system)
+  #:use-module (gnu tests)
+  #:use-module (guix derivations)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix scripts system reconfigure)
+  #:use-module (guix store)
+  #:export (%test-switch-to-system
+            %test-upgrade-services
+            %test-install-bootloader))
+
+;;; Commentary:
+;;;
+;;; Test in-place system reconfiguration: advancing the system generation on a
+;;; running instance of the Guix System.
+;;;
+;;; Code:
+
+(define* (run-switch-to-system-test)
+  "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new
+generation of the system profile."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (define (system-generations marionette)
+            "Return the names of the generation symlinks on MARIONETTE."
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 ftw)
+                             (srfi srfi-1))
+                (let* ((profile-dir "/var/guix/profiles/")
+                       (entries (map first (cddr (file-system-tree profile-dir)))))
+                  (remove (lambda (entry)
+                            (member entry '("per-user" "system")))
+                          entries)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "switch-to-system")
+
+          (let ((generations-prior (system-generations marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$script)
+               marionette))
+
+            (test-equal "script created new generation"
+              (length (system-generations marionette))
+              (1+ (length generations-prior))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "switch-to-system" (test (switch-system-program os))))
+
+(define* (run-upgrade-services-test)
+  "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the
+Shepherd (PID 1) by unloading obsolete services and loading new services."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define dummy-service
+    ;; Shepherd service that does nothing, for the sole purpose of ensuring
+    ;; that it is properly installed and started by the script.
+    (shepherd-service (provision '(dummy))
+                      (start #~(const #t))
+                      (stop #~(const #t))
+                      (respawn? #f)))
+
+  (define (ensure-service-file service)
+    "Return the Shepherd service file for SERVICE, after ensuring that it
+exists in the store"
+    (let ((file (shepherd-service-file service)))
+      (mlet* %store-monad ((store-object (lower-object file))
+                           (_ (built-derivations (list store-object))))
+        (return file))))
+
+  (define (test enable-dummy disable-dummy)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (define (running-services marionette)
+            "Return the names of the running services on MARIONETTE."
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (map live-service-canonical-name (current-services)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "upgrade-services")
+
+          (let ((services-prior (running-services marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$enable-dummy)
+               marionette))
+
+            (test-assert "script started new service"
+              (and (not (memq 'dummy services-prior))
+                   (memq 'dummy (running-services marionette))))
+
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$disable-dummy)
+               marionette))
+
+            (test-assert "script stopped new service"
+              (not (memq 'dummy (running-services marionette)))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (mlet* %store-monad ((file (ensure-service-file dummy-service)))
+    (let ((enable (upgrade-services-program (list file) '(dummy) '() '()))
+          (disable (upgrade-services-program '() '() '(dummy) '())))
+      (gexp->derivation "upgrade-services" (test enable disable)))))
+
+(define* (run-install-bootloader-test)
+  "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
+bootloader's configuration file."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (ice-9 regex)
+                       (srfi srfi-1)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (define (generations-in-grub-cfg marionette)
+            "Return the system generation paths that have GRUB menu entries."
+            (let ((grub-cfg (marionette-eval
+                             '(begin
+                                (call-with-input-file "/boot/grub/grub.cfg"
+                                  (lambda (port)
+                                    (get-string-all port))))
+                             marionette)))
+              (map (lambda (parameter)
+                     (second (string-split (match:substring parameter) #\=)))
+                   (list-matches "system=[^ ]*" grub-cfg))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "install-bootloader")
+
+
+          (test-assert "no prior menu entry for system generation"
+            (not (member #$os (generations-in-grub-cfg marionette))))
+
+          (test-assert "script successfully evaluated"
+            (marionette-eval
+             '(primitive-load #$script)
+             marionette))
+
+          (test-assert "menu entry created for system generation"
+            (member #$os (generations-in-grub-cfg marionette)))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (let* ((bootloader ((compose bootloader-configuration-bootloader
+                               operating-system-bootloader)
+                      os))
+         ;; The typical use-case for 'install-bootloader-program' is to read
+         ;; the boot parameters for the existing menu entries on the system,
+         ;; parse them with 'boot-parameters->menu-entry', and pass the
+         ;; results to 'operating-system-bootcfg'. However, to obtain boot
+         ;; parameters, we would need to start the marionette, which we should
+         ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we
+         ;; generate a bootloader configuration for the script as if there
+         ;; were no existing menu entries. In the grand scheme of things, this
+         ;; matters little -- these tests should not make assertions about the
+         ;; behavior of 'operating-system-bootcfg'.
+         (bootcfg (operating-system-bootcfg os '()))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (gexp->derivation
+     "install-bootloader"
+     ;; Due to the read-only nature of the virtual machines used in the system
+     ;; test suite, the bootloader installer script is omitted. 'grub-install'
+     ;; would attempt to write directly to the virtual disk if the
+     ;; installation script were run.
+     (test (install-bootloader-program #f #f bootcfg bootcfg-file #f "/")))))
+
+(define %test-switch-to-system
+  (system-test
+   (name "switch-to-system")
+   (description "Create a new generation of the system profile.")
+   (value (run-switch-to-system-test))))
+
+(define %test-upgrade-services
+  (system-test
+   (name "upgrade-services")
+   (description "Upgrade the Shepherd by unloading obsolete services and
+loading new services.")
+   (value (run-upgrade-services-test))))
+
+(define %test-install-bootloader
+  (system-test
+   (name "install-bootloader")
+   (description "Install a bootloader and its configuration file.")
+   (value (run-install-bootloader-test))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test.

[Ludovic Courtès]

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> * gnu/tests/reconfigure.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.

That’s really cool!

> +          (test-begin "switch-to-system")
> +
> +          (let ((generations-prior (system-generations marionette)))
> +            (test-assert "script successfully evaluated"
> +              (marionette-eval
> +               '(primitive-load #$script)
> +               marionette))
> +
> +            (test-equal "script created new generation"
> +              (length (system-generations marionette))
> +              (1+ (length generations-prior))))

Perhaps you could also check the target of /run/current-system, and
maybe check things like the set of user accounts (activation code)?

> +(define* (run-upgrade-services-test)
> +  "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the
> +Shepherd (PID 1) by unloading obsolete services and loading new services."
> +  (define os
> +    (marionette-operating-system
> +     (simple-operating-system)
> +     #:imported-modules '((gnu services herd)
> +                          (guix combinators))))
> +
> +  (define vm (virtual-machine os))
> +
> +  (define dummy-service
> +    ;; Shepherd service that does nothing, for the sole purpose of ensuring
> +    ;; that it is properly installed and started by the script.
> +    (shepherd-service (provision '(dummy))
> +                      (start #~(const #t))
> +                      (stop #~(const #t))
> +                      (respawn? #f)))
> +
> +  (define (ensure-service-file service)
> +    "Return the Shepherd service file for SERVICE, after ensuring that it
> +exists in the store"

No need for docstrings for inner procedures; a comment is enough.

> +            (test-assert "script started new service"
> +              (and (not (memq 'dummy services-prior))
> +                   (memq 'dummy (running-services marionette))))
> +
> +            (test-assert "script successfully evaluated"
> +              (marionette-eval
> +               '(primitive-load #$disable-dummy)
> +               marionette))
> +
> +            (test-assert "script stopped new service"
                                            ^
s/new/obsolete/, no?

Perhaps you could also check for the availability of a “replacement”
slot (info "(shepherd) Slots of services") for services that exist both
before and after the upgrade?  This could be achieved by augmenting (gnu
services herd) with a ‘live-service-replacement’ procedure, I think.

The rest LGTM!

I think you’ve reached the most difficult part of this whole endeavor.
The good thing is that, once you’re past this, things will be much
easier.

Thank you!

Ludo’.

[bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 5110 bytes --]

Hi, Ludovic!

Ludovic Courtès <ludo@gnu.org> writes:

> Really nice that it becomes this concise.

Yeah, I think (and hope) this is a good sign that we've picked the
right abstraction for this :)

> I like to avoid exposing constructors so that one cannot “forge”
> invalid objects, but let’s see…

Should I use @@ for this, perhaps? Aside from one other place in the
test suite, it's a one-off use, and the objects are then only used
internally.

> I wonder it we should just use
>
>   #~(begin (use-modules (guix build utils)) (invoke …))
>
> here and in other places.
>
> That’s probably better longer-term (for example when we switch to
> Guile 3, that could ease the transition since the right Guile would be
> used) but we can keep it this way and revisit it later.

Oh that's a good point, I agree that we should do that. I'll submit a
separate patch once this gets merged.

> s/remote-exp/exp/
> ...
> A leftover?  :-)
>
> These two statements disappeared in the process, but I think they’re
> added back by one of the subsequent patches, right?

Good catches, thanks! Yes, the code is added back in the commits that
follow.

> OK, that makes sense here.
>
> (Once we’ve done that (guix graph) demonadification we discussed
> before, perhaps we can perform run ‘shepherd-service-upgrade’ entirely
> on the “other side”, and at that point we won’t need to expose the
> ‘live-service’ constructor.)

The main issue with calling 'shepherd-service-upgrade' on the other side
is that we'd need to send over the service objects (the current
'upgrade-services-program' deals with provision symbols rather than the
service objects themselves).

I'm certain it's possible, it's just easier said than done. I've got
time to think it through, though :)

> No need to repeat the file name here.
>
> However there are other changes no mentioned here, for example changes
> to the ‘install’ procedure. Could you add them to the log?
>
> While you’re at it, could you change it to:
>
>   (info (G_ "bootloader successfully installed on '~a'~%") …)
>
> ?

Yep, sure thing.

> What happens when ‘install-bootloader’ fails though? We should make
> sure that the error is diagnosed, and that the output of
> ‘grub-install’ or similar is shown when that happens.

> Note that there are now a few places where we call ‘built-derivations’
> without calling ‘show-what-to-build*’ first. That means the UX might
> be pretty bad since one has no idea what’s being built.
>
> Furthermore, that means substitutes may not be up-to-date, leading to
> many “updating substitutes” messages and HTTP round trips (as happened
> with <https://issues.guix.gnu.org/issue/36509>).
>
> Last, doing several ‘build-derivations’ call with just a couple of
> derivations is less efficient than doing a single call with many
> derivations; that also has an impact on the UI, if we were to call
> ‘show-what-to-build*’ once for ‘build-derivations’ call.
>
> What’s your experience with this in practice?

I haven't had too many issues with it since the G-Expressions tended to
have few inputs, but those are some valid concerns. Would it be better
to create derivations for locally-evaluated G-Expressions? For example,
with 'program-file' or 'gexp->script'? I thought that evaluating them
in-place might be better since that's one fewer store item that needs to
be built, but if we were to turn the G-Expression into a derivation, we
could add it to the call to 'show-what-to-build*' in 'guix system
reconfigure'.

> Eventually we should add it to (guix gexp).

Yeah, that seems to make more sense. I can move it when I address the
above.

> Last but not least, make sure to test this on your machine.  :-)
>
> It’s sensitive code that we’d rather not break.

Heh, indeed! I've run it several times in a virtual machine, but running
it on my desktop is the ultimate "I promise this works, and if it
doesn't, I'll eat my hat." I'll do an update on this machine and report
back.

> Perhaps you could also check the target of /run/current-system, and
> maybe check things like the set of user accounts (activation code)?
>
> Perhaps you could also check for the availability of a “replacement”
> slot (info "(shepherd) Slots of services") for services that exist
> both before and after the upgrade? This could be achieved by
> augmenting (gnu services herd) with a ‘live-service-replacement’
> procedure, I think.

Great ideas! In the interest of keeping this patch manageable, I'll
submit these improvements separately.

> No need for docstrings for inner procedures; a comment is enough.
> ...
> s/new/obsolete/, no?

I can address these in my corrections, though.

> I think you’ve reached the most difficult part of this whole endeavor.
> The good thing is that, once you’re past this, things will be much
> easier.

Agreed, I think this gives us a good framework for implementing
provisioning etc.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 492 bytes --]

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) writes:

>> What happens when ‘install-bootloader’ fails though? We should make
>> sure that the error is diagnosed, and that the output of
>> ‘grub-install’ or similar is shown when that happens.

Apologies, forgot to respond to this point. This is handled in
'local-eval'.

(guard (c ((message-condition? c)
           (leave (G_ "failed to install bootloader:~%~a~%")
                  (condition-message c))))
  ...

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v5 0/3] Refactor out common behavior for system reconfiguration.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 2005 bytes --]

I'm feeling pretty good about this :)

jakob@Epsilon ~/Code/guix [env] $ sudo -E ./pre-inst-env guix system reconfigure ~/.config/guix/system/config.scm 
substitute: updating substitutes from 'https://ci.guix.gnu.org'... 100.0%
The following derivation will be built:
   /gnu/store/327py2dv6xjlm0xanqiqj1paxxx8g1rq-grub.cfg.drv
building /gnu/store/327py2dv6xjlm0xanqiqj1paxxx8g1rq-grub.cfg.drv...
/gnu/store/h45l455dg3wi6b24m0v8as5wdjskpfsm-system
/gnu/store/razfpshw9n33dvm4bp0d2jwpdf4255hf-grub.cfg

activating system...
making '/gnu/store/h45l455dg3wi6b24m0v8as5wdjskpfsm-system' the current system...
setting up setuid programs in '/run/setuid-programs'...
populating /etc from /gnu/store/glzrd1cb6ngzwqvnph3q3pbxxjv8nprs-etc...
substitute: updating substitutes from 'https://ci.guix.gnu.org'... 100.0%
building /gnu/store/8vn3dlcmhri0f3ygfhqavlab2q35q2yn-install-bootloader.scm.drv...
guix system: bootloader successfully installed on '/dev/sda'
substitute: updating substitutes from 'https://ci.guix.gnu.org'... 100.0%
building /gnu/store/43cyy0nnrdr6wg9xzcph6shs4w7gfxi6-upgrade-shepherd-services.scm.drv...
shepherd: Evaluating user expression (let* ((services (map primitive-load (?))) # ?) ?).

Jakob L. Kreuze (3):
  guix system: Add 'reconfigure' module.
  guix system: Reimplement 'reconfigure'.
  tests: Add reconfigure system test.

 Makefile.am                         |   1 +
 gnu/local.mk                        |   1 +
 gnu/machine/ssh.scm                 | 189 ++------------------
 gnu/services/herd.scm               |   6 +
 gnu/tests/reconfigure.scm           | 262 ++++++++++++++++++++++++++++
 guix/scripts/system.scm             | 186 +++++---------------
 guix/scripts/system/reconfigure.scm | 237 +++++++++++++++++++++++++
 tests/services.scm                  |   4 -
 8 files changed, 560 insertions(+), 326 deletions(-)
 create mode 100644 gnu/tests/reconfigure.scm
 create mode 100644 guix/scripts/system/reconfigure.scm

-- 
2.22.0

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v5 1/3] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 24677 bytes --]

* guix/scripts/system/reconfigure.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/system.scm (bootloader-installer-script): Export variable.
* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
* gnu/services/herd.scm (live-service): Export variable.
* gnu/services/herd.scm (live-service-canonical-name): New variable.
* tests/services.scm (live-service): Delete variable.
---
 Makefile.am                         |   1 +
 gnu/machine/ssh.scm                 | 189 ++--------------------
 gnu/services/herd.scm               |   6 +
 guix/scripts/system/reconfigure.scm | 237 ++++++++++++++++++++++++++++
 tests/services.scm                  |   4 -
 5 files changed, 256 insertions(+), 181 deletions(-)
 create mode 100644 guix/scripts/system/reconfigure.scm

diff --git a/Makefile.am b/Makefile.am
index dd7720e87..58a96d348 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -245,6 +245,7 @@ MODULES =					\
   guix/scripts/describe.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
+  guix/scripts/system/reconfigure.scm		\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index a7d1a967a..64d92acc9 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,23 +17,21 @@
 ;;; 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 services)
-  #:use-module (gnu services shepherd)
   #:use-module (gnu system)
-  #:use-module (guix derivations)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix modules)
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix remote)
+  #: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 +103,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 +161,20 @@ 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)))
+  (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
+    (let* ((os (machine-system machine))
+           (eval (cut machine-remote-eval machine <>))
+           (menu-entries (map boot-parameters->menu-entry boot-parameters))
+           (bootloader-configuration (operating-system-bootloader os))
+           (bootcfg (operating-system-bootcfg os menu-entries)))
+      (mbegin %store-monad
+        (switch-to-system eval os)
+        (upgrade-shepherd-services eval os)
+        (install-bootloader eval bootloader-configuration bootcfg)))))
 
 \f
 ;;;
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 0008746fe..2207b2d34 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -40,10 +40,12 @@
             unknown-shepherd-error?
             unknown-shepherd-error-sexp
 
+            live-service
             live-service?
             live-service-provision
             live-service-requirement
             live-service-running
+            live-service-canonical-name
 
             with-shepherd-action
             current-services
@@ -192,6 +194,10 @@ of pairs."
   (requirement  live-service-requirement)         ;list of symbols
   (running      live-service-running))            ;#f | object
 
+(define (live-service-canonical-name service)
+  "Return the 'canonical name' of SERVICE."
+  (first (live-service-provision service)))
+
 (define (current-services)
   "Return the list of currently defined Shepherd services, represented as
 <live-service> objects.  Return #f if the list of services could not be
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 000000000..8c7d46158
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,237 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 (guix scripts system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services)
+  #:use-module (gnu services herd)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:export (switch-system-program
+            switch-to-system
+
+            upgrade-services-program
+            upgrade-shepherd-services
+
+            install-bootloader-program
+            install-bootloader))
+
+;;; Commentary:
+;;;
+;;; This module implements the "effectful" parts of system
+;;; reconfiguration. Although building a system derivation is a pure
+;;; operation, a number of impure operations must be carried out for the
+;;; system configuration to be realized -- chiefly, creation of generation
+;;; symlinks and invocation of activation scripts.
+;;;
+;;; Code:
+
+\f
+;;;
+;;; Profile creation.
+;;;
+
+(define* (switch-system-program os #:optional profile)
+  "Return an executable store item that, upon being evaluated, will create a
+new generation of PROFILE pointing to the directory of OS, switch to it
+atomically, and run OS's activation script."
+  (program-file
+   "switch-to-system.scm"
+   (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 profile
+             (or #$profile (string-append %state-directory "/profiles/system")))
+
+           (let* ((number (1+ (generation-number profile)))
+                  (generation (generation-file-name profile number)))
+             (switch-symlinks generation #$os)
+             (switch-symlinks profile generation)
+             (setenv "GUIX_NEW_SYSTEM" #$os)
+             (primitive-load #$(operating-system-activation-script os))))))))
+
+(define* (switch-to-system eval os #:optional profile)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+create a new generation of PROFILE pointing to the directory of OS, switch to
+it atomically, and run OS's activation script."
+  (eval #~(primitive-load #$(switch-system-program os profile))))
+
+\f
+;;;
+;;; Services.
+;;;
+
+(define (running-services eval)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+return the <live-service> objects that are currently running on MACHINE."
+  (define exp
+    (with-imported-modules '((gnu services herd))
+      #~(begin
+          (use-modules (gnu services herd))
+          (let ((services (current-services)))
+            (and services
+                 ;; 'live-service-running' is ignored, as we can't necessarily
+                 ;; serialize arbitrary objects. This should be fine for now,
+                 ;; since 'machine-current-services' is not exposed publicly,
+                 ;; and the resultant <live-service> objects are only used for
+                 ;; resolving service dependencies.
+                 (map (lambda (service)
+                        (list (live-service-provision service)
+                              (live-service-requirement service)))
+                      services))))))
+  (mlet %store-monad ((services (eval exp)))
+    (return (map (match-lambda
+                   ((provision requirement)
+                    (live-service provision requirement #f)))
+                 services))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program service-files to-start to-unload to-restart)
+  "Return an executable store item that, upon being evaluated, will upgrade
+the Shepherd (PID 1) by unloading obsolete services and loading new
+services. SERVICE-FILES is a list of Shepherd service files to load, and
+TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services'
+canonical names (symbols)."
+  (program-file
+   "upgrade-shepherd-services.scm"
+   (with-imported-modules '((gnu services herd))
+    #~(begin
+        (use-modules (gnu services herd)
+                     (srfi srfi-1))
+
+        ;; Load the service files for any new services.
+        (load-services/safe '#$service-files)
+
+        ;; Unload obsolete services and start new services.
+        (for-each unload-service '#$to-unload)
+        (for-each start-service '#$to-start)))))
+
+(define* (upgrade-shepherd-services eval os)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
+services as defined by OS."
+  (define target-services
+    (service-value
+     (fold-services (operating-system-services os)
+                    #:target-type shepherd-root-service-type)))
+
+  (mlet* %store-monad ((live-services (running-services eval)))
+    (let*-values (((to-unload to-restart)
+                   (shepherd-service-upgrade live-services target-services)))
+      (let* ((to-unload (map live-service-canonical-name to-unload))
+             (to-restart (map shepherd-service-canonical-name to-restart))
+             (to-start (lset-difference eqv?
+                                        (map shepherd-service-canonical-name
+                                             target-services)
+                                        (map live-service-canonical-name
+                                             live-services)))
+             (service-files
+              (map shepherd-service-file
+                   (filter (lambda (service)
+                             (memq (shepherd-service-canonical-name service)
+                                   to-start))
+                           target-services))))
+        (eval #~(primitive-load #$(upgrade-services-program service-files
+                                                            to-start
+                                                            to-unload
+                                                            to-restart)))))))
+
+\f
+;;;
+;;; Bootloader configuration.
+;;;
+
+(define (install-bootloader-program installer bootloader-package bootcfg
+                                    bootcfg-file device target)
+  "Return an executable store item that, upon being evaluated, will install
+BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device,
+at TARGET, a mount point, and subsequently run INSTALLER from
+BOOTLOADER-PACKAGE."
+  (program-file
+   "install-bootloader.scm"
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules (source-module-closure '((gnu build bootloader)
+                                                     (gnu build install)
+                                                     (guix store)
+                                                     (guix utils)))
+       #~(begin
+           (use-modules (gnu build bootloader)
+                        (gnu build install)
+                        (guix build utils)
+                        (guix store)
+                        (guix utils)
+                        (ice-9 binary-ports)
+                        (srfi srfi-34)
+                        (srfi srfi-35))
+           (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
+                  (temp-gc-root (string-append gc-root ".new")))
+             (switch-symlinks temp-gc-root gc-root)
+             (install-boot-config #$bootcfg #$bootcfg-file #$target)
+             ;; Preserve the previous activation's garbage collector root
+             ;; until the bootloader installer has run, so that a failure in
+             ;; the bootloader's installer script doesn't leave the user with
+             ;; a broken installation.
+             (when #$installer
+               (catch #t
+                 (lambda ()
+                   (#$installer #$bootloader-package #$device #$target))
+                 (lambda args
+                   (delete-file temp-gc-root)
+                   (apply throw args))))
+             (rename-file temp-gc-root gc-root)))))))
+
+(define* (install-bootloader eval configuration bootcfg
+                             #:key
+                             (run-installer? #t)
+                             (target "/"))
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+configure the bootloader on TARGET such that OS will be booted by default and
+additional configurations specified by MENU-ENTRIES can be selected."
+  (let* ((bootloader (bootloader-configuration-bootloader configuration))
+         (installer (and run-installer?
+                         (bootloader-installer bootloader)))
+         (package (bootloader-package bootloader))
+         (device (bootloader-configuration-target configuration))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (eval #~(primitive-load #$(install-bootloader-program installer
+                                                          package
+                                                          bootcfg
+                                                          bootcfg-file
+                                                          device
+                                                          target)))))
diff --git a/tests/services.scm b/tests/services.scm
index 44ad0022c..572fe3816 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -26,10 +26,6 @@
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
-(define live-service
-  (@@ (gnu services herd) live-service))
-
-\f
 (test-begin "services")
 
 (test-equal "services, default value"
-- 
2.22.0

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v5 2/3] guix system: Reimplement 'reconfigure'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 13438 bytes --]

* guix/scripts/system.scm (switch-to-system)
(upgrade-shepherd-services, install-bootloader): Delete variable.
(local-eval): New variable.
(install): Remove 'bootloader-installer' and 'bootcfg-file' parameters.
(install): Add 'bootloader' parameter.
---
 guix/scripts/system.scm | 186 +++++++++-------------------------------
 1 file changed, 41 insertions(+), 145 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 60c1ca5c9..0a7a585af 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,7 @@
                                        delete-matching-generations)
   #:use-module (guix graph)
   #:use-module (guix scripts graph)
+  #:use-module (guix scripts system reconfigure)
   #:use-module (guix build utils)
   #:use-module (guix progress)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -178,43 +179,9 @@ TARGET, and register them."
 
     (return *unspecified*)))
 
-(define* (install-bootloader installer
-                             #:key
-                             bootcfg bootcfg-file
-                             target)
-  "Run INSTALLER, a bootloader installation script, with error handling, in
-%STORE-MONAD."
-  (mlet %store-monad ((installer-drv (if installer
-                                         (lower-object installer)
-                                         (return #f)))
-                      (bootcfg       (lower-object bootcfg)))
-    (let* ((gc-root      (string-append target %gc-roots-directory
-                                        "/bootcfg"))
-           (temp-gc-root (string-append gc-root ".new"))
-           (install (and installer-drv
-                         (derivation->output-path installer-drv)))
-           (bootcfg (derivation->output-path bootcfg)))
-      ;; Prepare the symlink to bootloader config file to make sure that it's
-      ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
-      (switch-symlinks temp-gc-root bootcfg)
-
-      (unless (false-if-exception
-               (begin
-                 (install-boot-config bootcfg bootcfg-file target)
-                 (when install
-                   (save-load-path-excursion (primitive-load install)))))
-        (delete-file temp-gc-root)
-        (leave (G_ "failed to install bootloader ~a~%") install))
-
-      ;; Register bootloader config file as a GC root so that its dependencies
-      ;; (background image, font, etc.) are not reclaimed.
-      (rename-file temp-gc-root gc-root)
-      (return #t))))
-
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
-                  bootloader-installer install-bootloader?
-                  bootcfg bootcfg-file)
+                  install-bootloader? bootloader bootcfg)
   "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
 directory TARGET.  TARGET must be an absolute directory name since that's what
 'register-path' expects.
@@ -265,10 +232,11 @@ the ownership of '~a' may be incorrect!~%")
         (populate os-dir target)
 
         (mwhen install-bootloader?
-          (install-bootloader bootloader-installer
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader local-eval bootloader bootcfg
+                              #:target target)
+          (return
+           (info (G_ "bootloader successfully installed on '~a'~%")
+                 (bootloader-configuration-target bootloader))))))))
 
 \f
 ;;;
@@ -335,82 +303,6 @@ unload."
        (warning (G_ "failed to obtain list of shepherd services~%"))
        (return #f)))))
 
-(define (upgrade-shepherd-services os)
-  "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
-services specified in OS and not currently running.
-
-This is currently very conservative in that it does not stop or unload any
-running service.  Unloading or stopping the wrong service ('udev', say) could
-bring the system down."
-  (define new-services
-    (service-value
-     (fold-services (operating-system-services os)
-                    #:target-type shepherd-root-service-type)))
-
-  ;; Arrange to simply emit a warning if the service upgrade fails.
-  (with-shepherd-error-handling
-   (call-with-service-upgrade-info new-services
-     (lambda (to-restart to-unload)
-        (for-each (lambda (unload)
-                    (info (G_ "unloading service '~a'...~%") unload)
-                    (unload-service unload))
-                  to-unload)
-
-        (with-monad %store-monad
-          (munless (null? new-services)
-            (let ((new-service-names  (map shepherd-service-canonical-name new-services))
-                  (to-restart-names   (map shepherd-service-canonical-name to-restart))
-                  (to-start           (filter shepherd-service-auto-start? new-services)))
-              (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
-              (unless (null? to-restart-names)
-                ;; Listing TO-RESTART-NAMES in the message below wouldn't help
-                ;; because many essential services cannot be meaningfully
-                ;; restarted.  See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
-                (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n")))
-              (mlet %store-monad ((files (mapm %store-monad
-                                               (compose lower-object
-                                                        shepherd-service-file)
-                                               new-services)))
-                ;; Here we assume that FILES are exactly those that were computed
-                ;; as part of the derivation that built OS, which is normally the
-                ;; case.
-                (load-services/safe (map derivation->output-path files))
-
-                (for-each start-service
-                          (map shepherd-service-canonical-name to-start))
-                (return #t)))))))))
-
-(define* (switch-to-system os
-                           #:optional (profile %system-profile))
-  "Make a new generation of PROFILE pointing to the directory of OS, switch to
-it atomically, and then run OS's activation script."
-  (mlet* %store-monad ((drv (operating-system-derivation os))
-                       (script (lower-object (operating-system-activation-script os))))
-    (let* ((system     (derivation->output-path drv))
-           (number     (+ 1 (generation-number profile)))
-           (generation (generation-file-name profile number)))
-      (switch-symlinks generation system)
-      (switch-symlinks profile generation)
-
-      (format #t (G_ "activating system...~%"))
-
-      ;; The activation script may change $PATH, among others, so protect
-      ;; against that.
-      (save-environment-excursion
-       ;; Tell 'activate-current-system' what the new system is.
-       (setenv "GUIX_NEW_SYSTEM" system)
-
-       ;; The activation script may modify '%load-path' & co., so protect
-       ;; against that.  This is necessary to ensure that
-       ;; 'upgrade-shepherd-services' gets to see the right modules when it
-       ;; computes derivations with 'gexp->derivation'.
-       (save-load-path-excursion
-        (primitive-load (derivation->output-path script))))
-
-      ;; Finally, try to update system services.
-      (upgrade-shepherd-services os))))
-
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
     (lambda ()
@@ -505,18 +397,13 @@ STORE is an open connection to the store."
                      ((bootloader-configuration-file-generator bootloader)
                       bootloader-config entries
                       #:old-entries old-entries)))
-           (bootcfg-file -> (bootloader-configuration-file bootloader))
-           (target -> "/")
            (drvs -> (list bootcfg)))
         (mbegin %store-monad
           (show-what-to-build* drvs)
           (built-derivations drvs)
-          ;; Only install bootloader configuration file. Thus, no installer is
-          ;; provided here.
-          (install-bootloader #f
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          ;; Only install bootloader configuration file.
+          (install-bootloader local-eval bootloader-config bootcfg
+                              #:run-installer? #f))))))
 
 \f
 ;;;
@@ -822,8 +709,22 @@ and TARGET arguments."
                                         (condition-message c))
                                 (exit 1)))
                        (#$installer #$bootloader #$device #$target)
-                       (format #t "bootloader successfully installed on '~a'~%"
-                               #$device))))))
+                       (info (G_ "bootloader successfully installed on '~a'~%")
+                             #$device))))))
+
+(define (local-eval exp)
+  "Evaluate EXP, a G-Expression, in-place."
+  (mlet* %store-monad ((lowered (lower-gexp exp))
+                       (_ (built-derivations (map gexp-input-thing
+                                                  (lowered-gexp-inputs lowered)))))
+    (save-load-path-excursion
+     (set! %load-path (lowered-gexp-load-path lowered))
+     (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
+     (return
+      (guard (c ((message-condition? c)
+                 (leave (G_ "failed to install bootloader:~%~a~%")
+                        (condition-message c))))
+        (primitive-eval (lowered-gexp-sexp lowered)))))))
 
 (define* (perform-action action os
                          #:key skip-safety-checks?
@@ -860,19 +761,12 @@ static checks."
         (map boot-parameters->menu-entry (profile-boot-parameters))))
 
   (define bootloader
-    (bootloader-configuration-bootloader (operating-system-bootloader os)))
+    (operating-system-bootloader os))
 
   (define bootcfg
     (and (memq action '(init reconfigure))
          (operating-system-bootcfg os menu-entries)))
 
-  (define bootloader-script
-    (let ((installer (bootloader-installer bootloader))
-          (target    (or target "/")))
-      (bootloader-installer-script installer
-                                   (bootloader-package bootloader)
-                                   bootloader-target target)))
-
   (when (eq? action 'reconfigure)
     (maybe-suggest-running-guix-pull))
 
@@ -899,9 +793,7 @@ static checks."
        ;; See <http://bugs.gnu.org/21068>.
        (drvs      (mapm %store-monad lower-object
                         (if (memq action '(init reconfigure))
-                            (if install-bootloader?
-                                (list sys bootcfg bootloader-script)
-                                (list sys bootcfg))
+                            (list sys bootcfg)
                             (list sys))))
        (%         (if derivations-only?
                       (return (for-each (compose println derivation-file-name)
@@ -911,28 +803,32 @@ static checks."
 
     (if (or dry-run? derivations-only?)
         (return #f)
-        (let ((bootcfg-file (bootloader-configuration-file bootloader)))
+        (begin
           (for-each (compose println derivation->output-path)
                     drvs)
 
           (case action
             ((reconfigure)
+             (newline)
+             (format #t (G_ "activating system...~%"))
              (mbegin %store-monad
-               (switch-to-system os)
+               (switch-to-system local-eval os)
                (mwhen install-bootloader?
-                 (install-bootloader bootloader-script
-                                     #:bootcfg bootcfg
-                                     #:bootcfg-file bootcfg-file
-                                     #:target "/"))))
+                 (install-bootloader local-eval bootloader bootcfg
+                                     #:target (or target "/"))
+                 (return
+                  (info (G_ "bootloader successfully installed on '~a'~%")
+                        (bootloader-configuration-target bootloader))))
+               (with-shepherd-error-handling
+                (upgrade-shepherd-services local-eval os))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
                      target)
              (install sys (canonicalize-path target)
                       #:install-bootloader? install-bootloader?
-                      #:bootcfg bootcfg
-                      #:bootcfg-file bootcfg-file
-                      #:bootloader-installer bootloader-script))
+                      #:bootloader bootloader
+                      #:bootcfg bootcfg))
             (else
              ;; All we had to do was to build SYS and maybe register an
              ;; indirect GC root.
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v5 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 11426 bytes --]

* gnu/tests/reconfigure.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk              |   1 +
 gnu/tests/reconfigure.scm | 262 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 263 insertions(+)
 create mode 100644 gnu/tests/reconfigure.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 0e17af953..b334d0572 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -592,6 +592,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/mail.scm				\
   %D%/tests/messaging.scm			\
   %D%/tests/networking.scm			\
+  %D%/tests/reconfigure.scm			\
   %D%/tests/rsync.scm				\
   %D%/tests/security-token.scm			\
   %D%/tests/singularity.scm			\
diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm
new file mode 100644
index 000000000..3a2f0a2e5
--- /dev/null
+++ b/gnu/tests/reconfigure.scm
@@ -0,0 +1,262 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 tests reconfigure)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system vm)
+  #:use-module (gnu system)
+  #:use-module (gnu tests)
+  #:use-module (guix derivations)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix scripts system reconfigure)
+  #:use-module (guix store)
+  #:export (%test-switch-to-system
+            %test-upgrade-services
+            %test-install-bootloader))
+
+;;; Commentary:
+;;;
+;;; Test in-place system reconfiguration: advancing the system generation on a
+;;; running instance of the Guix System.
+;;;
+;;; Code:
+
+(define* (run-switch-to-system-test)
+  "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new
+generation of the system profile."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          ;; Return the names of the generation symlinks on MARIONETTE.
+          (define (system-generations marionette)
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 ftw)
+                             (srfi srfi-1))
+                (let* ((profile-dir "/var/guix/profiles/")
+                       (entries (map first (cddr (file-system-tree profile-dir)))))
+                  (remove (lambda (entry)
+                            (member entry '("per-user" "system")))
+                          entries)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "switch-to-system")
+
+          (let ((generations-prior (system-generations marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$script)
+               marionette))
+
+            (test-equal "script created new generation"
+              (length (system-generations marionette))
+              (1+ (length generations-prior))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "switch-to-system" (test (switch-system-program os))))
+
+(define* (run-upgrade-services-test)
+  "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the
+Shepherd (PID 1) by unloading obsolete services and loading new services."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define dummy-service
+    ;; Shepherd service that does nothing, for the sole purpose of ensuring
+    ;; that it is properly installed and started by the script.
+    (shepherd-service (provision '(dummy))
+                      (start #~(const #t))
+                      (stop #~(const #t))
+                      (respawn? #f)))
+
+  ;; Return the Shepherd service file for SERVICE, after ensuring that it
+  ;; exists in the store.
+  (define (ensure-service-file service)
+    (let ((file (shepherd-service-file service)))
+      (mlet* %store-monad ((store-object (lower-object file))
+                           (_ (built-derivations (list store-object))))
+        (return file))))
+
+  (define (test enable-dummy disable-dummy)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          ;; Return the names of the running services on MARIONETTE.
+          (define (running-services marionette)
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (map live-service-canonical-name (current-services)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "upgrade-services")
+
+          (let ((services-prior (running-services marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$enable-dummy)
+               marionette))
+
+            (test-assert "script started new service"
+              (and (not (memq 'dummy services-prior))
+                   (memq 'dummy (running-services marionette))))
+
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$disable-dummy)
+               marionette))
+
+            (test-assert "script stopped obsolete service"
+              (not (memq 'dummy (running-services marionette)))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (mlet* %store-monad ((file (ensure-service-file dummy-service)))
+    (let ((enable (upgrade-services-program (list file) '(dummy) '() '()))
+          (disable (upgrade-services-program '() '() '(dummy) '())))
+      (gexp->derivation "upgrade-services" (test enable disable)))))
+
+(define* (run-install-bootloader-test)
+  "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
+bootloader's configuration file."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (ice-9 regex)
+                       (srfi srfi-1)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          ;; Return the system generation paths that have GRUB menu entries.
+          (define (generations-in-grub-cfg marionette)
+            (let ((grub-cfg (marionette-eval
+                             '(begin
+                                (call-with-input-file "/boot/grub/grub.cfg"
+                                  (lambda (port)
+                                    (get-string-all port))))
+                             marionette)))
+              (map (lambda (parameter)
+                     (second (string-split (match:substring parameter) #\=)))
+                   (list-matches "system=[^ ]*" grub-cfg))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "install-bootloader")
+
+          (test-assert "no prior menu entry for system generation"
+            (not (member #$os (generations-in-grub-cfg marionette))))
+
+          (test-assert "script successfully evaluated"
+            (marionette-eval
+             '(primitive-load #$script)
+             marionette))
+
+          (test-assert "menu entry created for system generation"
+            (member #$os (generations-in-grub-cfg marionette)))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (let* ((bootloader ((compose bootloader-configuration-bootloader
+                               operating-system-bootloader)
+                      os))
+         ;; The typical use-case for 'install-bootloader-program' is to read
+         ;; the boot parameters for the existing menu entries on the system,
+         ;; parse them with 'boot-parameters->menu-entry', and pass the
+         ;; results to 'operating-system-bootcfg'. However, to obtain boot
+         ;; parameters, we would need to start the marionette, which we should
+         ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we
+         ;; generate a bootloader configuration for the script as if there
+         ;; were no existing menu entries. In the grand scheme of things, this
+         ;; matters little -- these tests should not make assertions about the
+         ;; behavior of 'operating-system-bootcfg'.
+         (bootcfg (operating-system-bootcfg os '()))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (gexp->derivation
+     "install-bootloader"
+     ;; Due to the read-only nature of the virtual machines used in the system
+     ;; test suite, the bootloader installer script is omitted. 'grub-install'
+     ;; would attempt to write directly to the virtual disk if the
+     ;; installation script were run.
+     (test (install-bootloader-program #f #f bootcfg bootcfg-file #f "/")))))
+
+(define %test-switch-to-system
+  (system-test
+   (name "switch-to-system")
+   (description "Create a new generation of the system profile.")
+   (value (run-switch-to-system-test))))
+
+(define %test-upgrade-services
+  (system-test
+   (name "upgrade-services")
+   (description "Upgrade the Shepherd by unloading obsolete services and
+loading new services.")
+   (value (run-upgrade-services-test))))
+
+(define %test-install-bootloader
+  (system-test
+   (name "install-bootloader")
+   (description "Install a bootloader and its configuration file.")
+   (value (run-install-bootloader-test))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v5 2/3] guix system: Reimplement 'reconfigure'.

[Ludovic Courtès]

Hello,

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> +(define (local-eval exp)
> +  "Evaluate EXP, a G-Expression, in-place."
> +  (mlet* %store-monad ((lowered (lower-gexp exp))
> +                       (_ (built-derivations (map gexp-input-thing
> +                                                  (lowered-gexp-inputs lowered)))))

Note that on current master this should be:

  (built-derivations (lowered-gexp-inputs lowered))

> +    (save-load-path-excursion
> +     (set! %load-path (lowered-gexp-load-path lowered))
> +     (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
> +     (return
> +      (guard (c ((message-condition? c)
> +                 (leave (G_ "failed to install bootloader:~%~a~%")
> +                        (condition-message c))))
> +        (primitive-eval (lowered-gexp-sexp lowered)))))))

My last grief for this patch series is exception handling above: it’s
not good to report “failed to install bootloader” whatever the problem
is.  :-)

Could we somehow move exception handling at the call sites?  I know that
monadic style makes it harder.

The rest looks great, and congrats for being the first one to
reconfigure with it!  :-)

Thanks,
Ludo’.

[bug#36555] [PATCH v5 2/3] guix system: Reimplement 'reconfigure'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 996 bytes --]

Ludovic Courtès <ludo@gnu.org> writes:

> Note that on current master this should be:
>
>   (built-derivations (lowered-gexp-inputs lowered))
>

Ah, thank you. My feature branch is out of date again.

> My last grief for this patch series is exception handling above: it’s
> not good to report “failed to install bootloader” whatever the problem
> is. :-)
>
> Could we somehow move exception handling at the call sites? I know
> that monadic style makes it harder.

Whoops! It would definitely not be good to report "failed to install
bootloader" for unrelated issues. I'll look into moving the handling
into the call sites. Perhaps I can make a more general version of
'with-shepherd-error-handling'?

> The rest looks great, and congrats for being the first one to
> reconfigure with it! :-)

Heh, thanks! It was pretty exhilarating watching the output go by. I
didn't even do a system back-up beforehand because I was that confident
in it.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v5 2/3] guix system: Reimplement 'reconfigure'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 681 bytes --]

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) writes:

> Whoops! It would definitely not be good to report "failed to install
> bootloader" for unrelated issues. I'll look into moving the handling
> into the call sites. Perhaps I can make a more general version of
> 'with-shepherd-error-handling'?

I ran a few experiments with the Monad API and realized that this is
going to be far easier than I had originally thought. In fact, I've
already made what I believe to be the necessary changes to the code, I
just need to test it out. Expect the update to this patch to be done by
tomorrow morning -- I'm having trouble staying awake at my keyboard.

Goodnight, friends!
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v6 0/3] Refactor out common behavior for system reconfiguration.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 943 bytes --]

Updated to use the newer 'lowered-gexp' API, moved the 'guard' clause,
and confirmed that everything still works. I think that's everything for
this series.

Jakob L. Kreuze (3):
  guix system: Add 'reconfigure' module.
  guix system: Reimplement 'reconfigure'.
  tests: Add reconfigure system test.

 Makefile.am                         |   1 +
 gnu/local.mk                        |   1 +
 gnu/machine/ssh.scm                 | 189 ++------------------
 gnu/services/herd.scm               |   6 +
 gnu/tests/reconfigure.scm           | 262 ++++++++++++++++++++++++++++
 guix/scripts/system.scm             | 188 +++++---------------
 guix/scripts/system/reconfigure.scm | 237 +++++++++++++++++++++++++
 tests/services.scm                  |   4 -
 8 files changed, 560 insertions(+), 328 deletions(-)
 create mode 100644 gnu/tests/reconfigure.scm
 create mode 100644 guix/scripts/system/reconfigure.scm

-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v6 1/3] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 24689 bytes --]

* guix/scripts/system/reconfigure.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/system.scm (bootloader-installer-script): Export variable.
* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
* gnu/services/herd.scm (live-service): Export variable.
* gnu/services/herd.scm (live-service-canonical-name): New variable.
* tests/services.scm (live-service): Delete variable.
---
 Makefile.am                         |   1 +
 gnu/machine/ssh.scm                 | 189 ++--------------------
 gnu/services/herd.scm               |   6 +
 guix/scripts/system/reconfigure.scm | 237 ++++++++++++++++++++++++++++
 tests/services.scm                  |   4 -
 5 files changed, 256 insertions(+), 181 deletions(-)
 create mode 100644 guix/scripts/system/reconfigure.scm

diff --git a/Makefile.am b/Makefile.am
index 7fa51d17ac..0bd85e8fcf 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -249,6 +249,7 @@ MODULES =					\
   guix/scripts/describe.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
+  guix/scripts/system/reconfigure.scm		\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 278d43c10f..552eafa9de 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,23 +17,21 @@
 ;;; 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 services)
-  #:use-module (gnu services shepherd)
   #:use-module (gnu system)
-  #:use-module (guix derivations)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix modules)
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix remote)
+  #: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 +103,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 +161,20 @@ 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)))
+  (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
+    (let* ((os (machine-system machine))
+           (eval (cut machine-remote-eval machine <>))
+           (menu-entries (map boot-parameters->menu-entry boot-parameters))
+           (bootloader-configuration (operating-system-bootloader os))
+           (bootcfg (operating-system-bootcfg os menu-entries)))
+      (mbegin %store-monad
+        (switch-to-system eval os)
+        (upgrade-shepherd-services eval os)
+        (install-bootloader eval bootloader-configuration bootcfg)))))
 
 \f
 ;;;
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 0008746fe9..2207b2d34b 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -40,10 +40,12 @@
             unknown-shepherd-error?
             unknown-shepherd-error-sexp
 
+            live-service
             live-service?
             live-service-provision
             live-service-requirement
             live-service-running
+            live-service-canonical-name
 
             with-shepherd-action
             current-services
@@ -192,6 +194,10 @@ of pairs."
   (requirement  live-service-requirement)         ;list of symbols
   (running      live-service-running))            ;#f | object
 
+(define (live-service-canonical-name service)
+  "Return the 'canonical name' of SERVICE."
+  (first (live-service-provision service)))
+
 (define (current-services)
   "Return the list of currently defined Shepherd services, represented as
 <live-service> objects.  Return #f if the list of services could not be
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 0000000000..8c7d461585
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,237 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 (guix scripts system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services)
+  #:use-module (gnu services herd)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:export (switch-system-program
+            switch-to-system
+
+            upgrade-services-program
+            upgrade-shepherd-services
+
+            install-bootloader-program
+            install-bootloader))
+
+;;; Commentary:
+;;;
+;;; This module implements the "effectful" parts of system
+;;; reconfiguration. Although building a system derivation is a pure
+;;; operation, a number of impure operations must be carried out for the
+;;; system configuration to be realized -- chiefly, creation of generation
+;;; symlinks and invocation of activation scripts.
+;;;
+;;; Code:
+
+\f
+;;;
+;;; Profile creation.
+;;;
+
+(define* (switch-system-program os #:optional profile)
+  "Return an executable store item that, upon being evaluated, will create a
+new generation of PROFILE pointing to the directory of OS, switch to it
+atomically, and run OS's activation script."
+  (program-file
+   "switch-to-system.scm"
+   (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 profile
+             (or #$profile (string-append %state-directory "/profiles/system")))
+
+           (let* ((number (1+ (generation-number profile)))
+                  (generation (generation-file-name profile number)))
+             (switch-symlinks generation #$os)
+             (switch-symlinks profile generation)
+             (setenv "GUIX_NEW_SYSTEM" #$os)
+             (primitive-load #$(operating-system-activation-script os))))))))
+
+(define* (switch-to-system eval os #:optional profile)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+create a new generation of PROFILE pointing to the directory of OS, switch to
+it atomically, and run OS's activation script."
+  (eval #~(primitive-load #$(switch-system-program os profile))))
+
+\f
+;;;
+;;; Services.
+;;;
+
+(define (running-services eval)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+return the <live-service> objects that are currently running on MACHINE."
+  (define exp
+    (with-imported-modules '((gnu services herd))
+      #~(begin
+          (use-modules (gnu services herd))
+          (let ((services (current-services)))
+            (and services
+                 ;; 'live-service-running' is ignored, as we can't necessarily
+                 ;; serialize arbitrary objects. This should be fine for now,
+                 ;; since 'machine-current-services' is not exposed publicly,
+                 ;; and the resultant <live-service> objects are only used for
+                 ;; resolving service dependencies.
+                 (map (lambda (service)
+                        (list (live-service-provision service)
+                              (live-service-requirement service)))
+                      services))))))
+  (mlet %store-monad ((services (eval exp)))
+    (return (map (match-lambda
+                   ((provision requirement)
+                    (live-service provision requirement #f)))
+                 services))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program service-files to-start to-unload to-restart)
+  "Return an executable store item that, upon being evaluated, will upgrade
+the Shepherd (PID 1) by unloading obsolete services and loading new
+services. SERVICE-FILES is a list of Shepherd service files to load, and
+TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services'
+canonical names (symbols)."
+  (program-file
+   "upgrade-shepherd-services.scm"
+   (with-imported-modules '((gnu services herd))
+    #~(begin
+        (use-modules (gnu services herd)
+                     (srfi srfi-1))
+
+        ;; Load the service files for any new services.
+        (load-services/safe '#$service-files)
+
+        ;; Unload obsolete services and start new services.
+        (for-each unload-service '#$to-unload)
+        (for-each start-service '#$to-start)))))
+
+(define* (upgrade-shepherd-services eval os)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
+services as defined by OS."
+  (define target-services
+    (service-value
+     (fold-services (operating-system-services os)
+                    #:target-type shepherd-root-service-type)))
+
+  (mlet* %store-monad ((live-services (running-services eval)))
+    (let*-values (((to-unload to-restart)
+                   (shepherd-service-upgrade live-services target-services)))
+      (let* ((to-unload (map live-service-canonical-name to-unload))
+             (to-restart (map shepherd-service-canonical-name to-restart))
+             (to-start (lset-difference eqv?
+                                        (map shepherd-service-canonical-name
+                                             target-services)
+                                        (map live-service-canonical-name
+                                             live-services)))
+             (service-files
+              (map shepherd-service-file
+                   (filter (lambda (service)
+                             (memq (shepherd-service-canonical-name service)
+                                   to-start))
+                           target-services))))
+        (eval #~(primitive-load #$(upgrade-services-program service-files
+                                                            to-start
+                                                            to-unload
+                                                            to-restart)))))))
+
+\f
+;;;
+;;; Bootloader configuration.
+;;;
+
+(define (install-bootloader-program installer bootloader-package bootcfg
+                                    bootcfg-file device target)
+  "Return an executable store item that, upon being evaluated, will install
+BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device,
+at TARGET, a mount point, and subsequently run INSTALLER from
+BOOTLOADER-PACKAGE."
+  (program-file
+   "install-bootloader.scm"
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules (source-module-closure '((gnu build bootloader)
+                                                     (gnu build install)
+                                                     (guix store)
+                                                     (guix utils)))
+       #~(begin
+           (use-modules (gnu build bootloader)
+                        (gnu build install)
+                        (guix build utils)
+                        (guix store)
+                        (guix utils)
+                        (ice-9 binary-ports)
+                        (srfi srfi-34)
+                        (srfi srfi-35))
+           (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
+                  (temp-gc-root (string-append gc-root ".new")))
+             (switch-symlinks temp-gc-root gc-root)
+             (install-boot-config #$bootcfg #$bootcfg-file #$target)
+             ;; Preserve the previous activation's garbage collector root
+             ;; until the bootloader installer has run, so that a failure in
+             ;; the bootloader's installer script doesn't leave the user with
+             ;; a broken installation.
+             (when #$installer
+               (catch #t
+                 (lambda ()
+                   (#$installer #$bootloader-package #$device #$target))
+                 (lambda args
+                   (delete-file temp-gc-root)
+                   (apply throw args))))
+             (rename-file temp-gc-root gc-root)))))))
+
+(define* (install-bootloader eval configuration bootcfg
+                             #:key
+                             (run-installer? #t)
+                             (target "/"))
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+configure the bootloader on TARGET such that OS will be booted by default and
+additional configurations specified by MENU-ENTRIES can be selected."
+  (let* ((bootloader (bootloader-configuration-bootloader configuration))
+         (installer (and run-installer?
+                         (bootloader-installer bootloader)))
+         (package (bootloader-package bootloader))
+         (device (bootloader-configuration-target configuration))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (eval #~(primitive-load #$(install-bootloader-program installer
+                                                          package
+                                                          bootcfg
+                                                          bootcfg-file
+                                                          device
+                                                          target)))))
diff --git a/tests/services.scm b/tests/services.scm
index 44ad0022c6..572fe38164 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -26,10 +26,6 @@
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
-(define live-service
-  (@@ (gnu services herd) live-service))
-
-\f
 (test-begin "services")
 
 (test-equal "services, default value"
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v6 2/3] guix system: Reimplement 'reconfigure'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 13476 bytes --]

* guix/scripts/system.scm (switch-to-system)
(upgrade-shepherd-services, install-bootloader): Delete variable.
(local-eval): New variable.
(install): Remove 'bootloader-installer' and 'bootcfg-file' parameters.
(install): Add 'bootloader' parameter.
---
 guix/scripts/system.scm | 188 +++++++++-------------------------------
 1 file changed, 41 insertions(+), 147 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 67a4071684..115da665b4 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,7 @@
                                        delete-matching-generations)
   #:use-module (guix graph)
   #:use-module (guix scripts graph)
+  #:use-module (guix scripts system reconfigure)
   #:use-module (guix build utils)
   #:use-module (guix progress)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -178,43 +179,9 @@ TARGET, and register them."
 
     (return *unspecified*)))
 
-(define* (install-bootloader installer
-                             #:key
-                             bootcfg bootcfg-file
-                             target)
-  "Run INSTALLER, a bootloader installation script, with error handling, in
-%STORE-MONAD."
-  (mlet %store-monad ((installer-drv (if installer
-                                         (lower-object installer)
-                                         (return #f)))
-                      (bootcfg       (lower-object bootcfg)))
-    (let* ((gc-root      (string-append target %gc-roots-directory
-                                        "/bootcfg"))
-           (temp-gc-root (string-append gc-root ".new"))
-           (install (and installer-drv
-                         (derivation->output-path installer-drv)))
-           (bootcfg (derivation->output-path bootcfg)))
-      ;; Prepare the symlink to bootloader config file to make sure that it's
-      ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
-      (switch-symlinks temp-gc-root bootcfg)
-
-      (unless (false-if-exception
-               (begin
-                 (install-boot-config bootcfg bootcfg-file target)
-                 (when install
-                   (save-load-path-excursion (primitive-load install)))))
-        (delete-file temp-gc-root)
-        (leave (G_ "failed to install bootloader ~a~%") install))
-
-      ;; Register bootloader config file as a GC root so that its dependencies
-      ;; (background image, font, etc.) are not reclaimed.
-      (rename-file temp-gc-root gc-root)
-      (return #t))))
-
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
-                  bootloader-installer install-bootloader?
-                  bootcfg bootcfg-file)
+                  install-bootloader? bootloader bootcfg)
   "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
 directory TARGET.  TARGET must be an absolute directory name since that's what
 'register-path' expects.
@@ -265,10 +232,11 @@ the ownership of '~a' may be incorrect!~%")
         (populate os-dir target)
 
         (mwhen install-bootloader?
-          (install-bootloader bootloader-installer
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader local-eval bootloader bootcfg
+                              #:target target)
+          (return
+           (info (G_ "bootloader successfully installed on '~a'~%")
+                 (bootloader-configuration-target bootloader))))))))
 
 \f
 ;;;
@@ -335,82 +303,6 @@ unload."
        (warning (G_ "failed to obtain list of shepherd services~%"))
        (return #f)))))
 
-(define (upgrade-shepherd-services os)
-  "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
-services specified in OS and not currently running.
-
-This is currently very conservative in that it does not stop or unload any
-running service.  Unloading or stopping the wrong service ('udev', say) could
-bring the system down."
-  (define new-services
-    (service-value
-     (fold-services (operating-system-services os)
-                    #:target-type shepherd-root-service-type)))
-
-  ;; Arrange to simply emit a warning if the service upgrade fails.
-  (with-shepherd-error-handling
-   (call-with-service-upgrade-info new-services
-     (lambda (to-restart to-unload)
-        (for-each (lambda (unload)
-                    (info (G_ "unloading service '~a'...~%") unload)
-                    (unload-service unload))
-                  to-unload)
-
-        (with-monad %store-monad
-          (munless (null? new-services)
-            (let ((new-service-names  (map shepherd-service-canonical-name new-services))
-                  (to-restart-names   (map shepherd-service-canonical-name to-restart))
-                  (to-start           (filter shepherd-service-auto-start? new-services)))
-              (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
-              (unless (null? to-restart-names)
-                ;; Listing TO-RESTART-NAMES in the message below wouldn't help
-                ;; because many essential services cannot be meaningfully
-                ;; restarted.  See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
-                (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n")))
-              (mlet %store-monad ((files (mapm %store-monad
-                                               (compose lower-object
-                                                        shepherd-service-file)
-                                               new-services)))
-                ;; Here we assume that FILES are exactly those that were computed
-                ;; as part of the derivation that built OS, which is normally the
-                ;; case.
-                (load-services/safe (map derivation->output-path files))
-
-                (for-each start-service
-                          (map shepherd-service-canonical-name to-start))
-                (return #t)))))))))
-
-(define* (switch-to-system os
-                           #:optional (profile %system-profile))
-  "Make a new generation of PROFILE pointing to the directory of OS, switch to
-it atomically, and then run OS's activation script."
-  (mlet* %store-monad ((drv (operating-system-derivation os))
-                       (script (lower-object (operating-system-activation-script os))))
-    (let* ((system     (derivation->output-path drv))
-           (number     (+ 1 (generation-number profile)))
-           (generation (generation-file-name profile number)))
-      (switch-symlinks generation system)
-      (switch-symlinks profile generation)
-
-      (format #t (G_ "activating system...~%"))
-
-      ;; The activation script may change $PATH, among others, so protect
-      ;; against that.
-      (save-environment-excursion
-       ;; Tell 'activate-current-system' what the new system is.
-       (setenv "GUIX_NEW_SYSTEM" system)
-
-       ;; The activation script may modify '%load-path' & co., so protect
-       ;; against that.  This is necessary to ensure that
-       ;; 'upgrade-shepherd-services' gets to see the right modules when it
-       ;; computes derivations with 'gexp->derivation'.
-       (save-load-path-excursion
-        (primitive-load (derivation->output-path script))))
-
-      ;; Finally, try to update system services.
-      (upgrade-shepherd-services os))))
-
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
     (lambda ()
@@ -505,18 +397,13 @@ STORE is an open connection to the store."
                      ((bootloader-configuration-file-generator bootloader)
                       bootloader-config entries
                       #:old-entries old-entries)))
-           (bootcfg-file -> (bootloader-configuration-file bootloader))
-           (target -> "/")
            (drvs -> (list bootcfg)))
         (mbegin %store-monad
           (show-what-to-build* drvs)
           (built-derivations drvs)
-          ;; Only install bootloader configuration file. Thus, no installer is
-          ;; provided here.
-          (install-bootloader #f
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          ;; Only install bootloader configuration file.
+          (install-bootloader local-eval bootloader-config bootcfg
+                              #:run-installer? #f))))))
 
 \f
 ;;;
@@ -820,8 +707,17 @@ and TARGET arguments."
                                         (condition-message c))
                                 (exit 1)))
                        (#$installer #$bootloader #$device #$target)
-                       (format #t "bootloader successfully installed on '~a'~%"
-                               #$device))))))
+                       (info (G_ "bootloader successfully installed on '~a'~%")
+                             #$device))))))
+
+(define (local-eval exp)
+  "Evaluate EXP, a G-Expression, in-place."
+  (mlet* %store-monad ((lowered (lower-gexp exp))
+                       (_ (built-derivations (lowered-gexp-inputs lowered))))
+    (save-load-path-excursion
+     (set! %load-path (lowered-gexp-load-path lowered))
+     (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
+     (return (primitive-eval (lowered-gexp-sexp lowered))))))
 
 (define* (perform-action action os
                          #:key skip-safety-checks?
@@ -858,19 +754,12 @@ static checks."
         (map boot-parameters->menu-entry (profile-boot-parameters))))
 
   (define bootloader
-    (bootloader-configuration-bootloader (operating-system-bootloader os)))
+    (operating-system-bootloader os))
 
   (define bootcfg
     (and (memq action '(init reconfigure))
          (operating-system-bootcfg os menu-entries)))
 
-  (define bootloader-script
-    (let ((installer (bootloader-installer bootloader))
-          (target    (or target "/")))
-      (bootloader-installer-script installer
-                                   (bootloader-package bootloader)
-                                   bootloader-target target)))
-
   (when (eq? action 'reconfigure)
     (maybe-suggest-running-guix-pull))
 
@@ -897,9 +786,7 @@ static checks."
        ;; See <http://bugs.gnu.org/21068>.
        (drvs      (mapm %store-monad lower-object
                         (if (memq action '(init reconfigure))
-                            (if install-bootloader?
-                                (list sys bootcfg bootloader-script)
-                                (list sys bootcfg))
+                            (list sys bootcfg)
                             (list sys))))
        (%         (if derivations-only?
                       (return (for-each (compose println derivation-file-name)
@@ -909,28 +796,35 @@ static checks."
 
     (if (or dry-run? derivations-only?)
         (return #f)
-        (let ((bootcfg-file (bootloader-configuration-file bootloader)))
+        (begin
           (for-each (compose println derivation->output-path)
                     drvs)
 
           (case action
             ((reconfigure)
-             (mbegin %store-monad
-               (switch-to-system os)
-               (mwhen install-bootloader?
-                 (install-bootloader bootloader-script
-                                     #:bootcfg bootcfg
-                                     #:bootcfg-file bootcfg-file
-                                     #:target "/"))))
+             (newline)
+             (format #t (G_ "activating system...~%"))
+             (guard (c ((message-condition? c)
+                        (leave (G_ "failed to reconfigure system:~%~a~%")
+                               (condition-message c))))
+               (mbegin %store-monad
+                 (switch-to-system local-eval os)
+                 (mwhen install-bootloader?
+                   (install-bootloader local-eval bootloader bootcfg
+                                       #:target (or target "/"))
+                   (return
+                    (info (G_ "bootloader successfully installed on '~a'~%")
+                          (bootloader-configuration-target bootloader))))
+                 (with-shepherd-error-handling
+                  (upgrade-shepherd-services local-eval os)))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
                      target)
              (install sys (canonicalize-path target)
                       #:install-bootloader? install-bootloader?
-                      #:bootcfg bootcfg
-                      #:bootcfg-file bootcfg-file
-                      #:bootloader-installer bootloader-script))
+                      #:bootloader bootloader
+                      #:bootcfg bootcfg))
             (else
              ;; All we had to do was to build SYS and maybe register an
              ;; indirect GC root.
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v6 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 11430 bytes --]

* gnu/tests/reconfigure.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk              |   1 +
 gnu/tests/reconfigure.scm | 262 ++++++++++++++++++++++++++++++++++++++
 2 files changed, 263 insertions(+)
 create mode 100644 gnu/tests/reconfigure.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index eb3b0dcd3b..67faf72726 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -597,6 +597,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/mail.scm				\
   %D%/tests/messaging.scm			\
   %D%/tests/networking.scm			\
+  %D%/tests/reconfigure.scm			\
   %D%/tests/rsync.scm				\
   %D%/tests/security-token.scm			\
   %D%/tests/singularity.scm			\
diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm
new file mode 100644
index 0000000000..3a2f0a2e53
--- /dev/null
+++ b/gnu/tests/reconfigure.scm
@@ -0,0 +1,262 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 tests reconfigure)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system vm)
+  #:use-module (gnu system)
+  #:use-module (gnu tests)
+  #:use-module (guix derivations)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix scripts system reconfigure)
+  #:use-module (guix store)
+  #:export (%test-switch-to-system
+            %test-upgrade-services
+            %test-install-bootloader))
+
+;;; Commentary:
+;;;
+;;; Test in-place system reconfiguration: advancing the system generation on a
+;;; running instance of the Guix System.
+;;;
+;;; Code:
+
+(define* (run-switch-to-system-test)
+  "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new
+generation of the system profile."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          ;; Return the names of the generation symlinks on MARIONETTE.
+          (define (system-generations marionette)
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 ftw)
+                             (srfi srfi-1))
+                (let* ((profile-dir "/var/guix/profiles/")
+                       (entries (map first (cddr (file-system-tree profile-dir)))))
+                  (remove (lambda (entry)
+                            (member entry '("per-user" "system")))
+                          entries)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "switch-to-system")
+
+          (let ((generations-prior (system-generations marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$script)
+               marionette))
+
+            (test-equal "script created new generation"
+              (length (system-generations marionette))
+              (1+ (length generations-prior))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "switch-to-system" (test (switch-system-program os))))
+
+(define* (run-upgrade-services-test)
+  "Run a test of an OS running UPGRADE-SERVICES-PROGRAM, which upgrades the
+Shepherd (PID 1) by unloading obsolete services and loading new services."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define dummy-service
+    ;; Shepherd service that does nothing, for the sole purpose of ensuring
+    ;; that it is properly installed and started by the script.
+    (shepherd-service (provision '(dummy))
+                      (start #~(const #t))
+                      (stop #~(const #t))
+                      (respawn? #f)))
+
+  ;; Return the Shepherd service file for SERVICE, after ensuring that it
+  ;; exists in the store.
+  (define (ensure-service-file service)
+    (let ((file (shepherd-service-file service)))
+      (mlet* %store-monad ((store-object (lower-object file))
+                           (_ (built-derivations (list store-object))))
+        (return file))))
+
+  (define (test enable-dummy disable-dummy)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          ;; Return the names of the running services on MARIONETTE.
+          (define (running-services marionette)
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (map live-service-canonical-name (current-services)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "upgrade-services")
+
+          (let ((services-prior (running-services marionette)))
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$enable-dummy)
+               marionette))
+
+            (test-assert "script started new service"
+              (and (not (memq 'dummy services-prior))
+                   (memq 'dummy (running-services marionette))))
+
+            (test-assert "script successfully evaluated"
+              (marionette-eval
+               '(primitive-load #$disable-dummy)
+               marionette))
+
+            (test-assert "script stopped obsolete service"
+              (not (memq 'dummy (running-services marionette)))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (mlet* %store-monad ((file (ensure-service-file dummy-service)))
+    (let ((enable (upgrade-services-program (list file) '(dummy) '() '()))
+          (disable (upgrade-services-program '() '() '(dummy) '())))
+      (gexp->derivation "upgrade-services" (test enable disable)))))
+
+(define* (run-install-bootloader-test)
+  "Run a test of an OS running INSTALL-BOOTLOADER-PROGRAM, which installs a
+bootloader's configuration file."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (ice-9 regex)
+                       (srfi srfi-1)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          ;; Return the system generation paths that have GRUB menu entries.
+          (define (generations-in-grub-cfg marionette)
+            (let ((grub-cfg (marionette-eval
+                             '(begin
+                                (call-with-input-file "/boot/grub/grub.cfg"
+                                  (lambda (port)
+                                    (get-string-all port))))
+                             marionette)))
+              (map (lambda (parameter)
+                     (second (string-split (match:substring parameter) #\=)))
+                   (list-matches "system=[^ ]*" grub-cfg))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "install-bootloader")
+
+          (test-assert "no prior menu entry for system generation"
+            (not (member #$os (generations-in-grub-cfg marionette))))
+
+          (test-assert "script successfully evaluated"
+            (marionette-eval
+             '(primitive-load #$script)
+             marionette))
+
+          (test-assert "menu entry created for system generation"
+            (member #$os (generations-in-grub-cfg marionette)))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (let* ((bootloader ((compose bootloader-configuration-bootloader
+                               operating-system-bootloader)
+                      os))
+         ;; The typical use-case for 'install-bootloader-program' is to read
+         ;; the boot parameters for the existing menu entries on the system,
+         ;; parse them with 'boot-parameters->menu-entry', and pass the
+         ;; results to 'operating-system-bootcfg'. However, to obtain boot
+         ;; parameters, we would need to start the marionette, which we should
+         ;; ideally avoid doing outside of the 'test' G-Expression. Thus, we
+         ;; generate a bootloader configuration for the script as if there
+         ;; were no existing menu entries. In the grand scheme of things, this
+         ;; matters little -- these tests should not make assertions about the
+         ;; behavior of 'operating-system-bootcfg'.
+         (bootcfg (operating-system-bootcfg os '()))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (gexp->derivation
+     "install-bootloader"
+     ;; Due to the read-only nature of the virtual machines used in the system
+     ;; test suite, the bootloader installer script is omitted. 'grub-install'
+     ;; would attempt to write directly to the virtual disk if the
+     ;; installation script were run.
+     (test (install-bootloader-program #f #f bootcfg bootcfg-file #f "/")))))
+
+(define %test-switch-to-system
+  (system-test
+   (name "switch-to-system")
+   (description "Create a new generation of the system profile.")
+   (value (run-switch-to-system-test))))
+
+(define %test-upgrade-services
+  (system-test
+   (name "upgrade-services")
+   (description "Upgrade the Shepherd by unloading obsolete services and
+loading new services.")
+   (value (run-upgrade-services-test))))
+
+(define %test-install-bootloader
+  (system-test
+   (name "install-bootloader")
+   (description "Install a bootloader and its configuration file.")
+   (value (run-install-bootloader-test))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

bug#36555: [PATCH v6 3/3] tests: Add reconfigure system test.

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 1084 bytes --]

Hi there!

I’ve applied the whole series with the change below.  \o/

Because of the monadic style, the ‘guard’ clause had no effect:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> ,run-in-store (guard (c (#t 'caught)) (mbegin %store-monad (return 1)(return (raise (condition (&message (message "oh!")))))))
While executing meta-command:
Throw to key `srfi-34' with args `(#<condition &message [message: "oh!"] 1cab2c0>)'.
--8<---------------cut here---------------end--------------->8---

I thought about adding it in some other way, but it turns out not to be
needed at all because error conditions are guarded against in
‘guix-system’.  Hence the patch.

Thank you for the hard work on this series!

I’ll be away from keyboard roughly until August 17th.  Hopefully you can
get feedback from David or Chris, and maybe you can get others on board
as well.  :-)  If my opinion on changes to the core is needed, you can
always push to a separate branch in the meantime.  Anyway, I’m confident!

Ludo’.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 1715 bytes --]

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 115da665b4..9fc3a10e98 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -804,19 +804,16 @@ static checks."
             ((reconfigure)
              (newline)
              (format #t (G_ "activating system...~%"))
-             (guard (c ((message-condition? c)
-                        (leave (G_ "failed to reconfigure system:~%~a~%")
-                               (condition-message c))))
-               (mbegin %store-monad
-                 (switch-to-system local-eval os)
-                 (mwhen install-bootloader?
-                   (install-bootloader local-eval bootloader bootcfg
-                                       #:target (or target "/"))
-                   (return
-                    (info (G_ "bootloader successfully installed on '~a'~%")
-                          (bootloader-configuration-target bootloader))))
-                 (with-shepherd-error-handling
-                  (upgrade-shepherd-services local-eval os)))))
+             (mbegin %store-monad
+               (switch-to-system local-eval os)
+               (mwhen install-bootloader?
+                 (install-bootloader local-eval bootloader bootcfg
+                                     #:target (or target "/"))
+                 (return
+                  (info (G_ "bootloader successfully installed on '~a'~%")
+                        (bootloader-configuration-target bootloader))))
+               (with-shepherd-error-handling
+                  (upgrade-shepherd-services local-eval os))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")

[bug#36555] [PATCH v6 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1.1: Type: text/plain, Size: 631 bytes --]

Hi Ludo,

Ludovic Courtès <ludo@gnu.org> writes:

> Hi there!
>
> I’ve applied the whole series with the change below.  \o/

Awesome, thank you!

> Because of the monadic style, the ‘guard’ clause had no effect:
>
> scheme@(guile-user)> ,run-in-store (guard (c (#t 'caught)) (mbegin %store-monad (return 1)(return (raise (condition (&message (message "oh!")))))))
> While executing meta-command:
> Throw to key `srfi-34' with args `(#<condition &message [message: "oh!"] 1cab2c0>)'.

My thoughts were similar when I was working on earlier versions of this
series, so I had devised the following snippet:


[-- Attachment #1.2: example.scm --]
[-- Type: text/plain, Size: 613 bytes --]

(use-modules (guix monads)
             (guix store)
             (srfi srfi-34)
             (srfi srfi-35))

(define (monadic-procedure)
  (catch #t
    (lambda ()
      (guard (c ((message-condition? c)
                 (format (current-error-port) "error: ~a~%"
                         (condition-message c))
                 (throw c)))
        (mbegin %store-monad
          (return (raise (condition (&message (message "Bogus error"))))))))
    (lambda _
      (mbegin %store-monad
        (return (format #t "Error was caught~%"))))))

(with-store store
  (run-with-store store
    (monadic-procedure)))

[-- Attachment #1.3: Type: text/plain, Size: 1050 bytes --]


Which, when run, outputs the following:

jakob@Epsilon ~ $ guile example.scm
error: Bogus error
Error was caught

I have a fairly weak understanding of monads, how they're implemented in
Guix, and how exception handling works in Guile, so I'm not entirely
sure why one example works and the other doesn't. Either way,

> I thought about adding it in some other way, but it turns out not to
> be needed at all because error conditions are guarded against in
> ‘guix-system’. Hence the patch.

I suppose that, in that case, we don't really need to worry about it.

> Thank you for the hard work on this series!

And thank you for all of the code review you've done :)

> I’ll be away from keyboard roughly until August 17th. Hopefully you
> can get feedback from David or Chris, and maybe you can get others on
> board as well. :-) If my opinion on changes to the core is needed, you
> can always push to a separate branch in the meantime. Anyway, I’m
> confident!

Sounds good. Take care, Ludo!

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v5 2/3] guix system: Reimplement 'reconfigure'.

[Ludovic Courtès]

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) writes:
>
>> Whoops! It would definitely not be good to report "failed to install
>> bootloader" for unrelated issues. I'll look into moving the handling
>> into the call sites. Perhaps I can make a more general version of
>> 'with-shepherd-error-handling'?
>
> I ran a few experiments with the Monad API and realized that this is
> going to be far easier than I had originally thought. In fact, I've
> already made what I believe to be the necessary changes to the code, I
> just need to test it out. Expect the update to this patch to be done by
> tomorrow morning -- I'm having trouble staying awake at my keyboard.

Awesome.  Something along the lines of ‘with-shepherd-error-handling’
sounds great.

Thanks!

Ludo’.

[bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test.

[Ludovic Courtès]

Hello,

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> Ludovic Courtès <ludo@gnu.org> writes:

[...]

>> I like to avoid exposing constructors so that one cannot “forge”
>> invalid objects, but let’s see…
>
> Should I use @@ for this, perhaps?

No, it’s not any better ;-), but anyway, let’s address this later.

>> (Once we’ve done that (guix graph) demonadification we discussed
>> before, perhaps we can perform run ‘shepherd-service-upgrade’ entirely
>> on the “other side”, and at that point we won’t need to expose the
>> ‘live-service’ constructor.)
>
> The main issue with calling 'shepherd-service-upgrade' on the other side
> is that we'd need to send over the service objects (the current
> 'upgrade-services-program' deals with provision symbols rather than the
> service objects themselves).
>
> I'm certain it's possible, it's just easier said than done. I've got
> time to think it through, though :)

Oh, you may be right.  :-)

>> What happens when ‘install-bootloader’ fails though? We should make
>> sure that the error is diagnosed, and that the output of
>> ‘grub-install’ or similar is shown when that happens.

I think you didn’t answer this specific question; thoughts?

>> Note that there are now a few places where we call ‘built-derivations’
>> without calling ‘show-what-to-build*’ first. That means the UX might
>> be pretty bad since one has no idea what’s being built.
>>
>> Furthermore, that means substitutes may not be up-to-date, leading to
>> many “updating substitutes” messages and HTTP round trips (as happened
>> with <https://issues.guix.gnu.org/issue/36509>).
>>
>> Last, doing several ‘build-derivations’ call with just a couple of
>> derivations is less efficient than doing a single call with many
>> derivations; that also has an impact on the UI, if we were to call
>> ‘show-what-to-build*’ once for ‘build-derivations’ call.
>>
>> What’s your experience with this in practice?
>
> I haven't had too many issues with it since the G-Expressions tended to
> have few inputs, but those are some valid concerns. Would it be better
> to create derivations for locally-evaluated G-Expressions? For example,
> with 'program-file' or 'gexp->script'? I thought that evaluating them
> in-place might be better since that's one fewer store item that needs to
> be built, but if we were to turn the G-Expression into a derivation, we
> could add it to the call to 'show-what-to-build*' in 'guix system
> reconfigure'.

The number of ‘build-derivations’ calls is the same whether it’s local
or distant.

What would make a difference is having a single script instead of
three—i.e., one program that does:

  #~(begin
      (activate-system …)
      (upgrade-services …)
      (switch-system …))

I think this program could even be added to the ‘system’
derivation—i.e., as a file next to those in /run/current-system.

That way, switching to a system generation would be a matter of running
it’s ‘switch’ program.

Perhaps this should be our horizon.  WDYT?

Thanks for your feedback!

Ludo’.

[bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 1117 bytes --]

Ludovic Courtès <ludo@gnu.org> writes:

> I think you didn’t answer this specific question; thoughts?

I had a peek at your more recent email, and think you dug up (and
commented on) my handling of it, but I'll link [1] just in case.

> The number of ‘build-derivations’ calls is the same whether it’s local
> or distant.
>
> What would make a difference is having a single script instead of
> three—i.e., one program that does:
>
>   #~(begin
>       (activate-system …)
>       (upgrade-services …)
>       (switch-system …))
>
> I think this program could even be added to the ‘system’
> derivation—i.e., as a file next to those in /run/current-system.
>
> That way, switching to a system generation would be a matter of running
> it’s ‘switch’ program.
>
> Perhaps this should be our horizon.  WDYT?

I'm a fan of that idea. Having it as a file means we would be able to
run activation services on a roll-back. I've added this to my to-do list
of patches :)

Regards,
Jakob

[1]: https://lists.gnu.org/archive/html/guix-patches/2019-07/msg00656.html

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test.

[Ludovic Courtès]

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> I think you didn’t answer this specific question; thoughts?
>
> I had a peek at your more recent email, and think you dug up (and
> commented on) my handling of it, but I'll link [1] just in case.

Yup, sorry for the confusion!

Ludo’.

[bug#36555] [PATCH v4 2/3] guix system: Reimplement 'reconfigure'.

[Ludovic Courtès]

Hello,

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> * guix/scripts/system.scm (switch-to-system)
> (upgrade-shepherd-services, install-bootloader): Delete variable.
> * guix/scripts/system.scm (local-eval): New variable.
    ^
No need to repeat the file name here.

However there are other changes no mentioned here, for example changes
to the ‘install’ procedure.  Could you add them to the log?

> +          (install-bootloader local-eval bootloader bootcfg
> +                              #:target target)
> +          (return
> +           (format #t "bootloader successfully installed on '~a'~%"
> +                   (bootloader-configuration-target bootloader))))))))

While you’re at it, could you change it to:

  (info (G_ "bootloader successfully installed on '~a'~%") …)

?

What happens when ‘install-bootloader’ fails though?  We should make
sure that the error is diagnosed, and that the output of ‘grub-install’
or similar is shown when that happens.

> +(define (local-eval exp)
> +  "Evaluate EXP, a G-Expression, in-place."

Eventually we should add it to (guix gexp).

> +  (mlet* %store-monad ((lowered (lower-gexp exp))
> +                       (_ (built-derivations (map gexp-input-thing
> +                                                  (lowered-gexp-inputs lowered)))))

Note that there are now a few places where we call ‘built-derivations’
without calling ‘show-what-to-build*’ first.  That means the UX might be
pretty bad since one has no idea what’s being built.

Furthermore, that means substitutes may not be up-to-date, leading to
many “updating substitutes” messages and HTTP round trips (as happened
with <https://issues.guix.gnu.org/issue/36509>).

Last, doing several ‘build-derivations’ call with just a couple of
derivations is less efficient than doing a single call with many
derivations; that also has an impact on the UI, if we were to call
‘show-what-to-build*’ once for ‘build-derivations’ call.

What’s your experience with this in practice?

There are several things we can do to improve on that.  One is to have
‘built-derivations’ automatically call ‘show-what-to-build*’.  However,
(guix derivations) must not depend on (guix ui) so we could add a
parameter to ‘run-with-store’ that would specify what to do upon
‘build-derivations’.

Last but not least, make sure to test this on your machine.  :-)

It’s sensitive code that we’d rather not break.

Thanks!

Ludo’.

[bug#36555] [PATCH v4 1/3] guix system: Add 'reconfigure' module.

[Ludovic Courtès]

Hello Jakob!

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> * guix/scripts/system/reconfigure.scm: New file.
> * Makefile.am (MODULES): Add it.
> * guix/scripts/system.scm (bootloader-installer-script): Export variable.
> * gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
> (install-bootloader): Delete variable.
> * gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
> * gnu/services/herd.scm (live-service): Export variable.
> * gnu/services/herd.scm (live-service-canonical-name): New variable.
> * tests/services.scm (live-service): Delete variable.

It LGTM!  I have some comments inline below, but nothing that should
block this patch.

>  (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)))
> +  (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
> +    (let* ((os (machine-system machine))
> +           (eval (cut machine-remote-eval machine <>))
> +           (menu-entries (map boot-parameters->menu-entry boot-parameters))
> +           (bootloader-configuration (operating-system-bootloader os))
> +           (bootcfg (operating-system-bootcfg os menu-entries)))
> +      (mbegin %store-monad
> +        (switch-to-system eval os)
> +        (upgrade-shepherd-services eval os)
> +        (install-bootloader eval bootloader-configuration bootcfg)))))

Really nice that it becomes this concise.

>  \f
>  ;;;
> diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
> index 0008746fe..2207b2d34 100644
> --- a/gnu/services/herd.scm
> +++ b/gnu/services/herd.scm
> @@ -40,10 +40,12 @@
>              unknown-shepherd-error?
>              unknown-shepherd-error-sexp
>  
> +            live-service

I like to avoid exposing constructors so that one cannot “forge” invalid
objects, but let’s see…

> +(define* (switch-to-system eval os #:optional profile)
> +  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
> +create a new generation of PROFILE pointing to the directory of OS, switch to
> +it atomically, and run OS's activation script."
> +  (eval #~(primitive-load #$(switch-system-program os profile))))

I wonder it we should just use

  #~(begin (use-modules (guix build utils)) (invoke …))

here and in other places.

That’s probably better longer-term (for example when we switch to
Guile 3, that could ease the transition since the right Guile would be
used) but we can keep it this way and revisit it later.

> +(define (running-services eval)
> +  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
> +return the <live-service> objects that are currently running on MACHINE."
> +  (define remote-exp

s/remote-exp/exp/

> +    (with-imported-modules '((gnu services herd))
> +      #~(begin
> +          (use-modules (gnu services herd))
> +          (let ((services (current-services)))
> +            (and services
> +                 ;; 'live-service-running' is ignored, as we can't necessarily
> +                 ;; serialize arbitrary objects. This should be fine for now,
> +                 ;; since 'machine-current-services' is not exposed publicly,
> +                 ;; and the resultant <live-service> objects are only used for
> +                 ;; resolving service dependencies.
> +                 (map (lambda (service)
> +                        (list (live-service-provision service)
> +                              (live-service-requirement service)))
> +                      services))))))
> +  (mlet %store-monad ((services (eval remote-exp)))
> +    (return (map (match-lambda
> +                   ((provision requirement)
> +                    (live-service provision requirement #f)))
> +                 services))))

OK, that makes sense here.

(Once we’ve done that (guix graph) demonadification we discussed before,
perhaps we can perform run ‘shepherd-service-upgrade’ entirely on the
“other side”, and at that point we won’t need to expose the
‘live-service’ constructor.)

> +;; (format (current-error-port) "error: ~a~%" (condition-message c))
> +;; (format #t "bootloader successfully installed on '~a'~%"
> +;;                              #$device)

A leftover?  :-)

These two statements disappeared in the process, but I think they’re
added back by one of the subsequent patches, right?

Thanks,
Ludo’.

[bug#36555] [PATCH v4 1/3] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 830 bytes --]

Hi Ludovic,

Ludovic Courtès <ludo@gnu.org> writes:

> I wonder it we should just use
>
>   #~(begin (use-modules (guix build utils)) (invoke …))
>
> here and in other places.
>
> That’s probably better longer-term (for example when we switch to
> Guile 3, that could ease the transition since the right Guile would be
> used) but we can keep it this way and revisit it later.

I've been playing with this for a little while now, and I'm having
second thoughts regarding the use of 'invoke'. Any exceptions thrown in
the callee are swallowed into an '&invoke-error', so context for failure
in i.e. the activation script is lost. Also, does it really matter that
the "right" Guile is being used for the activation scripts if the daemon
is still going to be running the old Guile? WDYT?

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v4 1/3] guix system: Add 'reconfigure' module.

[Ludovic Courtès]

Hi,

zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) skribis:

> Ludovic Courtès <ludo@gnu.org> writes:
>
>> I wonder it we should just use
>>
>>   #~(begin (use-modules (guix build utils)) (invoke …))
>>
>> here and in other places.
>>
>> That’s probably better longer-term (for example when we switch to
>> Guile 3, that could ease the transition since the right Guile would be
>> used) but we can keep it this way and revisit it later.
>
> I've been playing with this for a little while now, and I'm having
> second thoughts regarding the use of 'invoke'. Any exceptions thrown in
> the callee are swallowed into an '&invoke-error', so context for failure
> in i.e. the activation script is lost. Also, does it really matter that
> the "right" Guile is being used for the activation scripts if the daemon
> is still going to be running the old Guile? WDYT?

I guess it only matters in corner cases—i.e., when switching Guiles.
And even then, we’re probably still able to evaluate code, so you’re
right that it’s not that big a deal.

And yeah, losing execution context isn’t great.

So maybe the status quo is not so bad after all!

Ludo’.

[bug#36555] [PATCH v4 1/3] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 24873 bytes --]

* guix/scripts/system/reconfigure.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/system.scm (bootloader-installer-script): Export variable.
* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
* gnu/services/herd.scm (live-service): Export variable.
* gnu/services/herd.scm (live-service-canonical-name): New variable.
* tests/services.scm (live-service): Delete variable.
---
 Makefile.am                         |   1 +
 gnu/machine/ssh.scm                 | 189 ++--------------------
 gnu/services/herd.scm               |   6 +
 guix/scripts/system/reconfigure.scm | 241 ++++++++++++++++++++++++++++
 tests/services.scm                  |   4 -
 5 files changed, 260 insertions(+), 181 deletions(-)
 create mode 100644 guix/scripts/system/reconfigure.scm

diff --git a/Makefile.am b/Makefile.am
index dd7720e87..58a96d348 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -245,6 +245,7 @@ MODULES =					\
   guix/scripts/describe.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
+  guix/scripts/system/reconfigure.scm		\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index a7d1a967a..64d92acc9 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -17,23 +17,21 @@
 ;;; 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 services)
-  #:use-module (gnu services shepherd)
   #:use-module (gnu system)
-  #:use-module (guix derivations)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix modules)
   #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix remote)
+  #: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 +103,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 +161,20 @@ 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)))
+  (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
+    (let* ((os (machine-system machine))
+           (eval (cut machine-remote-eval machine <>))
+           (menu-entries (map boot-parameters->menu-entry boot-parameters))
+           (bootloader-configuration (operating-system-bootloader os))
+           (bootcfg (operating-system-bootcfg os menu-entries)))
+      (mbegin %store-monad
+        (switch-to-system eval os)
+        (upgrade-shepherd-services eval os)
+        (install-bootloader eval bootloader-configuration bootcfg)))))
 
 \f
 ;;;
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 0008746fe..2207b2d34 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -40,10 +40,12 @@
             unknown-shepherd-error?
             unknown-shepherd-error-sexp
 
+            live-service
             live-service?
             live-service-provision
             live-service-requirement
             live-service-running
+            live-service-canonical-name
 
             with-shepherd-action
             current-services
@@ -192,6 +194,10 @@ of pairs."
   (requirement  live-service-requirement)         ;list of symbols
   (running      live-service-running))            ;#f | object
 
+(define (live-service-canonical-name service)
+  "Return the 'canonical name' of SERVICE."
+  (first (live-service-provision service)))
+
 (define (current-services)
   "Return the list of currently defined Shepherd services, represented as
 <live-service> objects.  Return #f if the list of services could not be
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 000000000..2c69ea727
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,241 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 (guix scripts system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu services)
+  #:use-module (gnu services herd)
+  #:use-module (gnu services shepherd)
+  #:use-module (gnu system)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:export (switch-system-program
+            switch-to-system
+
+            upgrade-services-program
+            upgrade-shepherd-services
+
+            install-bootloader-program
+            install-bootloader))
+
+;;; Commentary:
+;;;
+;;; This module implements the "effectful" parts of system
+;;; reconfiguration. Although building a system derivation is a pure
+;;; operation, a number of impure operations must be carried out for the
+;;; system configuration to be realized -- chiefly, creation of generation
+;;; symlinks and invocation of activation scripts.
+;;;
+;;; Code:
+
+\f
+;;;
+;;; Profile creation.
+;;;
+
+(define* (switch-system-program os #:optional profile)
+  "Return an executable store item that, upon being evaluated, will create a
+new generation of PROFILE pointing to the directory of OS, switch to it
+atomically, and run OS's activation script."
+  (program-file
+   "switch-to-system.scm"
+   (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 profile
+             (or #$profile (string-append %state-directory "/profiles/system")))
+
+           (let* ((number (1+ (generation-number profile)))
+                  (generation (generation-file-name profile number)))
+             (switch-symlinks generation #$os)
+             (switch-symlinks profile generation)
+             (setenv "GUIX_NEW_SYSTEM" #$os)
+             (primitive-load #$(operating-system-activation-script os))))))))
+
+(define* (switch-to-system eval os #:optional profile)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+create a new generation of PROFILE pointing to the directory of OS, switch to
+it atomically, and run OS's activation script."
+  (eval #~(primitive-load #$(switch-system-program os profile))))
+
+\f
+;;;
+;;; Services.
+;;;
+
+(define (running-services eval)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+return the <live-service> objects that are currently running on MACHINE."
+  (define remote-exp
+    (with-imported-modules '((gnu services herd))
+      #~(begin
+          (use-modules (gnu services herd))
+          (let ((services (current-services)))
+            (and services
+                 ;; 'live-service-running' is ignored, as we can't necessarily
+                 ;; serialize arbitrary objects. This should be fine for now,
+                 ;; since 'machine-current-services' is not exposed publicly,
+                 ;; and the resultant <live-service> objects are only used for
+                 ;; resolving service dependencies.
+                 (map (lambda (service)
+                        (list (live-service-provision service)
+                              (live-service-requirement service)))
+                      services))))))
+  (mlet %store-monad ((services (eval remote-exp)))
+    (return (map (match-lambda
+                   ((provision requirement)
+                    (live-service provision requirement #f)))
+                 services))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program service-files to-start to-unload to-restart)
+  "Return an executable store item that, upon being evaluated, will upgrade
+the Shepherd (PID 1) by unloading obsolete services and loading new
+services. SERVICE-FILES is a list of Shepherd service files to load, and
+TO-START, TO-UNLOAD, and TO-RESTART are lists of the Shepherd services'
+canonical names (symbols)."
+  (program-file
+   "upgrade-shepherd-services.scm"
+   (with-imported-modules '((gnu services herd))
+    #~(begin
+        (use-modules (gnu services herd)
+                     (srfi srfi-1))
+
+        ;; Load the service files for any new services.
+        (load-services/safe '#$service-files)
+
+        ;; Unload obsolete services and start new services.
+        (for-each unload-service '#$to-unload)
+        (for-each start-service '#$to-start)))))
+
+(define* (upgrade-shepherd-services eval os)
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
+services as defined by OS."
+  (define target-services
+    (service-value
+     (fold-services (operating-system-services os)
+                    #:target-type shepherd-root-service-type)))
+
+  (mlet* %store-monad ((live-services (running-services eval)))
+    (let*-values (((to-unload to-restart)
+                   (shepherd-service-upgrade live-services target-services)))
+      (let* ((to-unload (map live-service-canonical-name to-unload))
+             (to-restart (map shepherd-service-canonical-name to-restart))
+             (to-start (lset-difference eqv?
+                                        (map shepherd-service-canonical-name
+                                             target-services)
+                                        (map live-service-canonical-name
+                                             live-services)))
+             (service-files
+              (map shepherd-service-file
+                   (filter (lambda (service)
+                             (memq (shepherd-service-canonical-name service)
+                                   to-start))
+                           target-services))))
+        (eval #~(primitive-load #$(upgrade-services-program service-files
+                                                            to-start
+                                                            to-unload
+                                                            to-restart)))))))
+
+\f
+;;;
+;;; Bootloader configuration.
+;;;
+
+;; (format (current-error-port) "error: ~a~%" (condition-message c))
+;; (format #t "bootloader successfully installed on '~a'~%"
+;;                              #$device)
+
+(define (install-bootloader-program installer bootloader-package bootcfg
+                                    bootcfg-file device target)
+  "Return an executable store item that, upon being evaluated, will install
+BOOTCFG to BOOTCFG-FILE, a target file name, on DEVICE, a file system device,
+at TARGET, a mount point, and subsequently run INSTALLER from
+BOOTLOADER-PACKAGE."
+  (program-file
+   "install-bootloader.scm"
+   (with-extensions (list guile-gcrypt)
+     (with-imported-modules (source-module-closure '((gnu build bootloader)
+                                                     (gnu build install)
+                                                     (guix store)
+                                                     (guix utils)))
+       #~(begin
+           (use-modules (gnu build bootloader)
+                        (gnu build install)
+                        (guix build utils)
+                        (guix store)
+                        (guix utils)
+                        (ice-9 binary-ports)
+                        (srfi srfi-34)
+                        (srfi srfi-35))
+           (let* ((gc-root (string-append #$target %gc-roots-directory "/bootcfg"))
+                  (temp-gc-root (string-append gc-root ".new")))
+             (switch-symlinks temp-gc-root gc-root)
+             (install-boot-config #$bootcfg #$bootcfg-file #$target)
+             ;; Preserve the previous activation's garbage collector root
+             ;; until the bootloader installer has run, so that a failure in
+             ;; the bootloader's installer script doesn't leave the user with
+             ;; a broken installation.
+             (when #$installer
+               (catch #t
+                 (lambda ()
+                   (#$installer #$bootloader-package #$device #$target))
+                 (lambda args
+                   (delete-file temp-gc-root)
+                   (apply throw args))))
+             (rename-file temp-gc-root gc-root)))))))
+
+(define* (install-bootloader eval configuration bootcfg
+                             #:key
+                             (run-installer? #t)
+                             (target "/"))
+  "Using EVAL, a monadic procedure taking a single G-Expression as an argument,
+configure the bootloader on TARGET such that OS will be booted by default and
+additional configurations specified by MENU-ENTRIES can be selected."
+  (let* ((bootloader (bootloader-configuration-bootloader configuration))
+         (installer (and run-installer?
+                         (bootloader-installer bootloader)))
+         (package (bootloader-package bootloader))
+         (device (bootloader-configuration-target configuration))
+         (bootcfg-file (bootloader-configuration-file bootloader)))
+    (eval #~(primitive-load #$(install-bootloader-program installer
+                                                          package
+                                                          bootcfg
+                                                          bootcfg-file
+                                                          device
+                                                          target)))))
diff --git a/tests/services.scm b/tests/services.scm
index 44ad0022c..572fe3816 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -26,10 +26,6 @@
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
-(define live-service
-  (@@ (gnu services herd) live-service))
-
-\f
 (test-begin "services")
 
 (test-equal "services, default value"
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v3 0/3] Refactor out common behavior for system reconfiguration.

[Christopher Lemmer Webber]

Jakob L. Kreuze writes:

> Hello to anyone reviewing this patch,
>
> I probably should've held off on sending this reroll out. After taking
> some more time to experiment with possible solutions, I was able to
> figure most of this out. Comments would still be appreciated, but the
> points I specifically asked for comments on no longer need special
> treatment. Also, if you haven't already started reviewing this, v4 will
> likely hit the mailing list tomorrow; everything's there, it just needs
> to be cleaned up.
>
> zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze) writes:
>
>> I still need to handle failed deployments in 'guix deploy'. I suspect
>> that, for now, it would make sense to implement remote roll-backs and
>> just roll-back the system on failure, at least until we've have some
>> dialog about the proper way to do atomic deployments.
>
> Well, except for this. I'll submit a separate patch series addressing
> this.

I think that's fine to do in a separate series, and a good idea too.

>> My biggest concern at the moment is error handling reporting in the
>> new 'guix system reconfigure'. I'd like to emulate what was done with
>> the previous version, but I'm at somewhat of a loss for how I'd go
>> about that, since the error reporting was mixed with the
>> reconfiguration code. So I'd like to ask for some suggestions: is the
>> best way to catch errors in '%store-monad' to do what
>> 'with-shepherd-error-handling' does, and then 'leave' on failure?
>>
>> Ludovic suggested guarding against 'message-condition' and having the
>> expression I send to 'remote-eval' return either ('error message) or
>> ('success). Would it make sense to just do this in all of the
>> reconfiguration procedures? Or is raising exceptions in the
>> reconfiguration procedures and catching them in the scripts' code the
>> way to go?
>
> Comments, if anyone has them, would be appreciated, but I feel that I'm
> in a good spot in terms of error handling now.

Or even:

  ('error <error-type-symbol> "error message here")

(I suppose in case of success, a value would never be returned?)

>> There's also a slight bug in the new 'guix system reconfigure' that
>> I'll need to figure out. At the moment, it installs a bootloader entry
>> for all but the newest generation.
>
> It wasn't actually a bug, I was misinterpreting the intended behavior of
> 'guix system reconfigure'. :)

Heh :)

>> Oh, how naïve I was four days ago. This reroll doesn't address this.
>> Having the procedures "parameterized by an evaluation procedure" can
>> be done in so many ways, and I think it would be best I put some
>> serious thought into which of those ways would be the best. A
>> 'local-eval' would clearly be much better than what I'm doing at the
>> present in 'system.scm', but the solution I came up with today
>> involved three layers of 'primitive-load', which I doubt is the way to
>> go about it. I had the idea to parameterize on a procedure that takes
>> a '<program-file>' rather than a G-Expression as I was making dinner
>> tonight, which seems to me like a sound idea, but we'll see if it
>> works tomorrow when I try to implement it.
>
> Actually, a more generalized 'eval' (taking a G-Expression) was the
> better way to go: it allowed me to simplify the interface to the
> reconfiguration procedures even further. And, thanks to Ludovic's recent
> patches with 'lower-gexp', I was able to collapse the Russian nesting
> doll of 'primitive-load' calls.

Yay!  Generalization!

>> Also, it hit me today that the safety checks done in 'guix system
>> reconfigure' -- 'check-mapped-devices',
>> 'check-file-system-availability', and 'check-initrd-modules' -- should
>> also be done in 'guix deploy'. It might make sense for me to submit that
>> change as a separate patch series so the code review for this doesn't
>> get too complicated, but since we're on the topic of unifying the code
>> between 'guix deploy' and 'guix system reconfigure', should I perhaps
>> reimplement those procedures as '<program-file>' objects like everything
>> else in '(guix scripts system reconfigure)'? They aren't really
>> effectful, but they concern system reconfiguration.
>
> Again, separate patch series.

Yes, please do.

My main worry is that such a patch series may be forgotten.  Would it be
inappropriate to make a "stub" patch issue for both of the followup
patch series, since both seem important and we don't want to forget them?

>> And, on the same note, should I go ahead and refactor the rest of the
>> reconfiguration code in 'system.scm' out into '(guix scripts system
>> reconfigure)'? I mean, this will probably be a separate patch series for
>> the same reason that the safety checks would be a separate patch series,
>> and I'll likely do this _after_ I come up with a decent way to
>> parameterize on an evaluation procedure, but I'd like to know if it's a
>> good idea or not before going ahead and ripping apart 'system.scm'.
>
> I'd still like comments on this, though.

I guess see above.

But I think we shouldn't wait, since I'd like to keep the energy up and
get this merged in.
 - Chris

[bug#36555] [PATCH v3 0/3] Refactor out common behavior for system reconfiguration.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 551 bytes --]

Hey, Chris!

Christopher Lemmer Webber <cwebber@dustycloud.org> writes:

> My main worry is that such a patch series may be forgotten. Would it
> be inappropriate to make a "stub" patch issue for both of the followup
> patch series, since both seem important and we don't want to forget
> them?

Alternatively, because these patches address existing issues with 'guix
deploy', should we open tickets on the issue tracker? I don't have too
much of a preference: either way should work fine for ensuring that we
don't forget about them.

Regards,
Jakob

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v3 0/3] Refactor out common behavior for system reconfiguration.

[Christopher Lemmer Webber]

Jakob L. Kreuze writes:

> Hey, Chris!
>
> Christopher Lemmer Webber <cwebber@dustycloud.org> writes:
>
>> My main worry is that such a patch series may be forgotten. Would it
>> be inappropriate to make a "stub" patch issue for both of the followup
>> patch series, since both seem important and we don't want to forget
>> them?
>
> Alternatively, because these patches address existing issues with 'guix
> deploy', should we open tickets on the issue tracker? I don't have too
> much of a preference: either way should work fine for ensuring that we
> don't forget about them.
>
> Regards,
> Jakob

That's a good call.  Yeah, I think put them there.

[bug#36555] [PATCH 0/2] Refactor out common behavior for system reconfiguration.

[Christopher Lemmer Webber]

Jakob L. Kreuze writes:

> Hello, Guix!
>
> This is the preliminary version of a patch series to turn the behavior
> common between 'guix deploy' and 'guix system reconfigure' into a module
> that both can use. I am submitting it as-is both for comments and for
> tracking the refactoring effort.
>
> Note that this is _not_ ready to be merged. There are several things
> that I need to do before I would consider it ready for upstream Guix:

I just did a brief scan of the patches you submitted.  I don't have any
comments beyond your TODO list.  It's much clearer to me what's going on
with those commits beings quashed now, horray!

Look forward to more updates, keep it up Jakob! :)

[bug#36555] [PATCH v2 0/3] Refactor out common behavior for system reconfiguration.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 2246 bytes --]

I've implemented the features missing from 'switch-system-program',
'upgrade-services-program', and 'install-bootloader-program' and successfully
ran the new 'guix system reconfigure' in a virtual machine.

Also tests for 'switch-system-program' have been implement, but I realized that
I'll need to be a bit more clever to test 'upgrade-services-program' and
'install-bootloader-program' -- the latter, in particular, requires boot
parameters from the machine being tested at build time, so I suspect I'll have
to provide some constant boot parameters to avoid spinning up the virtual
machine outside of the test derivation.

Anyway, I've reverted a change in my previous patch series that updated
'upgrade-shepherd-services' to use 'call-with-service-upgrade-info', since I'd
neglected to check the parameters that it passes to 'mproc'. Basically, it _has_
to be called from 'upgrade-services-program', which already has some
functionality comparible to 'shepherd-service-upgrade'. If someone could take a
look and ensure that it sufficiently implements 'shepherd-service-upgrade', that
would be greatly appreciated.

On that note, I've changed 'upgrade-services-program' to collect Shepherd error
messages as it goes. Is this the right way to go about it? My thinking is that,
this way, both 'guix system reconfigure' and 'guix deploy' will be able to
report Shepherd errors without stopping half-way through because Shepherd errors
out. Either way, I believe this fixes the issue that Ricardo was having with
'guix deploy'.

Regards,
Jakob

Jakob L. Kreuze (3):
  guix system: Add 'reconfigure' module.
  guix system: Reimplement 'reconfigure'.
  tests: Add reconfigure system test.

 Makefile.am                         |   1 +
 gnu/local.mk                        |   1 +
 gnu/machine/ssh.scm                 | 229 +++++++---------------------
 gnu/tests/reconfigure.scm           |  99 ++++++++++++
 guix/scripts/system.scm             | 143 +++++------------
 guix/scripts/system/reconfigure.scm | 170 +++++++++++++++++++++
 6 files changed, 364 insertions(+), 279 deletions(-)
 create mode 100644 gnu/tests/reconfigure.scm
 create mode 100644 guix/scripts/system/reconfigure.scm

-- 
2.22.0

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v2 1/3] guix system: Add 'reconfigure' module.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 22018 bytes --]

* guix/scripts/system/reconfigure.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/system.scm (bootloader-installer-script): Export variable.
* gnu/machine/ssh.scm (switch-to-system, upgrade-shepherd-services)
(install-bootloader): Delete variable.
* gnu/machine/ssh.scm (deploy-managed-host): Rewrite procedure.
---
 Makefile.am                         |   1 +
 gnu/machine/ssh.scm                 | 229 +++++++---------------------
 guix/scripts/system.scm             |   1 +
 guix/scripts/system/reconfigure.scm | 170 +++++++++++++++++++++
 4 files changed, 228 insertions(+), 173 deletions(-)
 create mode 100644 guix/scripts/system/reconfigure.scm

diff --git a/Makefile.am b/Makefile.am
index dd7720e87..58a96d348 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -245,6 +245,7 @@ MODULES =					\
   guix/scripts/describe.scm			\
   guix/scripts/system.scm			\
   guix/scripts/system/search.scm		\
+  guix/scripts/system/reconfigure.scm		\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index a7d1a967a..5bac966ad 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,63 @@ 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."
+  (define target-services
+    (service-value
+     (fold-services (operating-system-services (machine-system machine))
+                    #:target-type shepherd-root-service-type)))
+
+  (define (serialize-service service)
+    "Monadic procedure serializing SERVICE, a <shepherd-service>."
+    (mlet %store-monad ((file (lower-object (shepherd-service-file service))))
+      (return (list (shepherd-service-canonical-name service)
+                    (derivation->output-path file)))))
+
+  (define (run-switch-to-system machine)
+    "Monadic procedure serializing the items in MACHINE necessary to build a
+G-Expression with 'switch-to-system'."
+    (mlet %store-monad ((script (switch-system-program (machine-system machine))))
+        (machine-remote-eval machine #~(primitive-load #$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 ((services (mapm %store-monad serialize-service
+                                         target-services))
+                         (script (upgrade-services-program services)))
+      (machine-remote-eval machine #~(primitive-load #$script))))
+
+  (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)))
+        (mlet %store-monad ((script (install-bootloader-program installer
+                                                                bootcfg
+                                                                bootcfg-file
+                                                                "/")))
+          (machine-remote-eval machine #~(primitive-load #$script))))))
+
   (maybe-raise-unsupported-configuration-error machine)
-  (mbegin %store-monad
-    (switch-to-system machine)
-    (upgrade-shepherd-services machine)
-    (install-bootloader machine)))
+  (mapm %store-monad (cut <> machine)
+        (list run-switch-to-system
+              run-upgrade-shepherd-services
+              run-install-bootloader)))
 
 \f
 ;;;
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 60c1ca5c9..21858ee7d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -70,6 +70,7 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:export (guix-system
+            bootloader-installer-script
             read-operating-system))
 
 \f
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
new file mode 100644
index 000000000..9491bde34
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,170 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 (guix scripts system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (gnu system)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:export (switch-system-program
+            upgrade-services-program
+            install-bootloader-program))
+
+;;; Commentary:
+;;;
+;;; This module implements the "effectful" parts of system
+;;; reconfiguration. Although building a system derivation is a pure
+;;; operation, a number of impure operations must be carried out for the
+;;; system configuration to be realized -- chiefly, creation of generation
+;;; symlinks and invocation of activation scripts.
+;;;
+;;; Code:
+
+(define* (switch-system-program os #:optional profile)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will create a new generation of PROFILE pointing to the
+directory of OS, switch to it atomically, and run OS's activation script,
+returning any textual output produced by the activation script as a string."
+  (gexp->script
+   "switch-to-system.scm"
+   (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 profile
+             (or #$profile (string-append %state-directory "/profiles/system")))
+
+           (let* ((number (1+ (generation-number profile)))
+                  (generation (generation-file-name profile number)))
+             (switch-symlinks generation #$os)
+             (switch-symlinks profile generation)
+             (setenv "GUIX_NEW_SYSTEM" #$os)
+             (with-output-to-string
+               (lambda ()
+                 (primitive-load
+                  #$(operating-system-activation-script os))))))))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-services-program target-services)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will upgrade the Shepherd (PID 1) by unloading obsolete
+services and loading new services. TARGET-SERVICES is a list
+of (shepherd-service-canonical-name, shepherd-service-file) pairs used for
+determining which services are obsolete, as well as which are new."
+  (gexp->script
+   "upgrade-shepherd-services.scm"
+   (with-imported-modules '((gnu services herd))
+    #~(begin
+        (use-modules (gnu services herd)
+                     (srfi srfi-1))
+
+        (define (call-with-shepherd-error-handling proc)
+          (lambda (service)
+            (catch 'system-error
+              (lambda ()
+                (proc service)
+                #f)
+              (lambda (key proc format-string format-args errno . rest)
+                (apply format #f format-string format-args)))))
+
+        (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))
+
+        ;; Load the service files for any new services.
+        (load-services/safe (map second to-start))
+
+        ;; Unload obsolete services and start new services.
+        (filter string?
+                (append (map (call-with-shepherd-error-handling unload-service)
+                             to-unload)
+                        (map (call-with-shepherd-error-handling start-service)
+                             (map first to-start))))))))
+
+(define (install-bootloader-program installer-script bootcfg bootcfg-file target)
+  "Return as a monadic value a derivation to build a scheme file that, upon
+being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target file name, on
+TARGET, a mount point, and subsequently run INSTALLER-SCRIPT, returning any
+textual output produced by the installer script as a string."
+  (gexp->script
+   "install-bootloader.scm"
+   (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 #$target %gc-roots-directory "/bootcfg"))
+                  (temp-gc-root (string-append gc-root ".new")))
+
+             (switch-symlinks temp-gc-root gc-root)
+
+             (let ((installer-result
+                    (false-if-exception
+                     (begin
+                       (install-boot-config #$bootcfg #$bootcfg-file #$target)
+                       (with-output-to-string
+                         (lambda ()
+                           (when #$installer-script
+                             (primitive-load #$installer-script))))))))
+               (unless installer-result
+                 (delete-file temp-gc-root)
+                 (error "failed to install bootloader"))
+               (rename-file temp-gc-root gc-root)
+               installer-result)))))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v2 2/3] guix system: Reimplement 'reconfigure'.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 9996 bytes --]

* guix/scripts/system.scm (switch-to-system)
(upgrade-shepherd-services, install-bootloader): Delete variable.
* guix/scripts/system.scm (%switch-to-system)
(%upgrade-shepherd-services, %install-bootloader): New variable.
---
 guix/scripts/system.scm | 142 ++++++++++------------------------------
 1 file changed, 36 insertions(+), 106 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 21858ee7d..a1807c39c 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -41,6 +41,7 @@
                                        delete-matching-generations)
   #:use-module (guix graph)
   #:use-module (guix scripts graph)
+  #:use-module (guix scripts system reconfigure)
   #:use-module (guix build utils)
   #:use-module (guix progress)
   #:use-module ((guix build syscalls) #:select (terminal-columns))
@@ -179,38 +180,14 @@ TARGET, and register them."
 
     (return *unspecified*)))
 
-(define* (install-bootloader installer
-                             #:key
-                             bootcfg bootcfg-file
-                             target)
+(define (install-bootloader installer bootcfg bootcfg-file target)
   "Run INSTALLER, a bootloader installation script, with error handling, in
 %STORE-MONAD."
-  (mlet %store-monad ((installer-drv (if installer
-                                         (lower-object installer)
-                                         (return #f)))
-                      (bootcfg       (lower-object bootcfg)))
-    (let* ((gc-root      (string-append target %gc-roots-directory
-                                        "/bootcfg"))
-           (temp-gc-root (string-append gc-root ".new"))
-           (install (and installer-drv
-                         (derivation->output-path installer-drv)))
-           (bootcfg (derivation->output-path bootcfg)))
-      ;; Prepare the symlink to bootloader config file to make sure that it's
-      ;; a GC root when 'installer-drv' completes (being a bit paranoid.)
-      (switch-symlinks temp-gc-root bootcfg)
-
-      (unless (false-if-exception
-               (begin
-                 (install-boot-config bootcfg bootcfg-file target)
-                 (when install
-                   (save-load-path-excursion (primitive-load install)))))
-        (delete-file temp-gc-root)
-        (leave (G_ "failed to install bootloader ~a~%") install))
-
-      ;; Register bootloader config file as a GC root so that its dependencies
-      ;; (background image, font, etc.) are not reclaimed.
-      (rename-file temp-gc-root gc-root)
-      (return #t))))
+  (mlet* %store-monad ((script (install-bootloader-program installer bootcfg
+                                                           bootcfg-file target))
+                       (file (lower-object script))
+                       (_ (built-derivations (list file))))
+    (return (primitive-load (derivation->output-path file)))))
 
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
@@ -266,10 +243,8 @@ the ownership of '~a' may be incorrect!~%")
         (populate os-dir target)
 
         (mwhen install-bootloader?
-          (install-bootloader bootloader-installer
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader bootloader-installer bootcfg
+                              bootcfg-file target))))))
 
 \f
 ;;;
@@ -343,74 +318,31 @@ services specified in OS and not currently running.
 This is currently very conservative in that it does not stop or unload any
 running service.  Unloading or stopping the wrong service ('udev', say) could
 bring the system down."
-  (define new-services
+  (define target-services
     (service-value
      (fold-services (operating-system-services os)
                     #:target-type shepherd-root-service-type)))
 
-  ;; Arrange to simply emit a warning if the service upgrade fails.
-  (with-shepherd-error-handling
-   (call-with-service-upgrade-info new-services
-     (lambda (to-restart to-unload)
-        (for-each (lambda (unload)
-                    (info (G_ "unloading service '~a'...~%") unload)
-                    (unload-service unload))
-                  to-unload)
-
-        (with-monad %store-monad
-          (munless (null? new-services)
-            (let ((new-service-names  (map shepherd-service-canonical-name new-services))
-                  (to-restart-names   (map shepherd-service-canonical-name to-restart))
-                  (to-start           (filter shepherd-service-auto-start? new-services)))
-              (info (G_ "loading new services:~{ ~a~}...~%") new-service-names)
-              (unless (null? to-restart-names)
-                ;; Listing TO-RESTART-NAMES in the message below wouldn't help
-                ;; because many essential services cannot be meaningfully
-                ;; restarted.  See <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=22039#30>.
-                (format #t (G_ "To complete the upgrade, run 'herd restart SERVICE' to stop,
-upgrade, and restart each service that was not automatically restarted.\n")))
-              (mlet %store-monad ((files (mapm %store-monad
-                                               (compose lower-object
-                                                        shepherd-service-file)
-                                               new-services)))
-                ;; Here we assume that FILES are exactly those that were computed
-                ;; as part of the derivation that built OS, which is normally the
-                ;; case.
-                (load-services/safe (map derivation->output-path files))
-
-                (for-each start-service
-                          (map shepherd-service-canonical-name to-start))
-                (return #t)))))))))
-
-(define* (switch-to-system os
-                           #:optional (profile %system-profile))
-  "Make a new generation of PROFILE pointing to the directory of OS, switch to
-it atomically, and then run OS's activation script."
-  (mlet* %store-monad ((drv (operating-system-derivation os))
-                       (script (lower-object (operating-system-activation-script os))))
-    (let* ((system     (derivation->output-path drv))
-           (number     (+ 1 (generation-number profile)))
-           (generation (generation-file-name profile number)))
-      (switch-symlinks generation system)
-      (switch-symlinks profile generation)
-
-      (format #t (G_ "activating system...~%"))
-
-      ;; The activation script may change $PATH, among others, so protect
-      ;; against that.
-      (save-environment-excursion
-       ;; Tell 'activate-current-system' what the new system is.
-       (setenv "GUIX_NEW_SYSTEM" system)
-
-       ;; The activation script may modify '%load-path' & co., so protect
-       ;; against that.  This is necessary to ensure that
-       ;; 'upgrade-shepherd-services' gets to see the right modules when it
-       ;; computes derivations with 'gexp->derivation'.
-       (save-load-path-excursion
-        (primitive-load (derivation->output-path script))))
-
-      ;; Finally, try to update system services.
-      (upgrade-shepherd-services os))))
+  (define (serialize-service service)
+    "Monadic procedure serializing SERVICE, a <shepherd-service>."
+    (mlet %store-monad ((file (lower-object (shepherd-service-file service))))
+      (return (list (shepherd-service-canonical-name service)
+                    (derivation->output-path file)))))
+
+  (mlet* %store-monad ((services (mapm %store-monad serialize-service
+                                       target-services))
+                       (script (upgrade-services-program services))
+                       (file (lower-object script))
+                       (_ (built-derivations (list file))))
+    (return (primitive-load (derivation->output-path file)))))
+
+(define (switch-to-system os)
+  "Make a new generation of PROFILE pointing to the directory of OS, switch
+to it atomically, and then run OS's activation script."
+  (mlet* %store-monad ((script (switch-system-program os))
+                       (file (lower-object script))
+                       (_ (built-derivations (list file))))
+    (return (primitive-load (derivation->output-path file)))))
 
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
@@ -514,10 +446,7 @@ STORE is an open connection to the store."
           (built-derivations drvs)
           ;; Only install bootloader configuration file. Thus, no installer is
           ;; provided here.
-          (install-bootloader #f
-                              #:bootcfg bootcfg
-                              #:bootcfg-file bootcfg-file
-                              #:target target))))))
+          (install-bootloader #f bootcfg bootcfg-file target))))))
 
 \f
 ;;;
@@ -918,13 +847,14 @@ static checks."
 
           (case action
             ((reconfigure)
+             (newline)
+             (format #t (G_ "activating system...~%"))
              (mbegin %store-monad
                (switch-to-system os)
+               (upgrade-shepherd-services os)
                (mwhen install-bootloader?
-                 (install-bootloader bootloader-script
-                                     #:bootcfg bootcfg
-                                     #:bootcfg-file bootcfg-file
-                                     #:target "/"))))
+                 (install-bootloader bootloader-script bootcfg
+                                     bootcfg-file (or target "/")))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#36555] [PATCH v2 3/3] tests: Add reconfigure system test.

[Jakob L. Kreuze]

[-- Attachment #1: Type: text/plain, Size: 4580 bytes --]

* gnu/tests/reconfigure.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
---
 gnu/local.mk              |  1 +
 gnu/tests/reconfigure.scm | 99 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 100 insertions(+)
 create mode 100644 gnu/tests/reconfigure.scm

diff --git a/gnu/local.mk b/gnu/local.mk
index 0e17af953..b334d0572 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -592,6 +592,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/mail.scm				\
   %D%/tests/messaging.scm			\
   %D%/tests/networking.scm			\
+  %D%/tests/reconfigure.scm			\
   %D%/tests/rsync.scm				\
   %D%/tests/security-token.scm			\
   %D%/tests/singularity.scm			\
diff --git a/gnu/tests/reconfigure.scm b/gnu/tests/reconfigure.scm
new file mode 100644
index 000000000..bb8c33bf5
--- /dev/null
+++ b/gnu/tests/reconfigure.scm
@@ -0,0 +1,99 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.lonestar.org>
+;;;
+;;; 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 tests reconfigure)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu services)
+  #:use-module (gnu services networking)
+  #:use-module (gnu services shepherd)
+  #:use-module (guix derivations)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
+  #:use-module (guix scripts system reconfigure)
+  #:use-module (guix store)
+  #:export (%test-switch-to-system))
+
+;;; Commentary:
+;;;
+;;; Test in-place system reconfiguration: advancing the system generation on a
+;;; running instance of the Guix System.
+;;;
+;;; Code:
+
+(define* (run-switch-to-system-test)
+  "Run a test of an OS running SWITCH-SYSTEM-PROGRAM, which creates a new
+generation of the system profile."
+  (define os
+    (marionette-operating-system
+     (simple-operating-system)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm (virtual-machine os))
+
+  (define (test script)
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (define (system-generations marionette)
+            "Return the names of the generation symlinks on MARIONETTE."
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 ftw)
+                             (srfi srfi-1))
+                (let* ((profile-dir "/var/guix/profiles/")
+                       (entries (map first (cddr (file-system-tree profile-dir)))))
+                  (remove (lambda (entry)
+                            (member entry '("per-user" "system")))
+                          entries)))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "switch-to-system")
+
+          (let ((generations-prior (system-generations marionette)))
+            (test-assert "capture activation script output"
+              (string?
+               (marionette-eval
+                '(primitive-load #$script)
+                marionette)))
+
+            (test-equal "deployment created new generation"
+              (length (system-generations marionette))
+              (1+ (length generations-prior))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (mlet %store-monad ((script (switch-system-program os)))
+    (gexp->derivation "switch-to-system" (test script))))
+
+(define %test-switch-to-system
+  (system-test
+   (name "switch-to-system")
+   (description "Create a new generation of the system profile.")
+   (value (run-switch-to-system-test))))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]