TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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.
This commit is contained in:
Ludovic Courtès 2016-08-30 22:40:24 +02:00
parent 183605c853
commit b8692e4696
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 73 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
guix/scripts/system.scm
View File

@ -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

34
tests/system.scm
View File

@ -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)