[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[bug#32408] [PATCH shepherd] Allow replacement of services

From: Carlo Zancanaro
Subject: [bug#32408] [PATCH shepherd] Allow replacement of services
Date: Thu, 23 Aug 2018 23:45:05 +1000
User-agent: mu4e 1.0; emacs 26.1

Hey Ludo’,

I've attached an updated patch. I couldn't think of any unwanted consequences, so I took your idea of making register-services handle most of the details of replacement. With my patch, something like
herd eval root '(register-services (load "a.scm") (load "b.scm"))'
will deal with a conflict by either replacing the old service (if it's not running), arranging for the old service to be replaced when it's stopped, or raising an error. This seems like a sensible way for things to function.

At the very least we need to control the inherent race condition [...]


Despite my desire to deal with the race condition, I haven't done anything about it in this patch. The modification of %services that was done in register-services was already racy, and I don't think this patch will make it worse. If it hasn't been a problem up until now, then I don't think this will make it a problem.


From 9ec5c0000e9a45441417a6ee4138cdcbf1b1f2b2 Mon Sep 17 00:00:00 2001
From: Carlo Zancanaro <address@hidden>
Date: Thu, 9 Aug 2018 22:30:38 +1000
Subject: [PATCH] service: Add a replacement slot for delayed service

* modules/shepherd/service.scm (<service>): Add replacement slot
(replace-service): New procedure.
(stop): Call replace-service after stopping a service.
(register-services): Replace existing services where possible, setting the new
replacement slot if they are currently running.
* tests/ Add a test for it.
* (TESTS): Add the new test.
* doc/shepherd.texi (Slots of services): Document it.
---                  |   1 +
 doc/shepherd.texi            |   9 +++
 modules/shepherd/service.scm |  68 ++++++++++++++++++-----
 tests/         | 105 +++++++++++++++++++++++++++++++++++
 4 files changed, 168 insertions(+), 15 deletions(-)
 create mode 100644 tests/

diff --git a/ b/
index 8dad006..4322d7f 100644
--- a/
+++ b/
@@ -184,6 +184,7 @@ SUFFIXES = .go
 TESTS =                                                \
   tests/                               \
+  tests/                         \
   tests/                             \
   tests/                  \
   tests/                   \
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 7946f8b..1de6d80 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -708,6 +708,15 @@ handler will not start it again.
 otherwise @code{#f}.
address@hidden replacement (slot of <service>)
address@hidden specifies a service to be used to replace this one
+when it is stopped.  This service will continue to function normally
+until the @code{stop} action is invoked.  After the service has been
+successfully stopped, its definition will be replaced by the value of
+this slot, which must itself be a service.  This slot is ignored if
+its value is @code{#f}.
 @end itemize
 @c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 5653388..006309c 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -205,7 +205,10 @@ respawned, shows that it has been respawned more than 
   (stop-delay? #:init-keyword #:stop-delay?
               #:init-value #f)
   ;; The times of the last respawns, most recent first.
-  (last-respawns #:init-form '()))
+  (last-respawns #:init-form '())
+  ;; A replacement for when this service is stopped.
+  (replacement #:init-keyword #:replacement
+               #:init-value #f))
 (define (service? obj)
   "Return true if OBJ is a service."
@@ -341,6 +344,20 @@ wire."
                         (canonical-name obj)))))
   (slot-ref obj 'running))
+(define (replace-service old-service new-service)
+  "Replace OLD-SERVICE with NEW-SERVICE in the services registry.  This
+completely removes all references to OLD-SERVICE before registering
+  (define (remove-service name)
+    (let* ((old (hashq-ref %services name))
+           (new (delete old-service old)))
+      (if (null? new)
+          (hashq-remove! %services name)
+          (hashq-set! %services name new))))
+  (when new-service
+    (for-each remove-service (provided-by old-service))
+    (register-services new-service)))
 ;; Stop the service, including services that depend on it.  If the
 ;; latter fails, continue anyway.  Return `#f' if it could be stopped.
 (define-method (stop (obj <service>) . args)
@@ -385,6 +402,11 @@ wire."
                ;; Reset the list of respawns.
                (slot-set! obj 'last-respawns '())
+               ;; Replace the service with its replacement, if it has one
+               (let ((replacement (slot-ref obj 'replacement)))
+                 (when replacement
+                   (replace-service obj replacement)))
                ;; Status message.
                (let ((name (canonical-name obj)))
                  (if (running? obj)
@@ -1038,25 +1060,41 @@ then disable it."
 ;; Add NEW-SERVICES to the list of known services.
 (define (register-services . new-services)
+  "Add NEW-SERVICES to the list of known services.  If a service has already
+been registered, arrange to have it replaced when it is next stopped.  If it
+is currently stopped, replace it immediately."
   (define (register-single-service new)
     ;; Sanity-checks first.
     (assert (list-of-symbols? (provided-by new)))
     (assert (list-of-symbols? (required-by new)))
     (assert (boolean? (respawn? new)))
-    ;; Canonical name actually must be canonical.  (FIXME: This test
-    ;; is incomplete, since we may add a service later that makes it
-    ;; non-cannonical.)
-    (assert (null? (lookup-services (canonical-name new))))
-    ;; FIXME: Verify consistency: Check that there are no circular
-    ;; dependencies, check for bogus conflicts/dependencies, whatever
-    ;; else makes sense.
-    ;; Insert into the hash table.
-    (for-each (lambda (name)
-               (let ((old (lookup-services name)))
-                 ;; Actually add the new service now.
-                 (hashq-set! %services name (cons new old))))
-             (provided-by new)))
+    ;; FIXME: Just because we have a unique canonical name now doesn't mean it
+    ;; will remain unique as other services are added. Whenever a service is
+    ;; added it should check that it's not conflicting with any already
+    ;; registered canonical names.
+    (match (lookup-services (canonical-name new))
+      (() ;; empty, so we can safely add ourselves
+       (for-each (lambda (name)
+                  (let ((old (lookup-services name)))
+                    (hashq-set! %services name (cons new old))))
+                (provided-by new)))
+      ((old) ;; one service registered, so it may be an old version of us
+       (cond
+        ((not (eq? (canonical-name new) (canonical-name old)))
+         (local-output
+          "Cannot register service ~a: canonical name is not unique."
+          (canonical-name new))
+         (throw 'non-canonical-name))
+        ((running? old)
+         (slot-set! old 'replacement new))
+        (#:else
+         (replace-service old new))))
+      (_ ;; in any other case, there are too many services to register
+       (local-output
+        "Cannot register service ~a: canonical name is not unique."
+        (canonical-name new))
+       (throw 'non-canonical-name))))
   (for-each register-single-service new-services))
diff --git a/tests/ b/tests/
new file mode 100644
index 0000000..e06cb93
--- /dev/null
+++ b/tests/
@@ -0,0 +1,105 @@
+# GNU Shepherd --- Ensure replacing services works properly
+# Copyright © 2014, 2016 Ludovic Courtès <address@hidden>
+# Copyright © 2018 Carlo Zancanaro <address@hidden>
+# This file is part of the GNU Shepherd.
+# The GNU Shepherd is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or (at
+# your option) any later version.
+# The GNU Shepherd is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# GNU General Public License for more details.
+# You should have received a copy of the GNU General Public License
+# along with the GNU Shepherd.  If not, see <>.
+shepherd --version
+herd --version
+herd="herd -s $socket"
+trap "rm -f $socket $conf $rconf $stamp $log;
+      test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
+cat > "$conf"<<EOF
+(use-modules (srfi srfi-26))
+ (make <service>
+   #:provides '(test)
+   #:start (const #t)
+   #:actions (make-actions
+              (say-hello (lambda _
+                          (call-with-output-file "$stamp"
+                           (lambda (port)
+                            (display "Hello" port))))))
+   #:respawn? #f))
+rm -f "$pid" "$stamp" "$socket"
+shepherd -I -s "$socket" -c "$conf" --pid="$pid" --log="$log" &
+while ! test -f "$pid"; do sleep 0.5 ; done
+$herd start test
+if ! $herd say-hello test; then
+    echo "say-hello failed"
+    exit 1
+cat > "$rconf"<<EOF
+ (make <service>
+   #:provides '(test)
+   #:start (const #t)
+   #:actions (make-actions
+              (say-goodbye (lambda _
+                             (call-with-output-file "$stamp"
+                              (lambda (port)
+                                (display "Goodbye" port))))))
+   #:respawn? #f))
+$herd load root "$rconf"
+if ! $herd say-hello test; then
+    echo "say-hello failed after setting replacement"
+    exit 1
+if test "`cat $stamp`" != "Hello"; then
+    echo "Output file had the wrong contents! Was:"
+    cat $stamp
+    exit 1
+$herd stop test
+$herd start test
+if $herd say-hello test; then
+    echo "say-hello should have failed after stop/start"
+    exit 1
+if ! $herd say-goodbye test; then
+    echo "say-goodbye failed after replacement"
+    exit 1
+if test "`cat $stamp`" != "Goodbye"; then
+    echo "Output file had the wrong contents! Was:"
+    cat $stamp
+    exit 1

Attachment: signature.asc
Description: PGP signature

reply via email to

[Prev in Thread] Current Thread [Next in Thread]