[shepherd] 01/01: service: Add a replacement slot for delayed service replacement.

[Carlo Zancanaro]

czan pushed a commit to branch master
in repository shepherd.

commit 9ec5c0000e9a45441417a6ee4138cdcbf1b1f2b2
Author: Carlo Zancanaro <address@hidden>
Date:   Thu Aug 9 22:30:38 2018 +1000

    service: Add a replacement slot for delayed service replacement.
    
    * 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/replacement.sh: Add a test for it.
    * Makefile.am (TESTS): Add the new test.
    * doc/shepherd.texi (Slots of services): Document it.
---
 Makefile.am                  |   1 +
 doc/shepherd.texi            |   9 ++++
 modules/shepherd/service.scm |  68 +++++++++++++++++++++-------
 tests/replacement.sh         | 105 +++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 168 insertions(+), 15 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 8dad006..4322d7f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -184,6 +184,7 @@ SUFFIXES = .go
 
 TESTS =                                                \
   tests/basic.sh                               \
+  tests/replacement.sh                         \
   tests/respawn.sh                             \
   tests/respawn-throttling.sh                  \
   tests/misbehaved-client.sh                   \
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
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 
TIMES in SECONDS."
   (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
+NEW-SERVICE."
+  (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/replacement.sh b/tests/replacement.sh
new file mode 100644
index 0000000..e06cb93
--- /dev/null
+++ b/tests/replacement.sh
@@ -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
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# 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 <http://www.gnu.org/licenses/>.
+
+shepherd --version
+herd --version
+
+socket="t-socket-$$"
+conf="t-conf-$$"
+rconf="t-rconf-$$"
+log="t-log-$$"
+stamp="t-stamp-$$"
+pid="t-pid-$$"
+
+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))
+(register-services
+ (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))
+EOF
+
+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
+fi
+
+cat > "$rconf"<<EOF
+(register-services
+ (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))
+EOF
+
+$herd load root "$rconf"
+
+if ! $herd say-hello test; then
+    echo "say-hello failed after setting replacement"
+    exit 1
+fi
+
+if test "`cat $stamp`" != "Hello"; then
+    echo "Output file had the wrong contents! Was:"
+    cat $stamp
+    exit 1
+fi
+
+$herd stop test
+
+$herd start test
+
+if $herd say-hello test; then
+    echo "say-hello should have failed after stop/start"
+    exit 1
+fi
+
+if ! $herd say-goodbye test; then
+    echo "say-goodbye failed after replacement"
+    exit 1
+fi
+
+if test "`cat $stamp`" != "Goodbye"; then
+    echo "Output file had the wrong contents! Was:"
+    cat $stamp
+    exit 1
+fi