[PATCH 1/2] dmd: Add dmd action unload: unload known services.

[Alex Sassmannshausen]

* modules/dmd/service.scm (deregister-services): New procedure.
  (dmd-service): Add new action: unload.
* dmd.texi (The 'dmd' and 'unknown' services): Document 'unload'.
* tests/basic.sh: Add 'unload' tests (stop single service  & 'all').
---
 dmd.texi                |   13 ++++++++
 modules/dmd/service.scm |   83 +++++++++++++++++++++++++++++++++++++++++++++--
 tests/basic.sh          |   22 +++++++++++++
 3 files changed, 116 insertions(+), 2 deletions(-)

diff --git a/dmd.texi b/dmd.texi
index f7306db..e31b230 100644
--- a/dmd.texi
+++ b/dmd.texi
@@ -854,6 +854,19 @@ 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 unload @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.  Any services
+depending upon @var{service-name} will be stopped as part of this
+process.  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 @code{web-server}, which
+might be provided by both @code{apache} and @code{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..20a3f52 100644
--- a/modules/dmd/service.scm
+++ b/modules/dmd/service.scm
@@ -761,6 +761,78 @@ 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 identity
+            (hash-map->list
+             (lambda (key value)
+               (match value
+                 ((service)     ; only one service associated with KEY
+                  (and (eq? key (canonical-name service))
+                       (not (eq? key 'dmd))
+                       (cons key service)))
+                 (_ #f)))               ; all other cases: #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.
+           (match (lookup-services name)
+             (()                        ; unknown service
+              (local-output
+               "Not unloading: '~a' is an uknown service." name))
+             ((service)             ; only SERVICE provides NAME
+              ;; Are we removing a user service…
+              (if (eq? (canonical-name service) name)
+                  (local-output "Removing service '~a'..." name)
+                  ;; or a virtual service?
+                  (local-output
+                   "Removing service '~a' providing '~a'..."
+                   (canonical-name service) name))
+              (deregister service)
+              (local-output "Done."))
+             ((services ...)            ; ambiguous NAME
+              (local-output
+               "Not unloading: '~a' names several services: '~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 +939,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
+     (unload
+      "Unload the service identified by SERVICE-NAME or all services
+except for dmd if SERVICE-NAME is 'all'.  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 +963,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."
diff --git a/tests/basic.sh b/tests/basic.sh
index e9ad970..5f53fe3 100644
--- a/tests/basic.sh
+++ b/tests/basic.sh
@@ -41,6 +41,16 @@ cat > "$conf"<<EOF
              #t)
    #:stop  (lambda _
              (delete-file "$stamp"))
+   #:respawn? #f)
+ (make <service>
+   #:provides '(test-2)
+   #:requires '(test)
+   #:start (lambda _
+             (call-with-output-file "$stamp-2"
+               (cut display "bar" <>))
+             #t)
+   #:stop  (lambda _
+             (delete-file "$stamp-2"))
    #:respawn? #f))
 EOF
 
@@ -65,6 +75,18 @@ $deco stop test
 
 $deco status test | grep stopped
 
+$deco start test-2
+
+$deco status test-2 | grep started
+
+$deco unload dmd test
+
+$deco status dmd | grep "Stopped: (test-2)"
+
+$deco unload dmd all
+
+$deco status dmd | grep "Stopped: ()"
+
 $deco stop dmd
 ! kill -0 $dmd_pid
 
-- 
1.7.9.5