aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-08-31 12:49:45 +0200
committerLudovic Courtès <ludo@gnu.org>2016-08-31 15:44:20 +0200
commitf20a7b869668b46a011d22e4c1dcb68f855a1c62 (patch)
tree4ff9bb0fc1a5f7c5340f131854bb7100a69d6ca5
parenta5d78eb64bcb87440a0b3ff25eec5568df0bc47c (diff)
downloadguix-f20a7b869668b46a011d22e4c1dcb68f855a1c62.tar
guix-f20a7b869668b46a011d22e4c1dcb68f855a1c62.tar.gz
guix system: Use 'shepherd-service-lookup-procedure' in 'service-upgrade'.
* guix/scripts/system.scm (service-upgrade)[essential?]: SERVICE is now a <live-service>. [lookup-target, lookup-live, running?, stopped, obsolete?]: New procedures. [to-load, to-unload]: Use them. TO-UNLOAD is now a list of <live-service>. (call-with-service-upgrade-info): Extract symbols from TO-UNLOAD. * tests/system.scm ("service-upgrade: one unchanged, one upgraded, one new"): Adjust accordingly.
-rw-r--r--guix/scripts/system.scm56
-rw-r--r--tests/system.scm5
2 files changed, 34 insertions, 27 deletions
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index a006b2d54e..80f62fb109 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -273,41 +273,45 @@ on service '~a':~%")
#t)))
(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."
+ "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 service '(root shepherd)))
+ (memq (first (live-service-provision service))
+ '(root shepherd)))
- (define new-service-names
- (map (compose first shepherd-service-provision)
- target))
+ (define lookup-target
+ (shepherd-service-lookup-procedure target
+ shepherd-service-provision))
- (define running
- (map (compose first live-service-provision)
- (filter live-service-running live)))
+ (define lookup-live
+ (shepherd-service-lookup-procedure live
+ live-service-provision))
- (define stopped
- (map (compose first live-service-provision)
- (remove live-service-running live)))
+ (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 (obsolete? service)
+ (match (lookup-target (first (live-service-provision service)))
+ (#f #t)
+ (_ #f)))
(define to-load
;; Only load services that are either new or currently stopped.
- (remove (lambda (service)
- (memq (first (shepherd-service-provision service))
- running))
- target))
+ (remove 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)))))
+ (append (filter obsolete? live)
+ (filter-map stopped to-load))))
(values to-unload to-load))
@@ -319,7 +323,9 @@ unload."
((services ...)
(let-values (((to-unload to-load)
(service-upgrade services new-services)))
- (mproc to-load to-unload)))
+ (mproc to-load
+ (map (compose first live-service-provision)
+ to-unload))))
(#f
(with-monad %store-monad
(warning (_ "failed to obtain list of shepherd services~%"))
diff --git a/tests/system.scm b/tests/system.scm
index dee6feda2c..eff997062f 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -129,7 +129,7 @@
list))
(test-equal "service-upgrade: one unchanged, one upgraded, one new"
- '((bar) ;unload
+ '(((bar)) ;unload
((bar) (baz))) ;load
(call-with-values
(lambda ()
@@ -146,6 +146,7 @@
(shepherd-service (provision '(baz))
(start #t)))))
(lambda (unload load)
- (list unload (map shepherd-service-provision load)))))
+ (list (map live-service-provision unload)
+ (map shepherd-service-provision load)))))
(test-end)