unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
From: zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze)
To: 36555@debbugs.gnu.org
Subject: [bug#36555] [PATCH 2/2] guix system: Reimplement 'reconfigure'.
Date: Mon, 08 Jul 2019 16:01:27 -0400	[thread overview]
Message-ID: <87a7doi9d4.fsf_-_@sdf.lonestar.org> (raw)
In-Reply-To: <87ef30i9fl.fsf@sdf.lonestar.org> (Jakob L. Kreuze's message of "Mon, 08 Jul 2019 15:59:58 -0400")

[-- 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 --]

  reply	other threads:[~2019-07-08 20:02 UTC|newest]

Thread overview: 52+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2019-07-08 19:52 [bug#36555] [PATCH 0/2] Refactor out common behavior for system reconfiguration Jakob L. Kreuze
2019-07-08 19:59 ` [bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module Jakob L. Kreuze
2019-07-08 20:01   ` Jakob L. Kreuze [this message]
2019-07-13 10:23   ` Ludovic Courtès
2019-07-13 17:44     ` Jakob L. Kreuze
2019-07-14 13:23       ` Ludovic Courtès
2019-07-15 15:36         ` Jakob L. Kreuze
2019-07-15 16:32           ` Ludovic Courtès
2019-07-15 23:57             ` Jakob L. Kreuze
2019-07-16 23:46               ` [bug#36555] [PATCH v3 0/3] Refactor out common behavior for system reconfiguration Jakob L. Kreuze
2019-07-16 23:47                 ` [bug#36555] [PATCH v3 1/3] guix system: Add 'reconfigure' module Jakob L. Kreuze
2019-07-16 23:48                   ` [bug#36555] [PATCH v3 2/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze
2019-07-16 23:48                     ` [bug#36555] [PATCH v3 3/3] tests: Add reconfigure system test Jakob L. Kreuze
2019-07-19 11:57                   ` [bug#36555] [PATCH v3 1/3] guix system: Add 'reconfigure' module Ludovic Courtès
2019-07-18 22:50                 ` [bug#36555] [PATCH v3 0/3] Refactor out common behavior for system reconfiguration Jakob L. Kreuze
2019-07-19 17:54                   ` [bug#36555] [PATCH v4 " Jakob L. Kreuze
2019-07-19 17:55                     ` [bug#36555] [PATCH v4 1/3] guix system: Add 'reconfigure' module Jakob L. Kreuze
2019-07-19 17:58                       ` [bug#36555] [PATCH v4 2/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze
2019-07-19 17:59                         ` [bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test Jakob L. Kreuze
2019-07-20 14:50                           ` Ludovic Courtès
2019-07-22 18:16                             ` Jakob L. Kreuze
2019-07-22 18:23                               ` Jakob L. Kreuze
2019-07-22 18:54                               ` [bug#36555] [PATCH v5 0/3] Refactor out common behavior for system reconfiguration Jakob L. Kreuze
2019-07-22 18:56                                 ` [bug#36555] [PATCH v5 1/3] guix system: Add 'reconfigure' module Jakob L. Kreuze
2019-07-22 18:57                                   ` [bug#36555] [PATCH v5 2/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze
2019-07-22 18:57                                     ` [bug#36555] [PATCH v5 3/3] tests: Add reconfigure system test Jakob L. Kreuze
2019-07-23 22:30                                     ` [bug#36555] [PATCH v5 2/3] guix system: Reimplement 'reconfigure' Ludovic Courtès
2019-07-24  0:06                                       ` Jakob L. Kreuze
2019-07-24  0:48                                         ` Jakob L. Kreuze
2019-07-24 16:33                                           ` [bug#36555] [PATCH v6 0/3] Refactor out common behavior for system reconfiguration Jakob L. Kreuze
2019-07-24 16:34                                             ` [bug#36555] [PATCH v6 1/3] guix system: Add 'reconfigure' module Jakob L. Kreuze
2019-07-24 16:34                                               ` [bug#36555] [PATCH v6 2/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze
2019-07-24 16:35                                                 ` [bug#36555] [PATCH v6 3/3] tests: Add reconfigure system test Jakob L. Kreuze
2019-07-26 16:59                                                   ` bug#36555: " Ludovic Courtès
2019-07-26 17:53                                                     ` [bug#36555] " Jakob L. Kreuze
2019-07-24 22:46                                           ` [bug#36555] [PATCH v5 2/3] guix system: Reimplement 'reconfigure' Ludovic Courtès
2019-07-23 21:47                               ` [bug#36555] [PATCH v4 3/3] tests: Add reconfigure system test Ludovic Courtès
2019-07-24  0:01                                 ` Jakob L. Kreuze
2019-07-24 22:44                                   ` Ludovic Courtès
2019-07-20 14:40                         ` [bug#36555] [PATCH v4 2/3] guix system: Reimplement 'reconfigure' Ludovic Courtès
2019-07-20 14:29                       ` [bug#36555] [PATCH v4 1/3] guix system: Add 'reconfigure' module Ludovic Courtès
2019-07-30 16:55                         ` Jakob L. Kreuze
2019-08-23 21:00                           ` Ludovic Courtès
2019-07-19 17:56                     ` Jakob L. Kreuze
2019-07-19 19:36                   ` [bug#36555] [PATCH v3 0/3] Refactor out common behavior for system reconfiguration Christopher Lemmer Webber
2019-07-22 16:18                     ` Jakob L. Kreuze
2019-07-22 16:39                       ` Christopher Lemmer Webber
2019-07-09 13:26 ` [bug#36555] [PATCH 0/2] " Christopher Lemmer Webber
2019-07-09 19:07   ` [bug#36555] [PATCH v2 0/3] " Jakob L. Kreuze
2019-07-09 19:08     ` [bug#36555] [PATCH v2 1/3] guix system: Add 'reconfigure' module Jakob L. Kreuze
2019-07-09 19:09       ` [bug#36555] [PATCH v2 2/3] guix system: Reimplement 'reconfigure' Jakob L. Kreuze
2019-07-09 19:09         ` [bug#36555] [PATCH v2 3/3] tests: Add reconfigure system test Jakob L. Kreuze

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=87a7doi9d4.fsf_-_@sdf.lonestar.org \
    --to=zerodaysfordays@sdf.lonestar.org \
    --cc=36555@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).