From mboxrd@z Thu Jan 1 00:00:00 1970 From: Alex Sassmannshausen Subject: =?UTF-8?q?=5BPATCH=201/2=5D=20dmd=3A=20Add=20dmd=20action=20unload=3A=20unload=20known=20services=2E?= Date: Mon, 10 Mar 2014 18:39:20 +0100 Message-ID: <1394473161-14356-1-git-send-email-alex.sassmannshausen@gmail.com> References: <87a9dcrzsh.fsf@gnu.org> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:36110) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WN4BJ-0004KX-JZ for guix-devel@gnu.org; Mon, 10 Mar 2014 13:40:12 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1WN4BD-0007gr-0S for guix-devel@gnu.org; Mon, 10 Mar 2014 13:40:05 -0400 Received: from mail-wg0-x22d.google.com ([2a00:1450:400c:c00::22d]:44449) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1WN4BC-0007gN-Li for guix-devel@gnu.org; Mon, 10 Mar 2014 13:39:58 -0400 Received: by mail-wg0-f45.google.com with SMTP id l18so8689459wgh.16 for ; Mon, 10 Mar 2014 10:39:57 -0700 (PDT) In-Reply-To: <87a9dcrzsh.fsf@gnu.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org To: guix-devel@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 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"< + #: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