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

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