[bug#36404] [PATCH 3/3] guix system: Reimplement 'reconfigure'.

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

[-- Attachment #1: Type: text/plain, Size: 11031 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 | 161 +++++++++++++---------------------------
 1 file changed, 50 insertions(+), 111 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 21858ee7d..1f7912dcf 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,16 @@ 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
+                              (scheme-file "install-bootloader.scm"
+                                           (install-bootloader installer bootcfg
+                                                               bootcfg-file
+                                                               target))))
+                       (_ (built-derivations (list file))))
+    (primitive-load (derivation->output-path file))))
 
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
@@ -266,10 +245,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
 ;;;
@@ -336,81 +313,47 @@ unload."
        (warning (G_ "failed to obtain list of shepherd services~%"))
        (return #f)))))
 
-(define (upgrade-shepherd-services os)
+(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."
+  (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 os)
+                          #:target-type shepherd-root-service-type))))
+
+  (mlet* %store-monad ((target-services target-services)
+                       (file (lower-object
+                              (scheme-file "upgrade-shepherd-services.scm"
+                                           (upgrade-shepherd-services
+                                            target-services))))
+                       (_ (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 ((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))))
+                       (script (lower-object
+                                (operating-system-activation-script os)))
+                       (file (lower-object
+                              (scheme-file "switch-to-system.scm"
+                                           (switch-to-system drv script))))
+                       (_ (built-derivations (list file))))
+    (primitive-load (derivation->output-path file))))
 
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
@@ -514,10 +457,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
 ;;;
@@ -919,12 +859,11 @@ static checks."
           (case action
             ((reconfigure)
              (mbegin %store-monad
-               (switch-to-system os)
+               (%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 --]