08/08: services: shepherd: Add 'shepherd-service-upgrade', from 'guix system'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 7b44cae50aed1d6d67337e9eae9f449ccd00a870
Author: Ludovic Courtès <address@hidden>
Date:   Wed Aug 31 15:40:00 2016 +0200

    services: shepherd: Add 'shepherd-service-upgrade', from 'guix system'.
    
    * guix/scripts/system.scm (service-upgrade): Move to...
    * gnu/services/shepherd.scm (shepherd-service-upgrade): ... here.
    * tests/system.scm ("service-upgrade: nothing to do", "service-upgrade:
    one unchanged, one upgraded, one new", "service-upgrade: service
    depended on is not unloaded", "service-upgrade: obsolete services that
    depend on each other"): Move to...
    * tests/services.scm: ... here.  Adjust to 'service-upgrade' rename.
---
 gnu/services/shepherd.scm |   52 +++++++++++++++++++++++++++++++++-
 guix/scripts/system.scm   |   50 +-------------------------------
 tests/services.scm        |   68 ++++++++++++++++++++++++++++++++++++++++++++
 tests/system.scm          |   69 +--------------------------------------------
 4 files changed, 121 insertions(+), 118 deletions(-)

diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm
index 426b0e7..3273184 100644
--- a/gnu/services/shepherd.scm
+++ b/gnu/services/shepherd.scm
@@ -25,6 +25,7 @@
   #:use-module (guix records)
   #:use-module (guix derivations)                 ;imported-modules, etc.
   #:use-module (gnu services)
+  #:use-module (gnu services herd)
   #:use-module (gnu packages admin)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
@@ -53,7 +54,8 @@
             shepherd-service-file
 
             shepherd-service-lookup-procedure
-            shepherd-service-back-edges))
+            shepherd-service-back-edges
+            shepherd-service-upgrade))
 
 ;;; Commentary:
 ;;;
