diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 55a8e475d4..a006b2d54e 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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 +) that needs to be unloaded, and the subset of TARGET (a list of +) 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 diff --git a/tests/system.scm b/tests/system.scm index b5bb9af016..dee6feda2c 100644 --- a/tests/system.scm +++ b/tests/system.scm @@ -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)