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

[zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze)]

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

* guix/scripts/system/reconfigure.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/scripts/system.scm (bootloader-installer-script): Export variable.
---
 Makefile.am                         |   1 +
 guix/scripts/system.scm             |   1 +
 guix/scripts/system/reconfigure.scm | 157 ++++++++++++++++++++++++++++
 3 files changed, 159 insertions(+)
 create mode 100644 guix/scripts/system/reconfigure.scm

diff --git a/Makefile.am b/Makefile.am
index 4d3024e58..1934a21b1 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/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..f4ca6b4b1
--- /dev/null
+++ b/guix/scripts/system/reconfigure.scm
@@ -0,0 +1,157 @@
+;;; 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 (guix scripts system reconfigure)
+  #:autoload   (gnu packages gnupg) (guile-gcrypt)
+  #:use-module (guix gexp)
+  #:use-module (guix modules)
+  #:export (switch-to-system
+            upgrade-shepherd-services
+            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:
+
+(define (switch-to-system system-derivation activation-script)
+  "Return a G-Expression that, upon being evaluated, will create a new
+generation for SYSTEM-DERIVATION and execute ACTIVATION-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 #$system-derivation)
+                 (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 #$activation-script))))))))
+
+;; XXX: Currently, this does NOT attempt to restart running services. See
+;; <https://issues.guix.info/issue/33508> for details.
+(define (upgrade-shepherd-services target-services)
+  "Return a G-Expression 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."
+  (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 installer-script bootcfg bootcfg-file target)
+  "Return a G-Expression that, upon being evaluated, will install BOOTCFG to
+BOOTCFG-FILE, a target path, on TARGET, a mount point, and subsequently run
+INSTALLER-SCRIPT."
+  (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 #$target)
+                       ;; 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-script)))))
+              (delete-file temp-gc-root)
+              (error "failed to install bootloader"))
+
+            (rename-file temp-gc-root gc-root))))))
-- 
2.22.0


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