From: Alex Sassmannshausen <alex.sassmannshausen@gmail.com>
To: guix-devel@gnu.org
Subject: [PATCH 1/2] dmd: Add dmd action unload: unload known services.
Date: Mon, 10 Mar 2014 18:39:20 +0100 [thread overview]
Message-ID: <1394473161-14356-1-git-send-email-alex.sassmannshausen@gmail.com> (raw)
In-Reply-To: <87a9dcrzsh.fsf@gnu.org>
* 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}).
+@item unload @var{service-name}
+Attempt to remove the service identified by @var{service-name}.
+@command{dmd} 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
+@var{service-name} 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
next prev parent reply other threads:[~2014-03-10 17:40 UTC|newest]
Thread overview: 10+ messages / expand[flat|nested] mbox.gz Atom feed top
2014-02-25 8:22 dmd: Unload one or all services at runtime Alex Sassmannshausen
2014-02-27 21:50 ` Ludovic Courtès
2014-03-10 17:39 ` Alex Sassmannshausen [this message]
2014-03-10 17:39 ` [PATCH 2/2] dmd: Add dmd action 'reload': unload all; load Alex Sassmannshausen
2014-03-12 17:49 ` Ludovic Courtès
2014-03-19 14:25 ` dmd: Unload one or all services at runtime Alex Sassmannshausen
2014-03-19 14:25 ` [PATCH] dmd: Add dmd action 'reload': unload all; load Alex Sassmannshausen
2014-03-25 20:33 ` Ludovic Courtès
2014-03-25 20:30 ` dmd: Unload one or all services at runtime Ludovic Courtès
2014-03-12 17:45 ` [PATCH 1/2] dmd: Add dmd action unload: unload known services Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=1394473161-14356-1-git-send-email-alex.sassmannshausen@gmail.com \
--to=alex.sassmannshausen@gmail.com \
--cc=guix-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.