[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/08: guix system: Extract and test the service upgrade procedure.
From: |
Ludovic Courtès |
Subject: |
03/08: guix system: Extract and test the service upgrade procedure. |
Date: |
Wed, 31 Aug 2016 14:14:00 +0000 (UTC) |
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)
- branch master updated (c180533 -> 7b44cae), Ludovic Courtès, 2016/08/31
- 04/08: services: shepherd: Add 'shepherd-service-lookup-procedure'., Ludovic Courtès, 2016/08/31
- 06/08: services: shepherd: Parameterize 'shepherd-service-back-edges'., Ludovic Courtès, 2016/08/31
- 01/08: doc: Fix 'ntp-service' typo., Ludovic Courtès, 2016/08/31
- 08/08: services: shepherd: Add 'shepherd-service-upgrade', from 'guix system'., Ludovic Courtès, 2016/08/31
- 07/08: guix system: Do not unload services depended on., Ludovic Courtès, 2016/08/31
- 02/08: services: herd: Provide <live-service> objects., Ludovic Courtès, 2016/08/31
- 03/08: guix system: Extract and test the service upgrade procedure.,
Ludovic Courtès <=
- 05/08: guix system: Use 'shepherd-service-lookup-procedure' in 'service-upgrade'., Ludovic Courtès, 2016/08/31