summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/services/herd.scm37
-rw-r--r--gnu/tests/base.scm12
-rw-r--r--guix/scripts/system.scm51
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