03/08: guix system: Extract and test the service upgrade procedure.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit b8692e4696d0d2b36466827da1e0d25d69a298af
Author: Ludovic Courtès <address@hidden>
Date:   Tue Aug 30 22:40:24 2016 +0200

    guix system: Extract and test the service upgrade procedure.
    
    * guix/scripts/system.scm (service-upgrade): New procedure, with code
    from...
    (call-with-service-upgrade-info): ... here.  Use it.
    * tests/system.scm (live-service, service-upgrade): New variables.
    ("service-upgrade: nothing to do", "service-upgrade: one unchanged, one
    upgraded, one new"): New tests.
---
 guix/scripts/system.scm |   65 ++++++++++++++++++++++++++++-------------------
 tests/system.scm        |   34 +++++++++++++++++++++++++
 2 files changed, 73 insertions(+), 26 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 55a8e47..a006b2d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -272,40 +272,53 @@ on service '~a':~%")
         ((not error)                              ;not an error
          #t)))
 
-(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
-unload."
+(define (service-upgrade live target)
+  "Return two values: the names of 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 service '(root shepherd)))
 
   (define new-service-names
     (map (compose first shepherd-service-provision)
-         new-services))
+         target))
+
+  (define running
+    (map (compose first live-service-provision)
+         (filter live-service-running live)))
+
+  (define stopped
+    (map (compose first live-service-provision)
+         (remove live-service-running live)))
+
+  (define to-load
+    ;; Only load services that are either new or currently stopped.
+    (remove (lambda (service)
+              (memq (first (shepherd-service-provision service))
+                    running))
+            target))
+
+  (define to-unload
+    ;; Unload services that are (1) no longer required, or (2) are in TO-LOAD.
+    (remove essential?
+            (append (remove (lambda (service)
+                              (memq service new-service-names))
+                            (append running stopped))
+                    (filter (lambda (service)
+                              (memq service stopped))
+                            (map shepherd-service-canonical-name
+                                 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
+unload."
   (match (current-services)
     ((services ...)
-     (let* ((running (map (compose first live-service-provision)
-                          (filter live-service-running services)))
-            (stopped (map (compose first live-service-provision)
-                          (remove live-service-running services)))
-            (to-load
-             ;; Only load services that are either new or currently stopped.
-             (remove (lambda (service)
-                       (memq (first (shepherd-service-provision service))
-                             running))
-                     new-services))
-            (to-unload
-             ;; Unload services that are (1) no longer required, or (2) are
-             ;; in TO-LOAD.
-             (remove essential?
-                     (append (remove (lambda (service)
-                                       (memq service new-service-names))
-                                     (append running stopped))
-                             (filter (lambda (service)
-                                       (memq service stopped))
-                                     (map shepherd-service-canonical-name
-                                          to-load))))))
+     (let-values (((to-unload to-load)
+                   (service-upgrade services new-services)))
        (mproc to-load to-unload)))
     (#f
      (with-monad %store-monad
diff --git a/tests/system.scm b/tests/system.scm
index b5bb9af..dee6fed 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -19,6 +19,8 @@
 (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))
 
@@ -59,6 +61,11 @@
                         %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")
 
@@ -114,4 +121,31 @@
                            (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 unload (map shepherd-service-provision load)))))
+
 (test-end)