diff options
| -rw-r--r-- | gnu/services/herd.scm | 37 | ||||
| -rw-r--r-- | gnu/tests/base.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 51 |
3 files changed, 57 insertions, 43 deletions
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 7a9db90012..03bfbf1d78 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -17,8 +17,8 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu services herd) - #:use-module (guix combinators) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -37,6 +37,11 @@ unknown-shepherd-error? unknown-shepherd-error-sexp + live-service? + live-service-provision + live-service-requirement + live-service-running + current-services unload-services unload-service @@ -165,25 +170,27 @@ of pairs." (let ((key (and=> (assoc-ref alist 'key) car)) ...) exp ...)))) +;; Information about live Shepherd services. +(define-record-type <live-service> + (live-service provision requirement running) + live-service? + (provision live-service-provision) ;list of symbols + (requirement live-service-requirement) ;list of symbols + (running live-service-running)) ;#f | object + (define (current-services) - "Return two lists: the list of currently running services, and the list of -currently stopped services. Return #f and #f if the list of services could -not be obtained." + "Return the list of currently defined Shepherd services, represented as +<live-service> objects. Return #f if the list of services could not be +obtained." (with-shepherd-action 'root ('status) services (match services ((('service ('version 0 _ ...) _ ...) ...) - (fold2 (lambda (service running-services stopped-services) - (alist-let* service (provides running) - (if running - (values (cons (first provides) running-services) - stopped-services) - (values running-services - (cons (first provides) stopped-services))))) - '() - '() - services)) + (map (lambda (service) + (alist-let* service (provides requires running) + (live-service provides requires running))) + services)) (x - (values #f #f))))) + #f)))) (define (unload-service service) "Unload SERVICE, a symbol name; return #t on success." diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index ca6f76c0f8..41f50c0e7a 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -122,11 +122,13 @@ info --version") (operating-system-user-accounts os)))))) (test-assert "shepherd services" - (let ((services (marionette-eval '(begin - (use-modules (gnu services herd)) - (call-with-values current-services - append)) - marionette))) + (let ((services (marionette-eval + '(begin + (use-modules (gnu services herd)) + + (map (compose car live-service-provision) + (current-services))) + marionette))) (lset= eq? (pk 'services services) '(root #$@(operating-system-shepherd-service-names os))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index a9fe7d5975..55a8e475d4 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -283,29 +283,34 @@ unload." (map (compose first shepherd-service-provision) new-services)) - (let-values (((running stopped) (current-services))) - (if (and running stopped) - (let* ((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)))))) - (mproc to-load to-unload)) - (with-monad %store-monad - (warning (_ "failed to obtain list of shepherd services~%")) - (return #f))))) + (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)))))) + (mproc to-load to-unload))) + (#f + (with-monad %store-monad + (warning (_ "failed to obtain list of shepherd services~%")) + (return #f))))) (define (upgrade-shepherd-services os) "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new |