M gnu/services/shepherd.scm => gnu/services/shepherd.scm +51 -1
@@ 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
M guix/scripts/system.scm => guix/scripts/system.scm +1 -49
@@ 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))))
M tests/services.scm => tests/services.scm +68 -0
@@ 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)
M tests/system.scm => tests/system.scm +1 -68
@@ 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)