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

[Jakob L. Kreuze]

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

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

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 
<address@hidden>
+;;; Copyright © 2016 Alex Kost <address@hidden>
+;;; Copyright © 2016, 2017, 2018 Chris Marusich <address@hidden>
+;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
+;;; Copyright © 2018 Ricardo Wurmus <address@hidden>
+;;; Copyright © 2019 Christopher Baines <address@hidden>
+;;; Copyright © 2019 Jakob L. Kreuze <address@hidden>
+;;;
+;;; 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

signature.asc
Description: PGP signature