diff options
| -rw-r--r-- | gnu/services/shepherd.scm | 52 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 50 | ||||
| -rw-r--r-- | tests/services.scm | 68 | ||||
| -rw-r--r-- | tests/system.scm | 69 |
4 files changed, 121 insertions, 118 deletions
diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 426b0e7290..3273184b9a 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -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 diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bcf19dbb7e..953c6243ed 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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)))) diff --git a/tests/services.scm b/tests/services.scm index 12745c8006..8993c3dafc 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -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) diff --git a/tests/system.scm b/tests/system.scm index 9c1a13dd9b..ca34409be9 100644 --- a/tests/system.scm +++ b/tests/system.scm @@ -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) |