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 v3 2/3] guix system: Reimplement 'reconfigure'.
Date: Tue, 16 Jul 2019 19:48:09 -0400	[thread overview]
Message-ID: <87muhdzgli.fsf_-_@sdf.lonestar.org> (raw)
In-Reply-To: <87r26pzgmx.fsf_-_@sdf.lonestar.org> (Jakob L. Kreuze's message of "Tue, 16 Jul 2019 19:47:18 -0400")

[-- Attachment #1: Type: text/plain, Size: 18139 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             | 151 +++++++++-------------------
 guix/scripts/system/reconfigure.scm | 116 +++++++--------------
 2 files changed, 79 insertions(+), 188 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 21858ee7d..b59818577 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 ((file (lower-object
+                              (install-bootloader-program installer bootcfg
+                                                          bootcfg-file target)))
+                       (_ (built-derivations (list file))))
+    (return (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
 ;;;
@@ -343,74 +318,39 @@ 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
+  (define target-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."
-  (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))))
+  (let-values (((to-unload to-restart)
+                (shepherd-service-upgrade (current-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 (current-services))))
+           (service-files
+            (map shepherd-service-file
+                 (filter (lambda (service)
+                           (memq (shepherd-service-canonical-name service)
+                                 to-start))
+                         target-services))))
+      (mlet* %store-monad ((file (lower-object
+                                  (upgrade-services-program service-files
+                                                            to-start
+                                                            to-unload
+                                                            to-restart)))
+                           (_ (built-derivations (list file))))
+        (return (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 ((file (lower-object (switch-system-program os)))
+                       (_ (built-derivations (list file))))
+    (return (primitive-load (derivation->output-path file)))))
 
 (define-syntax-rule (unless-file-not-found exp)
   (catch 'system-error
@@ -514,10 +454,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
 ;;;
@@ -918,13 +855,15 @@ static checks."
 
           (case action
             ((reconfigure)
+             (newline)
+             (format #t (G_ "activating system...~%"))
              (mbegin %store-monad
                (switch-to-system os)
                (mwhen install-bootloader?
-                 (install-bootloader bootloader-script
-                                     #:bootcfg bootcfg
-                                     #:bootcfg-file bootcfg-file
-                                     #:target "/"))))
+                 (install-bootloader bootloader-script bootcfg
+                                     bootcfg-file (or target "/")))
+               (with-shepherd-error-handling
+                (upgrade-shepherd-services os))))
             ((init)
              (newline)
              (format #t (G_ "initializing operating system under '~a'...~%")
diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm
index 9491bde34..1ef656f0c 100644
--- a/guix/scripts/system/reconfigure.scm
+++ b/guix/scripts/system/reconfigure.scm
@@ -42,11 +42,11 @@
 ;;; Code:
 
 (define* (switch-system-program os #:optional profile)
-  "Return as a monadic value a derivation to build a scheme file 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,
-returning any textual output produced by the activation script as a string."
-  (gexp->script
+  "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, returning any textual output
+produced by the activation script as a string."
+  (program-file
    "switch-to-system.scm"
    (with-extensions (list guile-gcrypt)
      (with-imported-modules (source-module-closure '((guix config)
@@ -65,82 +65,36 @@ returning any textual output produced by the activation script as a string."
              (switch-symlinks generation #$os)
              (switch-symlinks profile generation)
              (setenv "GUIX_NEW_SYSTEM" #$os)
-             (with-output-to-string
-               (lambda ()
-                 (primitive-load
-                  #$(operating-system-activation-script os))))))))))
+             (primitive-load #$(operating-system-activation-script os))))))))
 
 ;; XXX: Currently, this does NOT attempt to restart running services. See
 ;; <https://issues.guix.info/issue/33508> for details.
-(define (upgrade-services-program target-services)
-  "Return as a monadic value a derivation to build a scheme file that, upon
-being evaluated, will upgrade the Shepherd (PID 1) by unloading obsolete
-services and loading new services. TARGET-SERVICES is a list
-of (shepherd-service-canonical-name, shepherd-service-file) pairs used for
-determining which services are obsolete, as well as which are new."
-  (gexp->script
+(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))
 
-        (define (call-with-shepherd-error-handling proc)
-          (lambda (service)
-            (catch 'system-error
-              (lambda ()
-                (proc service)
-                #f)
-              (lambda (key proc format-string format-args errno . rest)
-                (apply format #f format-string format-args)))))
-
-        (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))
-
         ;; Load the service files for any new services.
-        (load-services/safe (map second to-start))
+        (load-services/safe '#$service-files)
 
         ;; Unload obsolete services and start new services.
-        (filter string?
-                (append (map (call-with-shepherd-error-handling unload-service)
-                             to-unload)
-                        (map (call-with-shepherd-error-handling start-service)
-                             (map first to-start))))))))
+        (for-each unload-service '#$to-unload)
+        (for-each start-service '#$to-start)))))
 
 (define (install-bootloader-program installer-script bootcfg bootcfg-file target)
-  "Return as a monadic value a derivation to build a scheme file that, upon
-being evaluated, will install BOOTCFG to BOOTCFG-FILE, a target file name, on
-TARGET, a mount point, and subsequently run INSTALLER-SCRIPT, returning any
-textual output produced by the installer script as a string."
-  (gexp->script
+  "Return an executable store item that, upon being evaluated, will install
+BOOTCFG to BOOTCFG-FILE, a target file name, on TARGET, a mount point, and
+subsequently run INSTALLER-SCRIPT, returning any textual output produced by
+the installer script as a string."
+  (program-file
    "install-bootloader.scm"
    (with-extensions (list guile-gcrypt)
      (with-imported-modules (source-module-closure '((gnu build install)
@@ -152,19 +106,17 @@ textual output produced by the installer script as a string."
                         (guix utils))
            (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)
-
-             (let ((installer-result
-                    (false-if-exception
-                     (begin
-                       (install-boot-config #$bootcfg #$bootcfg-file #$target)
-                       (with-output-to-string
-                         (lambda ()
-                           (when #$installer-script
-                             (primitive-load #$installer-script))))))))
-               (unless installer-result
-                 (delete-file temp-gc-root)
-                 (error "failed to install bootloader"))
-               (rename-file temp-gc-root gc-root)
-               installer-result)))))))
+             (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-script
+               (catch #t
+                 (lambda ()
+                   (primitive-load #$installer-script))
+                 (lambda args
+                   (delete-file temp-gc-root)
+                   (apply throw args))))
+             (rename-file temp-gc-root gc-root)))))))
-- 
2.22.0


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

  reply	other threads:[~2019-07-16 23:49 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   ` [bug#36555] [PATCH 2/2] guix system: Reimplement 'reconfigure' Jakob L. Kreuze
2019-07-13 10:23   ` [bug#36555] [PATCH 1/2] guix system: Add 'reconfigure' module 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                   ` Jakob L. Kreuze [this message]
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=87muhdzgli.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).