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.
This commit is contained in:
Ludovic Courtès
parent
d4f8884fdb
commit
7b44cae50a
4 changed files with 121 additions and 118 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Reference in a new issue