dmd-service: Add 'halt' and 'power-off' actions.
[guix:dmd.git] / modules / dmd / service.scm
1 ;; service.scm -- Representation of services.
2 ;; Copyright (C) 2013 Ludovic Courtès <ludo@gnu.org>
3 ;; Copyright (C) 2002, 2003 Wolfgang Jährling <wolfgang@pro-linux.de>
4 ;;
5 ;; This file is part of GNU dmd.
6 ;;
7 ;; GNU dmd is free software; you can redistribute it and/or modify it
8 ;; under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 3 of the License, or (at
10 ;; your option) any later version.
11 ;;
12 ;; GNU dmd is distributed in the hope that it will be useful, but
13 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 ;; GNU General Public License for more details.
16 ;;
17 ;; You should have received a copy of the GNU General Public License
18 ;; along with GNU dmd.  If not, see <http://www.gnu.org/licenses/>.
19
20 (define-module (dmd service)
21   #:use-module (oop goops)
22   #:use-module (srfi srfi-1)
23   #:use-module (srfi srfi-26)
24   #:use-module (ice-9 format)
25   #:use-module (dmd support)
26   #:use-module (dmd comm)
27   #:use-module (dmd config)
28   #:use-module (dmd system)
29   #:export (<service>
30             canonical-name
31             running?
32             action-list
33             lookup-action
34             defines-action?
35             enable
36             disable
37             start
38             stop
39             action
40             enforce
41             doc
42             conflicts-with
43             conflicts-with-running
44             dmd-status
45             depends-resolved?
46             launch-service
47             first-running
48             lookup-running
49             lookup-running-or-providing
50             make-service-group
51             for-each-service
52             lookup-services
53             respawn-service
54             register-services
55             required-by
56             handle-unknown
57             make-forkexec-constructor
58             make-kill-destructor
59             make-system-constructor
60             make-system-destructor
61             make-init.d-service
62
63             dmd-service))
64
65 ;; Conveniently create an actions object containing the actions for a
66 ;; <service> object.  The current structure is a list of actions,
67 ;; where every action has the format ``(name . (proc . doc))''.
68 (define-syntax make-actions
69   (syntax-rules ()
70     ((_ (name docstring proc) rest ...)
71      (cons (cons 'name (cons proc docstring))
72            (make-actions rest ...)))
73     ((_ (name proc) rest ...)
74      (cons (cons 'name (cons proc "[No documentation.]"))
75            (make-actions rest ...)))
76     ((_)
77      '())))
78
79 ;; Respawning CAR times in CDR seconds will disable the service.
80 (define respawn-limit (cons 5 5))
81
82 (define-class <service> ()
83   ;; List of provided service-symbols.  The first one is also called
84   ;; the `canonical name' and must be unique to this service.
85   (provides #:init-keyword #:provides
86             #:getter provided-by)
87   ;; List of required service-symbols.
88   (requires #:init-keyword #:requires
89             #:init-value '()
90             #:getter required-by)
91   ;; If `#t', then assume the `running' slot specifies a PID and
92   ;; respawn it if that process terminates.  Otherwise `#f'.
93   (respawn? #:init-keyword #:respawn?
94             #:init-value #f
95             #:getter respawn?)
96   ;; The action to perform to start the service.  This must be a
97   ;; procedure and may take an arbitrary amount of arguments, but it
98   ;; must be possible to call it without any argument.  If the
99   ;; starting attempt failed, it must return `#f'.  The return value
100   ;; will be stored in the `running' slot.
101   (start #:init-keyword #:start
102          #:init-value (lambda () #t))
103   ;; The action to perform to stop the service.  This must be a
104   ;; procedure and may take an arbitrary amount of arguments, but must
105   ;; be callable with exactly one argument, which will be the value of
106   ;; the `running' slot.  Whatever the procedure returns will be
107   ;; ignored.
108   (stop #:init-keyword #:stop
109         #:init-value (lambda (running) #f))
110   ;; Additional actions that can be performed with the service.  This
111   ;; currently is a list with each element (and thus each action)
112   ;; being ``(name . (proc . docstring))'', but users should not rely
113   ;; on this.
114   (actions #:init-keyword #:actions
115            #:init-form (make-actions))
116   ;; If this is `#f', it means that the service is not running
117   ;; currently.  Otherwise, it is the value that was returned by the
118   ;; procedure in the `start' slot when the service was started.
119   (running #:init-value #f)
120   ;; A description of the service.
121   (docstring #:init-keyword #:docstring
122              #:init-value "[No description].")
123   ;; A service can be disabled if it is respawning too fast; it is
124   ;; also possible to enable or disable it manually.
125   (enabled? #:init-value #t
126             #:getter enabled?)
127   ;; Some services should not be directly stopped, but should not be
128   ;; respawned anymore instead.  This field indicates that we are in
129   ;; the phase after the stop but before the termination.
130   (waiting-for-termination? #:init-value #f)
131   ;; This causes the above to be used.  When this is `#t', there is no
132   ;; need for a destructor (i.e. no value in the `stop' slot).
133   (stop-delay? #:init-keyword #:stop-delay?
134                #:init-value #f)
135   ;; The times of the last respawns.
136   (last-respawns #:init-form (apply circular-list
137                                     (make-list (car respawn-limit) 0))))
138
139 (define action:name car)
140 (define action:proc cadr)
141 (define action:doc cddr)
142
143 ;; Return the canonical name of the service.
144 (define-method (canonical-name (obj <service>))
145   (car (provided-by obj)))
146
147 ;; Return whether the service is currently running.
148 (define-method (running? (obj <service>))
149   (and (slot-ref obj 'running) #t))
150
151 ;; Return a list of all actions implemented by OBJ. 
152 (define-method (action-list (obj <service>))
153   (map action:name (slot-ref obj 'actions)))
154
155 ;; Return the action ACTION.
156 (define-method (lookup-action (obj <service>) action)
157   (assq action (slot-ref obj 'actions)))
158
159 ;; Return whether OBJ implements the action ACTION.
160 (define-method (defines-action? (obj <service>) action)
161   (and (lookup-action obj action) #t))
162
163 ;; Enable the service, allow it to get started.
164 (define-method (enable (obj <service>))
165   (slot-set! obj 'enabled? #t)
166   (local-output "Enabled service ~a." (canonical-name obj)))
167
168 ;; Disable the service, make it unstartable.
169 (define-method (disable (obj <service>))
170   (slot-set! obj 'enabled? #f)
171   (local-output "Disabled service ~a." (canonical-name obj)))
172
173 ;; Start the service, including dependencies.
174 (define-method (start (obj <service>) . args)
175   (cond ((running? obj)
176          (local-output "Service ~a is already running."
177                        (canonical-name obj)))
178         ((not (enabled? obj))
179          (local-output "Service ~a is currently disabled."
180                        (canonical-name obj)))
181         ((let ((conflicts (conflicts-with-running obj)))
182            (or (null? conflicts)
183                (local-output "Service ~a conflicts with running services ~a."
184                              (canonical-name obj) conflicts))
185            (not (null? conflicts)))
186          #f) ;; Dummy.
187         (else
188          ;; It is not running and does not conflict with anything
189          ;; that's running, so we can go on and launch it.
190          (let ((problem
191                 ;; Resolve all dependencies.
192                 (call/ec (lambda (return)
193                            (for-each (lambda (symbol)
194                                        ;; FIXME: enforce?!
195                                        (or (start symbol)
196                                            (return symbol)))
197                                      (required-by obj))
198                            #f))))
199            (if problem
200                (local-output "Service ~a depends on ~a."
201                              (canonical-name obj)
202                              problem)
203              ;; Start the service itself.
204              (slot-set! obj 'running (catch #t
205                                        (lambda ()
206                                          (apply (slot-ref obj 'start)
207                                                 args))
208                                        (lambda (key . args)
209                                          (caught-error key args)
210                                          #f))))
211            ;; Status message.
212            (local-output (if (running? obj)
213                              (l10n "Service ~a has been started.")
214                            (l10n "Service ~a could not be started."))
215                          (canonical-name obj)))))
216   (slot-ref obj 'running))
217
218 ;; Stop the service, including services that depend on it.  If the
219 ;; latter fails, continue anyway.  Return `#f' if it could be stopped.
220 (define-method (stop (obj <service>) . args)
221   (if (not (running? obj))
222       (local-output "Service ~a is not running." (canonical-name obj))
223     (if (slot-ref obj 'stop-delay?)
224         (begin
225           (slot-set! obj 'waiting-for-termination? #t)
226           (local-output "Service ~a pending to be stopped."
227                         (canonical-name obj)))
228       (begin
229         ;; Stop services that depend on it.
230         (for-each-service
231          (lambda (serv)
232            (and (running? serv)
233                 (for-each (lambda (sym)
234                             (and (memq sym (provided-by obj))
235                                  (stop serv)))
236                           (required-by serv)))))
237
238         (let ((running-value (slot-ref obj 'running)))
239           ;; If it is a respawnable service, we have to pretend that
240           ;; it is already stopped, because killing it in the
241           ;; destructor would respawn it immediatelly otherwise.
242           ;; However, the destructor must be called with the original
243           ;; value of the `running' slot.
244           (and (respawn? obj)
245                (slot-set! obj 'running #f))
246           ;; Stop the service itself.
247           (catch #t
248             (lambda ()
249               (apply (slot-ref obj 'stop)
250                      running-value
251                      args))
252             (lambda (key . args)
253               ;; Special case: `dmd' may quit.
254               (and (eq? dmd-service obj)
255                    (eq? key 'quit)
256                    (apply quit args))
257               (caught-error key args))))
258         ;; Status message.
259         (let ((name (canonical-name obj)))
260           (if (running? obj)
261               (local-output "Service ~a could not be stopped." name)
262             (local-output "Service ~a has been stopped." name))))))
263   (slot-ref obj 'running))
264
265 ;; Call action THE-ACTION with ARGS.
266 (define-method (action (obj <service>) the-action . args)
267   (define (default-action running . args)
268     ;; All actions which are handled here might be called even if the
269     ;; service is not running, so they have to take this into account.
270     (case the-action
271       ;; Restarting is done in the obvious way.
272       ((restart)
273        (if running
274            (stop obj)
275          (local-output "~a was not running." (canonical-name obj)))
276        (start obj))
277       ((status)
278        (dmd-status obj))
279       (else
280        ;; FIXME: Unknown service.
281        (local-output "Service ~a does not have a ~a action."
282                      (canonical-name obj)
283                      the-action))))
284
285   (define (apply-if-pair obj proc)
286     (if (pair? obj)
287         (proc obj)
288       obj))
289
290   (let ((proc (or (apply-if-pair (lookup-action obj the-action)
291                                  action:proc)
292                   default-action)))
293     ;; Calling default-action will be allowed even when the service is
294     ;; not running, as it provides generally useful functionality and
295     ;; information.
296     ;; FIXME: Why should the user-implementations not be allowed to be
297     ;; called this way?
298     (if (and (not (eq? proc default-action))
299              (not (running? obj)))
300         (local-output "Service ~a is not running." (canonical-name obj))
301       (catch #t
302         (lambda ()
303           (if (can-apply? proc (+ 1 (length args)))
304               (apply proc (slot-ref obj 'running) args)
305             ;; FIXME: Better message.
306             (local-output "Action ~a of service ~a can't take ~a arguments."
307                           the-action (canonical-name obj) (length args))))
308         (lambda (key . args)
309           ;; Special case: `dmd' may quit.
310           (and (eq? dmd-service obj)
311                (eq? key 'quit)
312                (apply quit args))
313           (caught-error key args))))))
314
315 ;; Display documentation about the service.
316 (define-method (doc (obj <service>) . args)
317   (if (null? args)
318       ;; No further argument given -> Normal level of detail.
319       (local-output (slot-ref obj 'docstring))
320     (case (string->symbol (car args)) ;; Does not work with strings.
321       ((full)
322        ;; FIXME
323        (local-output (slot-ref obj 'docstring)))
324       ((short)
325        ;; FIXME
326        (local-output (slot-ref obj 'docstring)))
327       ((action)
328        ;; Display documentation of given actions.
329        (for-each
330         (lambda (the-action)
331           (local-output "~a: ~a"
332                         the-action
333                         (let ((action-object
334                                (lookup-action obj
335                                               (string->symbol the-action))))
336                           (if action-object
337                               (action:doc action-object)
338                               (gettext "This action does not exist.")))))
339         (cdr args)))
340       ((list-actions)
341        (local-output "~a ~a"
342                      (canonical-name obj)
343                      (action-list obj)))
344       (else
345        ;; FIXME: Implement doc-help.
346        (local-output "Unknown keyword.  Try `doc dmd help'.")))))
347
348 ;; Return a list of canonical names of the services that conflict with
349 ;; OBJ.
350 (define-method (conflicts-with (obj <service>))
351   (let ((conflicts '()))
352     (for-each (lambda (sym)
353                 (for-each (lambda (s)
354                             (set! conflicts (cons (canonical-name s)
355                                                   conflicts)))
356                           (lookup-services sym)))
357               (provided-by obj))
358     ;; Clean up the result.
359     (delete! (canonical-name obj)
360              (delete-duplicates! conflicts eq?)
361              eq?)))
362
363 ;; Check if this service provides a symbol that is already provided
364 ;; by any other running services.  If so, return the canonical names
365 ;; of the other services.  Otherwise, return the empty list.
366 (define-method (conflicts-with-running (obj <service>))
367   (let ((conflicts '()))
368     (for-each-service
369      (lambda (serv)
370        (and (running? serv)
371             (for-each (lambda (sym)
372                         (and (memq sym (provided-by obj))
373                              (set! conflicts
374                                    (cons (canonical-name serv)
375                                          conflicts))))
376                       (provided-by serv)))))
377     conflicts))
378
379 ;; Start OBJ, but first kill all services which conflict with it.
380 ;; FIXME-CRITICAL: Conflicts of indirect dependencies.  For this, we
381 ;; seem to need a similar solution like launch-service.
382 ;; FIXME: This should rather be removed and added cleanly later.
383 (define-method (enforce (obj <service>) . args)
384   (for-each stop (conflicts-with-running obj))
385   (apply start obj args))
386
387 ;; Display information about the service.
388 (define-method (dmd-status (obj <service>))
389   (local-output "Status of ~a:"
390                 (canonical-name obj))
391   (if (running? obj)
392       (local-output "  It is started.")
393     (local-output "  It is stopped."))
394   (if (enabled? obj)
395       (local-output "  It is enabled.")
396     (local-output "  It is disabled."))
397   (local-output "  Provides ~a." (provided-by obj))
398   (local-output "  Requires ~a." (required-by obj))
399   (local-output "  Conflicts with ~a." (conflicts-with obj))
400   (if (respawn? obj)
401       (local-output "  Will be respawned.")
402     (local-output "  Will not be respawned.")))
403
404 ;; Return whether OBJ requires something that is not yet running.
405 (define-method (depends-resolved? (obj <service>))
406   (call/ec (lambda (return)
407              (for-each (lambda (dep)
408                          (or (lookup-running dep)
409                              (return #f)))
410                        (required-by obj))
411              #t)))
412
413 \f
414
415 ;; Try to start (with PROC) a service providing NAME.  Used by `start'
416 ;; and `enforce'.
417 (define (launch-service name proc args)
418   (let* ((possibilities (lookup-services name))
419          (which (first-running possibilities)))
420     (if (null? possibilities)
421         (local-output "No service provides ~a." name)
422       (or which
423           ;; None running yet, start one.
424           (set! which
425                 (call/ec (lambda (return)
426                            (for-each (lambda (service)
427                                        (and (apply proc service args)
428                                             (return service)))
429                                      possibilities)
430                            #f)))))
431     (or which
432         (let ((unknown (lookup-running 'unknown)))
433           (if (and unknown
434                    (defines-action? unknown 'start))
435               (apply action unknown 'start name args)
436             (local-output "Providing ~a impossible." name))))
437     (and which #t)))
438
439 ;; Starting by name.
440 (define-method (start (obj <symbol>) . args)
441   (launch-service obj start args))
442
443 ;; Enforcing by name.  FIXME: Should be removed and added cleanly later.
444 (define-method (enforce (obj <symbol>) . args)
445   (launch-service obj enforce args))
446
447 ;; Stopping by name.
448 (define-method (stop (obj <symbol>) . args)
449   (let ((which (lookup-running obj)))
450     (if (not which)
451         (let ((unknown (lookup-running 'unknown)))
452           (if (and unknown
453                    (defines-action? unknown 'stop))
454               (apply action unknown 'stop obj args)
455             (local-output "No service currently providing ~a." obj)))
456       (apply stop which args))))
457
458 ;; Perform action THE-ACTION by name.
459 (define-method (action (obj <symbol>) the-action . args)
460   (let ((which-services (lookup-running-or-providing obj)))
461     (if (null? which-services)
462         (let ((unknown (lookup-running 'unknown)))
463           (if (and unknown
464                    (defines-action? unknown 'action))
465               (apply action unknown 'action the-action args)
466             (local-output "No service at all providing ~a." obj)))
467       (for-each (lambda (s)
468                   (apply (case the-action
469                            ((enable) enable)
470                            ((disable) disable)
471                            ((doc) doc)
472                            (else
473                             (lambda (s . further-args)
474                               (apply action s the-action further-args))))
475                          s
476                          args))
477                 which-services))))
478
479 \f
480
481 ;; Handling of unprovided service-symbols.  This can be called in
482 ;; either of the following ways (i.e. with either three or four
483 ;; arguments):
484 ;;   handle-unknown SERVICE-SYMBOL [ 'start | 'stop ] ARGS
485 ;;   handle-unknown SERVICE-SYMBOL 'action THE_ACTION ARGS
486 (define (handle-unknown . args)
487   (let ((unknown (lookup-running 'unknown)))
488     ;; FIXME: Display message if no unknown service.
489     (if unknown
490         (apply-to-args args
491             (case-lambda
492              ;; Start or stop.
493              ((service-symbol start/stop args)
494               (if (defines-action? unknown start/stop)
495                   (apply action unknown start/stop service-symbol args)
496                 ;; FIXME: Bad message.
497                 (local-output "Cannot ~a ~a." start/stop service-symbol)))
498              ;; Action.
499              ((service-symbol action-sym the-action args)
500               (assert (eq? action-sym 'action))
501               (if (defines-action? unknown 'action)
502                   (apply action unknown 'action service-symbol the-action args)
503                 (local-output "No service provides ~a." service-symbol))))))))
504
505 ;; Check if any of SERVICES is running.  If this is the case, return
506 ;; it.  If none, return `#f'.  Only the first one found will be
507 ;; returned; this is because this is mainly intended to be applied on
508 ;; the return value of `lookup-services', where no more than one will
509 ;; ever run at the same time.
510 (define (first-running services)
511   (find running? services))
512
513 ;; Return the running service that provides NAME, or false if none.
514 (define (lookup-running name)
515   (first-running (lookup-services name)))
516
517 ;; Lookup the running service providing SYM, and return it as a
518 ;; one-element list.  If none is running, return a list of all
519 ;; services which provide SYM.
520 (define (lookup-running-or-providing sym)
521   (define (list-unless-false x)
522     (if x (list x) x))
523
524   (or (list-unless-false (lookup-running sym))
525       (lookup-services sym)))
526
527 ;; FIXME: They ignore arguments currently, but they should not.
528
529 ;; Produce a constructor that execs PROGRAM with CHILD-ARGS in a child
530 ;; process and returns its pid.
531 (define (make-forkexec-constructor program . child-args)
532   (lambda args
533     (let ((pid (primitive-fork)))
534       (if (zero? pid)
535           (begin
536             ;; Become the leader of a new session and session group.
537             ;; Programs such as 'mingetty' expect this.
538             (setsid)
539             (apply execlp program program child-args))
540           pid))))
541
542 ;; Produce a destructor that sends SIGNAL to the process with the pid
543 ;; given as argument, where SIGNAL defaults to `SIGTERM'.
544 (define make-kill-destructor
545   (lambda* (#:optional (signal SIGTERM))
546     (lambda (pid . args)
547       (kill pid signal)
548       #f)))
549
550 ;; Produce a constructor that executes a command.
551 (define (make-system-constructor . command)
552   (lambda args
553     (zero? (status:exit-val (system (apply string-append command))))))
554
555 ;; Produce a destructor that executes a command.
556 (define (make-system-destructor . command)
557   (lambda (ignored . args)
558     (not (zero? (status:exit-val (system (apply string-append command)))))))
559
560 ;; Create service with constructor and destructor being set to typical
561 ;; init.d scripts.
562 (define (make-init.d-service name . stuff)
563   (let ((cmd (string-append "/etc/init.d/" name)))
564     (apply make <service>
565            #:provides (list (string->symbol name))
566            #:start (make-system-constructor cmd " start")
567            #:stop (make-system-destructor cmd " stop")
568            stuff)))
569
570 ;; A group of service-names which can be provided (i.e. services
571 ;; providing them get started) and unprovided (same for stopping)
572 ;; together.  Not comparable with a real runlevel at all, but can be
573 ;; used to emulate a simple kind of runlevel.
574 (define-syntax-rule (make-service-group NAME (SYM ...) ADDITIONS ...)
575   (make <service>
576     #:provides '(NAME)
577     #:requires '(SYM ...)
578     #:stop (lambda (running)
579              (for-each stop '(SYM ...))
580              #f)
581     ADDITIONS ...))
582
583 \f
584
585 ;;; Registered services.
586
587 ;; Current size of the hash table below.  The table will be resized on
588 ;; demand.
589 (define services-max-cnt 100)
590
591 ;; Number of used entries in the table below.
592 (define services-cnt 0)
593
594 ;; All registered services.
595 (define services (make-hash-table services-max-cnt))
596
597 ;;; Perform actions with services:
598
599 ;; Call PROC once for each registered service.
600 (define (for-each-service proc)
601   (hash-fold (lambda (key value unused)
602                (and (eq? key (canonical-name (car value)))
603                     (proc (car value))))
604              #f ;; Unused
605              services))
606
607 ;; Lookup the services that provide NAME.  Returns a (possibly empty)
608 ;; list of those.
609 (define (lookup-services name)
610   (hashq-ref services name '()))
611
612 ;; SIGCHLD handler.
613 (define (respawn-service signum)
614   (define (handler return)
615     (let ((pid (car (waitpid WAIT_ANY))))
616       (for-each-service
617        (lambda (serv)
618          (and (respawn? serv)
619               (running? serv)
620               (enabled? serv)
621               (= pid (slot-ref serv 'running))
622               ;; We found it.
623               (begin
624                 (slot-set! serv 'running #f)
625                 (if (> (current-time)
626                        (+ (cdr respawn-limit)
627                           (car (slot-ref serv 'last-respawns))))
628                     (if (not (slot-ref serv 'waiting-for-termination?))
629                         (begin
630                           ;; Everything is okay, start it.
631                           (local-output "Respawning ~a."
632                                         (canonical-name serv))
633                           (set-car! (slot-ref serv 'last-respawns)
634                                     (current-time))
635                           (slot-set! serv 'last-respawns
636                                      (cdr (slot-ref serv 'last-respawns)))
637                           (start serv))
638                       ;; We have just been waiting for the
639                       ;; termination.  The `running' slot has already
640                       ;; been set to `#f' by `stop'.
641                       (begin
642                         (local-output "Service ~a terminated."
643                                       (canonical-name serv))
644                         (slot-set! serv 'waiting-for-termination? #f)))
645                   (begin
646                     (local-output "Service ~a has been disabled."
647                                   (canonical-name serv))
648                     (local-output "  (Respawning too fast.)")
649                     (slot-set! serv 'enabled? #f)))
650                 (return #t)))))))
651
652   (without-extra-output
653    (catch-system-error
654     (call/ec handler))))
655
656 ;; Install it as the handler.
657 (sigaction SIGCHLD respawn-service)
658
659 ;; Add NEW-SERVICES to the list of known services.
660 (define (register-services . new-services)
661   (define (register-single-service new)
662     ;; Sanity-checks first.
663     (assert (list-of-symbols? (provided-by new)))
664     (assert (list-of-symbols? (required-by new)))
665     (assert (boolean? (respawn? new)))
666     ;; Canonical name actually must be canonical.  (FIXME: This test
667     ;; is incomplete, since we may add a service later that makes it
668     ;; non-cannonical.)
669     (assert (null? (lookup-services (canonical-name new))))
670     ;; FIXME: Verify consistency: Check that there are no circular
671     ;; dependencies, check for bogus conflicts/dependencies, whatever
672     ;; else makes sense.
673
674     ;; Insert into the hash table.
675     (for-each (lambda (name)
676                 (let ((old (lookup-services name)))
677                   ;; Counting the number of used entries.
678                   (and (null? old)
679                        (set! services-cnt (1+ services-cnt)))
680                   (and (= services-cnt services-max-cnt)
681                        (begin
682                          ;; Double the size, so that we don't have to
683                          ;; do all this too often.
684                          (set! services-max-cnt (* 2 services-max-cnt))
685                          (set! services
686                                (copy-hashq-table services services-max-cnt))))
687                   ;; Actually add the new service now.
688                   (hashq-set! services name (cons new old))))
689               (provided-by new)))
690
691   (for-each register-single-service new-services))
692
693 ;;; Tests for validity of the slots of <service> objects.
694
695 ;; Test if OBJ is a list that only contains symbols.
696 (define (list-of-symbols? obj)
697   (cond ((null? obj) #t)
698         ((and (pair? obj)
699               (symbol? (car obj)))
700          (list-of-symbols? (cdr obj)))
701         (else #f)))
702
703 \f
704
705 ;; The `dmd' service.
706
707 (define (shutdown-services)
708   "Shut down all the currently running services; update the persistent state
709 file when persistence is enabled."
710   (let ((running-services '()))
711     (for-each-service
712      (lambda (service)
713        (when (running? service)
714          (stop service)
715          (when persistency
716            (set! running-services
717                  (cons (canonical-name service)
718                        running-services))))))
719
720     (when persistency
721       (call-with-output-file persistency-state-file
722         (lambda (p)
723           (format p "~{~a ~}~%" running-services))))))
724
725 (define dmd-service
726   (make <service>
727     #:docstring "The dmd service is used to operate on dmd itself."
728     #:provides '(dmd)
729     #:requires '()
730     #:respawn #f
731     #:start (lambda args
732               (when (isatty? (current-output-port))
733                 (display-version))
734               #t)
735     #:stop (lambda (unused . args)
736              (local-output "Exiting dmd...")
737              ;; Prevent that we try to stop ourself again.
738              (slot-set! dmd-service 'running #f)
739              (shutdown-services)
740              (quit))
741     ;; All actions here need to take care that they do not invoke any
742     ;; user-defined code without catching `quit', since they are
743     ;; allowed to quit, while user-supplied code shouldn't be.
744     #:actions
745     (make-actions
746      ;; Display status.
747      (status
748       "Display the status of dmd.  I.e. which services are running and
749 which ones are not."
750       (lambda (running)
751         (let ((started '()) (stopped '()))
752           (for-each-service
753            (lambda (service)
754              (if (running? service)
755                  (set! started (cons (canonical-name service)
756                                      started))
757                  (set! stopped (cons (canonical-name service)
758                                      stopped)))))
759           (local-output "Started: ~a" started)
760           (local-output "Stopped: ~a" stopped))))
761      ;; Look at every service in detail.
762      (detailed-status
763       "Display detailed information about all services."
764       (lambda (running)
765         (for-each-service dmd-status)))
766      ;; Halt.
767      (halt
768       "Halt the system."
769       (lambda (running)
770         (local-output "Halting...")
771         (catch 'quit
772           (cut stop dmd-service)
773           (cut halt))))
774      ;; Power off.
775      (power-off
776       "Halt the system and turn it off."
777       (lambda (running)
778         (local-output "Shutting down...")
779         (catch 'quit
780           (cut stop dmd-service)
781           (cut power-off))))
782      ;; Load a configuration file.
783      (load
784       "Load the Scheme code from FILE into dmd.  This is potentially
785 dangerous.  You have been warned."
786       (lambda (running file-name)
787         (local-output "Loading ~a." file-name)
788         ;; Every action is protected anyway, so no need for a `catch'
789         ;; here.  FIXME: What about `quit'?
790         (load file-name)))
791      ;; Disable output.
792      (silent
793       "Disable the displaying of information on standard output."
794       (lambda (running)
795         (be-silent)))
796      ;; Enable output.
797      (verbose
798       "Enable the displaying of information on standard output."
799       (lambda (running)
800         (be-verbose)))
801      ;; Go into the background.
802      (daemonize
803       "Go into the background.  Be careful, this means that a new
804 process will be created, so dmd will not get SIGCHLD signals anymore
805 if previously spawned childs terminate.  Therefore, this action should
806 usually only be used (if at all) *before* childs get spawned for which
807 we want to receive these signals."
808       (lambda (running)
809         (be-silent)
810         (if (zero? (primitive-fork))
811             #t
812             (primitive-exit 0))))
813      (persistency
814       "Safe the current state of running and non-running services.
815 This status gets written into a file on termination, so that we can
816 restore the status on next startup.  Optionally, you can pass a file
817 name as argument that will be used to store the status."
818       (lambda* (running #:optional (file #f))
819         (set! persistency #t)
820         (when file
821           (set! persistency-state-file file))))
822      (no-persistency
823       "Don't safe state in a file on exit."
824       (lambda (running)
825         (set! persistency #f)))
826      (cd
827       "Change the working directory of dmd.  This only makes sense
828 when in interactive mode, i.e. with `--socket=none'."
829       (lambda (running dir)
830         (chdir dir)))
831      ;; Restart it - that does not make sense, but
832      ;; we're better off by implementing it due to the
833      ;; default action.
834      (restart
835       "This does not work for dmd."
836       (lambda (running)
837         (local-output "You must be kidding."))))))
838
839 (register-services dmd-service)