dmd: Unload one or all services at runtime.

[Alex Sassmannshausen]

Hello,

Currently dmd allows you to dynamically load new services into a running
instance. Unfortunately, currently dmd will not allow you to carry out
corrections to a running service by reloading its definition.

The attached patch is a first step towards this aim. It allows you to
unload individual services (by their name) or all known user
services. It even allows you to unload the special service dmd itself,
which is the same as sending the stop command to dmd.

For example:
$: dmd rm dmd apache // Unload the apache server
$: dmd rm dmd web-server // Unload the service providing
                         // a web server if there is only one.
$: dmd rm dmd all // Unload all user services.

You can then reload the relevant service's definition (or, if you ran
'dmd rm dmd all', you can reload your dmd.d/init.scm).

In future this might provide the foundation for a 'reload' action for
dmd.

Feedback welcome.

Best wishes,

Alex

>From 1b4ec0f2261e1231ff21c5486dc6e75466c5829e Mon Sep 17 00:00:00 2001
From: Alex Sassmannshausen <address@hidden>
Date: Sun, 23 Feb 2014 11:06:14 +0100
Subject: [PATCH] dmd: Add dmd action rm: remove known services.

* modules/dmd/service.scm (deregister-services): New procedure.
  (dmd-service): Add new action: rm.
* dmd.texi (The 'dmd' and 'unknown' services): Document 'rm'.
---
 dmd.texi                |   11 ++++++
 modules/dmd/service.scm |   85 +++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 94 insertions(+), 2 deletions(-)

diff --git a/dmd.texi b/dmd.texi
index f7306db..8ff0451 100644
--- a/dmd.texi
+++ b/dmd.texi
@@ -854,6 +854,17 @@ Evaluate the Scheme code in @var{file} in a fresh module 
that uses the
 @code{(oop goops)} and @code{(dmd services)} modules---as with the
 @code{--config} option of @command{dmd} (@pxref{Invoking dmd}).
 
address@hidden rm @var{service-name}
+Attempt to remove the service identified by @var{service-name}.
address@hidden will first stop the service, if necessary, and then
+remove it from the list of registered services.  If @var{service-name}
+simply does not exist, output a warning and do nothing.  If it exists,
+but is provided by several services, output a warning and do nothing.
+This latter case might occur for instance with the fictional service
+web-server, which might be provided by both apache and nginx.  If
address@hidden is the special string and @code{all}, attempt to
+remove all services except for dmd itself.
+
 @item daemonize
 Fork and go into the background.  This should be called before
 respawnable services are started, as otherwise we would not get the
diff --git a/modules/dmd/service.scm b/modules/dmd/service.scm
index 6862775..601b6aa 100644
--- a/modules/dmd/service.scm
+++ b/modules/dmd/service.scm
@@ -761,6 +761,80 @@ otherwise by updating its state."
 
   (for-each register-single-service new-services))
 
+(define (deregister-service service-name)
+  "For each string in SERVICE-NAME, stop the associated service if
+necessary and remove it from the services table.  If SERVICE-NAME is
+the special string 'all', remove all services except for dmd.
+
+This will remove a service either if it is identified by its canonical
+name, or if it is the only service providing the service that is
+requested to be removed."
+  (define (deregister service)
+    (if (running? service)
+        (stop service))
+    ;; Remove services provided by service from the hash table.
+    (for-each
+     (lambda (name)
+       (let ((old (lookup-services name)))
+         (if (= 1 (length old))
+             ;; Only service provides this service, ergo:
+             (begin
+               ;; Reduce provided services count
+               (set! services-cnt (1- services-cnt))
+               ;; Remove service entry from services.
+               (hashq-remove! services name))
+             ;; ELSE: remove service from providing services.
+             (hashq-set! services name
+                         (remove
+                          (lambda (lk-service)
+                            (eq? (canonical-name service)
+                                 (canonical-name lk-service)))
+                          old)))))
+     (provided-by service)))
+  (define (service-pairs)
+    "Return '(name . service) of all user-registered services."
+    (filter (lambda (service-pair) (if service-pair #t #f))
+            (hash-map->list
+             (lambda (key value)
+               (let ((can-name (canonical-name (car value))))
+                 (if (and (null? (cdr value))
+                          (eq? key can-name)
+                          (not (eq? can-name 'dmd)))
+                     (cons key (car value)) #f)))
+             services)))
+
+  (let ((name (string->symbol service-name)))
+    (cond ((eq? name 'all)
+           ;; Special 'remove all' case.
+           (let ((pairs (service-pairs)))
+             (local-output "Unloading all optional services: '~a'..."
+                           (map car pairs))
+             (for-each deregister (map cdr pairs))
+             (local-output "Done.")))
+          (else
+           ;; Removing only one service.
+           (let ((services (lookup-services name)))
+             (cond ((null? services)
+                    (local-output "'~a' is an uknown service." name))
+                   ((= 1 (length services))
+                    ;; Are we removing a user service…
+                    (if (eq? (canonical-name (car services)) name)
+                        (local-output "Removing service '~a'..."
+                                      name)
+                        ;; or a virtual service?
+                        (local-output
+                         (string-append "Removing service '~a' "
+                                        "providing '~a'...")
+                         (canonical-name (car services)) name))
+                    (deregister (car services))
+                    (local-output "Done."))
+                   (else
+                    ;; Service name to ambiguous
+                    (local-output
+                     (string-append "'~a' identifies more than one "
+                                    "service to be stopped: '~a'.")
+                     name (map canonical-name services)))))))))
+
 ;;; Tests for validity of the slots of <service> objects.
 
 ;; Test if OBJ is a list that only contains symbols.
@@ -867,6 +941,13 @@ dangerous.  You have been warned."
             (local-output "Failed to load from '~a': ~a."
                           file-name (strerror (system-error-errno args)))
             #f))))
+     ;; Unload a service
+     (rm
+      "Remove the service identified by SERVICE-NAME or all services
+except for dmd if SERVICE-NAME is 'all' from services.  Stop services
+before removing them if needed."
+      (lambda (running service-name)
+        (deregister-service service-name)))
      ;; Go into the background.
      (daemonize
       "Go into the background.  Be careful, this means that a new
@@ -884,8 +965,8 @@ This status gets written into a file on termination, so 
that we can
 restore the status on next startup.  Optionally, you can pass a file
 name as argument that will be used to store the status."
       (lambda* (running #:optional (file #f))
-       (set! persistency #t)
-       (when file
+       (set! persistency #t)
+       (when file
           (set! persistency-state-file file))))
      (no-persistency
       "Don't safe state in a file on exit."
-- 
1.7.9.5