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
|
|
@ -25,6 +25,7 @@
|
||||||
#:use-module (guix records)
|
#:use-module (guix records)
|
||||||
#:use-module (guix derivations) ;imported-modules, etc.
|
#:use-module (guix derivations) ;imported-modules, etc.
|
||||||
#:use-module (gnu services)
|
#:use-module (gnu services)
|
||||||
|
#:use-module (gnu services herd)
|
||||||
#:use-module (gnu packages admin)
|
#:use-module (gnu packages admin)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 vlist)
|
#:use-module (ice-9 vlist)
|
||||||
|
|
@ -53,7 +54,8 @@
|
||||||
shepherd-service-file
|
shepherd-service-file
|
||||||
|
|
||||||
shepherd-service-lookup-procedure
|
shepherd-service-lookup-procedure
|
||||||
shepherd-service-back-edges))
|
shepherd-service-back-edges
|
||||||
|
shepherd-service-upgrade))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -293,4 +295,52 @@ symbols provided/required by a service."
|
||||||
(lambda (service)
|
(lambda (service)
|
||||||
(vhash-foldq* cons '() service edges)))
|
(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
|
;;; shepherd.scm ends here
|
||||||
|
|
|
||||||
|
|
@ -272,54 +272,6 @@ on service '~a':~%")
|
||||||
((not error) ;not an error
|
((not error) ;not an error
|
||||||
#t)))
|
#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)
|
(define (call-with-service-upgrade-info new-services mproc)
|
||||||
"Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of
|
"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
|
names of services to load (upgrade), and the list of names of services to
|
||||||
|
|
@ -327,7 +279,7 @@ unload."
|
||||||
(match (current-services)
|
(match (current-services)
|
||||||
((services ...)
|
((services ...)
|
||||||
(let-values (((to-unload to-load)
|
(let-values (((to-unload to-load)
|
||||||
(service-upgrade services new-services)))
|
(shepherd-service-upgrade services new-services)))
|
||||||
(mproc to-load
|
(mproc to-load
|
||||||
(map (compose first live-service-provision)
|
(map (compose first live-service-provision)
|
||||||
to-unload))))
|
to-unload))))
|
||||||
|
|
|
||||||
|
|
@ -18,12 +18,17 @@
|
||||||
|
|
||||||
(define-module (test-services)
|
(define-module (test-services)
|
||||||
#:use-module (gnu services)
|
#:use-module (gnu services)
|
||||||
|
#:use-module (gnu services herd)
|
||||||
#:use-module (gnu services shepherd)
|
#:use-module (gnu services shepherd)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-64))
|
#:use-module (srfi srfi-64))
|
||||||
|
|
||||||
|
(define live-service
|
||||||
|
(@@ (gnu services herd) live-service))
|
||||||
|
|
||||||
|
|
||||||
(test-begin "services")
|
(test-begin "services")
|
||||||
|
|
||||||
(test-assert "service-back-edges"
|
(test-assert "service-back-edges"
|
||||||
|
|
@ -127,4 +132,67 @@
|
||||||
(lset= eq? (e s2) (list s3))
|
(lset= eq? (e s2) (list s3))
|
||||||
(null? (e 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)
|
(test-end)
|
||||||
|
|
|
||||||
|
|
@ -19,8 +19,6 @@
|
||||||
(define-module (test-system)
|
(define-module (test-system)
|
||||||
#:use-module (gnu)
|
#:use-module (gnu)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (gnu services herd)
|
|
||||||
#:use-module (gnu services shepherd)
|
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-64))
|
#:use-module (srfi srfi-64))
|
||||||
|
|
||||||
|
|
@ -61,12 +59,7 @@
|
||||||
%base-file-systems))
|
%base-file-systems))
|
||||||
(users %base-user-accounts)))
|
(users %base-user-accounts)))
|
||||||
|
|
||||||
(define live-service
|
|
||||||
(@@ (gnu services herd) live-service))
|
|
||||||
|
|
||||||
(define service-upgrade
|
|
||||||
(@@ (guix scripts system) service-upgrade))
|
|
||||||
|
|
||||||
(test-begin "system")
|
(test-begin "system")
|
||||||
|
|
||||||
(test-assert "operating-system-store-file-system"
|
(test-assert "operating-system-store-file-system"
|
||||||
|
|
@ -121,64 +114,4 @@
|
||||||
(type "ext4"))
|
(type "ext4"))
|
||||||
%base-file-systems)))))
|
%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)
|
(test-end)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue