02/08: guix system: Load all services on reconfigure, not just stopped ones.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 4245ddcbc9f935804c17c97872b90ec1050c2d75
Author: Carlo Zancanaro <address@hidden>
Date:   Sun Aug 26 21:54:14 2018 +1000

    guix system: Load all services on reconfigure, not just stopped ones.
    
    This uses the 'replacement' service slot introduced in the Shepherd
    version 0.5.0.
    
    * gnu/services/shepherd.scm (shepherd-service-upgrade): Return a list of
      services that need to be restarted to complete their upgrade.
    * guix/scripts/system.scm (call-with-service-upgrade-info): Rename an 
internal
      variable to reflect the change to shepherd-service-upgrade.
      (upgrade-shepherd-services): Call 'load-services/safe' instead of
      'load-services'.  Print a message about services that need to be
      manually restarted.
    * gnu/services/herd.scm (load-services/safe): New procedure.
    * doc/guix.texi (Invoking guix system): Document the new behaviour.
    
    Co-authored-by: Ludovic Courtès <address@hidden>
---
 doc/guix.texi             |  8 ++++----
 gnu/services/herd.scm     | 20 ++++++++++++++++++++
 gnu/services/shepherd.scm | 23 ++++++++---------------
 guix/scripts/system.scm   | 25 ++++++++++++++++---------
 4 files changed, 48 insertions(+), 28 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 6b4b06f..e1046eb 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -33,7 +33,7 @@ Copyright @copyright{} 2016 Alex ter address@hidden
 Copyright @copyright{} 2017, 2018 Clément address@hidden
 Copyright @copyright{} 2017 Mathieu address@hidden
 Copyright @copyright{} 2017 Federico address@hidden
-Copyright @copyright{} 2017 Carlo address@hidden
+Copyright @copyright{} 2017, 2018 Carlo address@hidden
 Copyright @copyright{} 2017 Thomas address@hidden
 Copyright @copyright{} 2017 address@hidden
 Copyright @copyright{} 2017 Christopher Allan address@hidden
@@ -21920,9 +21920,9 @@ systems already running GuixSD.}.
 This effects all the configuration specified in @var{file}: user
 accounts, system services, global package list, setuid programs, etc.
 The command starts system services specified in @var{file} that are not
-currently running; if a service is currently running, it does not
-attempt to upgrade it since this would not be possible without stopping it
-first.
+currently running; if a service is currently running this command will
+arrange for it to be upgraded the next time it is stopped (eg. by
address@hidden stop X} or @code{herd restart X}).
 
 This command creates a new generation whose number is one greater than
 the current generation (as reported by @command{guix system
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 8c96b70..8ff8177 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -50,6 +50,7 @@
             unload-services
             unload-service
             load-services
+            load-services/safe
             start-service
             stop-service))
 
@@ -232,6 +233,25 @@ returns a shepherd <service> object."
                          `(primitive-load ,file))
                        files))))
 
+(define (load-services/safe files)
+  "This is like 'load-services', but make sure only the subset of FILES that
+can be safely reloaded is actually reloaded.
+
+This is done to accommodate the Shepherd < 0.15.0 where services lacked the
+'replacement' slot, and where 'register-services' would throw an exception
+when passed a service with an already-registered name."
+  (eval-there `(let* ((services     (map primitive-load ',files))
+                      (slots        (map slot-definition-name
+                                         (class-slots <service>)))
+                      (can-replace? (memq 'replacement slots)))
+                 (define (registered? service)
+                   (not (null? (lookup-services (canonical-name service)))))
+
+                 (apply register-services
+                        (if can-replace?
+                            services
+                            (remove registered? services))))))
+
 (define (start-service name)
   (with-shepherd-action name ('start) result
     result))
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 4cd2249..4c7e720 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2018 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2017 Clément Lassieur <address@hidden>
+;;; Copyright © 2018 Carlo Zancanaro <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -329,7 +330,7 @@ symbols provided/required by a service."
 (define (shepherd-service-upgrade live target)
   "Return two values: the subset of LIVE (a list of <live-service>) that needs
 to be unloaded, and the subset of TARGET (a list of <shepherd-service>) that
-needs to be loaded."
+need to be restarted to complete their upgrade."
   (define (essential? service)
     (memq (first (live-service-provision service))
           '(root shepherd)))
@@ -346,12 +347,6 @@ needs to be loaded."
     (and=> (lookup-live (shepherd-service-canonical-name service))
            live-service-running))
 
-  (define (stopped service)
-    (match (lookup-live (shepherd-service-canonical-name service))
-      (#f #f)
-      (service (and (not (live-service-running service))
-                    service))))
-
   (define live-service-dependents
     (shepherd-service-back-edges live
                                  #:provision live-service-provision
@@ -362,16 +357,14 @@ needs to be loaded."
       (#f (every obsolete? (live-service-dependents service)))
       (_  #f)))
 
-  (define to-load
-    ;; Only load services that are either new or currently stopped.
-    (remove running? target))
+  (define to-restart
+    ;; Restart services that are currently running.
+    (filter running? target))
 
   (define to-unload
-    ;; Unload services that are (1) no longer required, or (2) are in TO-LOAD.
-    (remove essential?
-            (append (filter obsolete? live)
-                    (filter-map stopped to-load))))
+    ;; Unload services that are no longer required.
+    (remove essential? (filter obsolete? live)))
 
-  (values to-unload to-load))
+  (values to-unload to-restart))
 
 ;;; shepherd.scm ends here
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 69bd05b..1e7620f 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -310,9 +310,9 @@ names of services to load (upgrade), and the list of names 
of services to
 unload."
   (match (current-services)
     ((services ...)
-     (let-values (((to-unload to-load)
+     (let-values (((to-unload to-restart)
                    (shepherd-service-upgrade services new-services)))
-       (mproc to-load
+       (mproc to-restart
               (map (compose first live-service-provision)
                    to-unload))))
     (#f
@@ -335,25 +335,32 @@ bring the system down."
   ;; Arrange to simply emit a warning if the service upgrade fails.
   (with-shepherd-error-handling
    (call-with-service-upgrade-info new-services
-     (lambda (to-load to-unload)
+     (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? to-load)
-            (let ((to-load-names  (map shepherd-service-canonical-name 
to-load))
-                  (to-start       (filter shepherd-service-auto-start? 
to-load)))
-              (info (G_ "loading new services:~{ ~a~}...~%") to-load-names)
+          (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)
-                                               to-load)))
+                                               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 (map derivation->output-path files))
+                (load-services/safe (map derivation->output-path files))
 
                 (for-each start-service
                           (map shepherd-service-canonical-name to-start))