@@ -293,4 +295,52 @@ symbols provided/required by a service."
   (lambda (service)
     (vhash-foldq* cons '() service edges)))
 
+(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."
+  (define (essential? service)
+    (memq (first (live-service-provision service))
+          '(root shepherd)))
+
+  (define lookup-target
+    (shepherd-service-lookup-procedure target
+                                       shepherd-service-provision))
+
+  (define lookup-live
+    (shepherd-service-lookup-procedure live
+                                       live-service-provision))
+
+  (define (running? service)
+    (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
+                                 #:requirement live-service-requirement))
+
+  (define (obsolete? service)
+    (match (lookup-target (first (live-service-provision service)))
+      (#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-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))))
+
+  (values to-unload to-load))
+
 ;;; shepherd.scm ends here
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index bcf19db..953c624 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -272,54 +272,6 @@ on service '~a':~%")
         ((not error)                              ;not an error
          #t)))
 
-(define (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."
-  (define (essential? service)
-    (memq (first (live-service-provision service))
-          '(root shepherd)))
-
-  (define lookup-target
-    (shepherd-service-lookup-procedure target
-                                       shepherd-service-provision))
-
-  (define lookup-live
-    (shepherd-service-lookup-procedure live
-                                       live-service-provision))
-
-  (define (running? service)
-    (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
-                                 #:requirement live-service-requirement))
-
-  (define (obsolete? service)
-    (match (lookup-target (first (live-service-provision service)))
-      (#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-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))))
-
-  (values to-unload to-load))
-
 (define (call-with-service-upgrade-info new-services mproc)
   "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of
 names of services to load (upgrade), and the list of names of services to
@@ -327,7 +279,7 @@ unload."
   (match (current-services)
     ((services ...)
      (let-values (((to-unload to-load)
-                   (service-upgrade services new-services)))
+                   (shepherd-service-upgrade services new-services)))
        (mproc to-load
               (map (compose first live-service-provision)
                    to-unload))))
diff --git a/tests/services.scm b/tests/services.scm
index 12745c8..8993c3d 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -18,12 +18,17 @@
 
 (define-module (test-services)
   #:use-module (gnu services)
+  #:use-module (gnu services herd)
   #:use-module (gnu services shepherd)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64))
 
+(define live-service
+  (@@ (gnu services herd) live-service))
+
+
 (test-begin "services")
 
 (test-assert "service-back-edges"
@@ -127,4 +132,67 @@
          (lset= eq? (e s2) (list s3))
          (null? (e s3)))))
 
+(test-equal "shepherd-service-upgrade: nothing to do"
+  '(() ())
+  (call-with-values
+      (lambda ()
+        (shepherd-service-upgrade '() '()))
+    list))
+
+(test-equal "shepherd-service-upgrade: one unchanged, one upgraded, one new"
+  '(((bar))                                       ;unload
+    ((bar) (baz)))                                ;load
+  (call-with-values
+      (lambda ()
+        ;; Here 'foo' is not upgraded because it is still running, whereas
+        ;; 'bar' is upgraded because it is not currently running.  'baz' is
+        ;; loaded because it's a new service.
+        (shepherd-service-upgrade
+         (list (live-service '(foo) '() #t)
+               (live-service '(bar) '() #f)
+               (live-service '(root) '() #t))     ;essential!
+         (list (shepherd-service (provision '(foo))
+                                 (start #t))
+               (shepherd-service (provision '(bar))
+                                 (start #t))
+               (shepherd-service (provision '(baz))
+                                 (start #t)))))
+    (lambda (unload load)
+      (list (map live-service-provision unload)
+            (map shepherd-service-provision load)))))
+
+(test-equal "shepherd-service-upgrade: service depended on is not unloaded"
+  '(((baz))                                       ;unload
+    ())                                           ;load
+  (call-with-values
+      (lambda ()
+        ;; Service 'bar' is not among the target services; yet, it must not be
+        ;; unloaded because 'foo' depends on it.
+        (shepherd-service-upgrade
+         (list (live-service '(foo) '(bar) #t)
+               (live-service '(bar) '() #t)       ;still used!
+               (live-service '(baz) '() #t))
+         (list (shepherd-service (provision '(foo))
+                                 (start #t)))))
+    (lambda (unload load)
+      (list (map live-service-provision unload)
+            (map shepherd-service-provision load)))))
+
+(test-equal "shepherd-service-upgrade: obsolete services that depend on each 
other"
+  '(((foo) (bar) (baz))                           ;unload
+    ((qux)))                                      ;load
+  (call-with-values
+      (lambda ()
+        ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are
+        ;; obsolete, and thus should be unloaded.
+        (shepherd-service-upgrade
+         (list (live-service '(foo) '(bar) #t)    ;obsolete
+               (live-service '(bar) '(baz) #t)    ;obsolete
+               (live-service '(baz) '() #t))      ;obsolete
+         (list (shepherd-service (provision '(qux))
+                                 (start #t)))))
+    (lambda (unload load)
+      (list (map live-service-provision unload)
+            (map shepherd-service-provision load)))))
+
 (test-end)
diff --git a/tests/system.scm b/tests/system.scm
index 9c1a13d..ca34409 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -19,8 +19,6 @@
 (define-module (test-system)
   #:use-module (gnu)
   #:use-module (guix store)
-  #:use-module (gnu services herd)
-  #:use-module (gnu services shepherd)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64))
 
@@ -61,12 +59,7 @@
                         %base-file-systems))
     (users %base-user-accounts)))
 
-(define live-service
-  (@@ (gnu services herd) live-service))
-
-(define service-upgrade
-  (@@ (guix scripts system) service-upgrade))
-
+
 (test-begin "system")
 
 (test-assert "operating-system-store-file-system"
@@ -121,64 +114,4 @@
                            (type "ext4"))
                          %base-file-systems)))))
 
-(test-equal "service-upgrade: nothing to do"
-  '(() ())
-  (call-with-values
-      (lambda ()
-        (service-upgrade '() '()))
-    list))
-
-(test-equal "service-upgrade: one unchanged, one upgraded, one new"
-  '(((bar))                                       ;unload
-    ((bar) (baz)))                                ;load
-  (call-with-values
-      (lambda ()
-        ;; Here 'foo' is not upgraded because it is still running, whereas
-        ;; 'bar' is upgraded because it is not currently running.  'baz' is
-        ;; loaded because it's a new service.
-        (service-upgrade (list (live-service '(foo) '() #t)
-                               (live-service '(bar) '() #f)
-                               (live-service '(root) '() #t)) ;essential!
-                         (list (shepherd-service (provision '(foo))
-                                                 (start #t))
-                               (shepherd-service (provision '(bar))
-                                                 (start #t))
-                               (shepherd-service (provision '(baz))
-                                                 (start #t)))))
-    (lambda (unload load)
-      (list (map live-service-provision unload)
-            (map shepherd-service-provision load)))))
-
-(test-equal "service-upgrade: service depended on is not unloaded"
-  '(((baz))                                       ;unload
-    ())                                           ;load
-  (call-with-values
-      (lambda ()
-        ;; Service 'bar' is not among the target services; yet, it must not be
-        ;; unloaded because 'foo' depends on it.
-        (service-upgrade (list (live-service '(foo) '(bar) #t)
-                               (live-service '(bar) '() #t) ;still used!
-                               (live-service '(baz) '() #t))
-                         (list (shepherd-service (provision '(foo))
-                                                 (start #t)))))
-    (lambda (unload load)
-      (list (map live-service-provision unload)
-            (map shepherd-service-provision load)))))
-
-(test-equal "service-upgrade: obsolete services that depend on each other"
-  '(((foo) (bar) (baz))                           ;unload
-    ((qux)))                                      ;load
-  (call-with-values
-      (lambda ()
-        ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are
-        ;; obsolete, and thus should be unloaded.
-        (service-upgrade (list (live-service '(foo) '(bar) #t) ;obsolete
-                               (live-service '(bar) '(baz) #t) ;obsolete
-                               (live-service '(baz) '() #t))   ;obsolete
-                         (list (shepherd-service (provision '(qux))
-                                                 (start #t)))))
-    (lambda (unload load)
-      (list (map live-service-provision unload)
-            (map shepherd-service-provision load)))))
-
 (test-end)