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

[zerodaysfordays@sdf.lonestar.org (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 --]