[shepherd] 02/08: Implement service-registry demo.

[Juliana Sims]

juli pushed a commit to branch wip-goblinsify
in repository shepherd.

commit 92c60ccaa06314c5d6df46ec9791c09936a69dc4
Author: Juliana Sims <juli@incana.org>
AuthorDate: Fri Jun 21 15:27:32 2024 -0400

    Implement service-registry demo.
    
    * scratch-demo.scm: New file.
    * scratch.scm: New file.
---
 scratch-demo.scm |   9 +
 scratch.scm      | 658 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 667 insertions(+)

diff --git a/scratch-demo.scm b/scratch-demo.scm
new file mode 100644
index 0000000..c604164
--- /dev/null
+++ b/scratch-demo.scm
@@ -0,0 +1,9 @@
+(define mcron
+  (service
+   '(mcron)
+   ;; Run /usr/bin/mcron without any command-line arguments.
+   #:start (make-forkexec-constructor '("/usr/bin/mcron"))
+   #:stop (make-kill-destructor)
+   #:respawn? #t))
+
+(register-services (list mcron))
diff --git a/scratch.scm b/scratch.scm
new file mode 100644
index 0000000..cda1b81
--- /dev/null
+++ b/scratch.scm
@@ -0,0 +1,658 @@
+;; Testing/experimentation code for porting the Shepherd
+(use-modules (goblins)
+             (goblins actor-lib cell)
+             (goblins actor-lib joiners)
+             (goblins actor-lib methods)
+             (goblins actor-lib selfish-spawn)
+             (ice-9 exceptions)
+             (ice-9 match)
+             (ice-9 vlist)
+             ((rnrs io ports)
+              #:select (get-string-all))
+             ;; TODO make sure these are Goblins-friendly
+             ((shepherd support)
+              #:select (l10n
+                        let-loop
+                        local-output
+                        primitive-load*))
+             (srfi srfi-1)
+             (srfi srfi-9)
+             (srfi srfi-26))
+
+;;; new code/utils
+
+(define-actor (^pcell bcom #:optional val)
+  "Construct a propagated cell, a cell which returns its new value after 
setting
+it"
+  #:frozen
+  (case-lambda
+    [() val]
+    [(new-val)
+     (bcom (^pcell bcom new-val) new-val)]))
+
+(define-syntax define-pcell
+  ;; Define a Cell using standard Scheme define syntax.
+  (syntax-rules ()
+    [(_ id)
+     (define id
+       (spawn-named 'id ^pcell))]
+    [(_ id val)
+     (define id
+       (spawn-named 'id ^pcell val))]))
+
+;;; extant Shepherd utils
+
+(define (remove pred lst)
+  ;; In Guile <= 3.0.9, 'remove' is written in C and thus introduced a
+  ;; continuation barrier.  Provide a Scheme implementation to address that.
+  (let loop ((lst lst)
+             (result '()))
+    (match lst
+      (()
+       (reverse result))
+      ((head . tail)
+       (loop tail (if (pred head) result (cons head result)))))))
+
+;;; porting experiments
+
+;; Shepherd uses SRFI-34 and SRFI-35 for exceptions. Let's update those
+
+;; Service errors.
+(define-exception-type &service-error &error
+  make-service-error service-error?)
+
+;; Error raised when looking up a service by name fails.
+(define-exception-type &missing-service-error &service-error
+  make-missing-service-error missing-service-error?
+  (name missing-service-name))
+
+(define-exception-type &unknown-action-error &service-error
+  make-unknown-action-error unknown-action-error?
+  (service unknown-action-service)
+  (action  unknown-action-name))
+
+;; Report of an action throwing an exception in user code.
+(define-exception-type &action-runtime-error &service-error
+  make-action-runtime-error action-runtime-error?
+  (service   action-runtime-error-service)
+  (action    action-runtime-error-action)
+  (key       action-runtime-error-key)
+  (arguments action-runtime-error-arguments))
+
+(define (report-exception action service key args)
+  "Report an exception of type @var{key} in user code @var{action} of
+@var{service}."
+  ;; FIXME: Would be nice to log it without sending the message to the client.
+  (raise-exception (make-action-runtime-error service action key args)))
+
+;; TODO
+#;
+(define (exception->sexp exception)
+  "Turn the ice-9 error @var{exception} into an sexp that can be sent over the
+wire."
+  (match exception
+    ((? missing-service-error?)
+     `(error (version 0) service-not-found
+             ,(missing-service-name exception)))
+    ((? unknown-action-error?)
+     `(error (version 0) action-not-found
+             ,(unknown-action-name exception)
+             ,($ (unknown-action-service exception) 'canonical-name)))
+    ((? action-runtime-error?)
+     `(error (version 0) action-exception
+             ,(action-runtime-error-action exception)
+             ,($ (action-runtime-error-service exception) 'canonical-name)
+             ,(action-runtime-error-key exception)
+             ,(map result->sexp (action-runtime-error-arguments exception))))
+    ((? service-error?)
+     `(error (version 0) service-error))))
+
+;; service.scm proper
+
+;; A process, as started by 'make-forkexec-constructor'.
+;; NOTE the process API is not exposed to users so we can do whatever we want
+;; to it
+(define-actor (^process bcom id command)
+  (define-cell current-command command)
+  (methods
+   ;; integer
+   ((id) id)
+   ;; list of strings | #f
+   ((command)
+    (let ((old-command ($ current-command)))
+      (if old-command
+          old-command
+          (let ((new-command
+                 (catch 'system-error
+                   (lambda ()
+                     (call-with-input-file (string-append "/proc/"
+                                                          (number->string id)
+                                                          "/cmdline")
+                       (lambda (port)
+                         (string-tokenize (get-string-all port)
+                                          (char-set-complement (char-set 
#\nul))))))
+                   (const '()))))
+            ($ current-command new-command)
+            new-command))))))
+
+(define (pid->process pid)
+  "Return a @code{<process>} record for @var{pid}."
+  ;; PID is typically the result of a 'fork+exec-command' call.  There's a
+  ;; possibility that that process has not called 'exec' yet, so reading
+  ;; /proc/PID/cmdline right now would give the wrong result (the command line
+  ;; of the parent process).  Instead, set the command to #f to delay /proc
+  ;; access.
+  (spawn-named (format #f "process-~s" pid)
+               ^process pid #f))
+
+;; XXX we should really have a more elegant solution for this. We should be 
able
+;; to define some macro to "compile down" actions into the service objects 
using
+;; them so we don't have to treat them as a separate object, much as
+;; extend-methods allows methods-based actors to inherit methods. The issue is
+;; exposing individual documentation for each action. One possible solution is
+;; string-append-ing together action docstrings into the overall service 
actor's
+;; documentation object
+(define-record-type <action>
+  (make-action name proc doc)
+  action?
+  (name action-name)
+  (proc action-procedure)
+  (doc  action-documentation))
+
+(define* (action name proc #:optional (doc "[No documentation.]"))
+  "Return a new action with the given @var{name}, a symbol, that executes
+@var{proc}, a one-argument procedure that is passed the service's running
+value.  Use @var{doc} as the documentation of that action."
+  (make-action name proc doc))
+
+;; Conveniently create a list of <action> objects containing the actions for a
+;; <service> object.
+(define-syntax actions
+  (syntax-rules ()
+    ((_ (name docstring proc) rest ...)
+     (cons (make-action 'name proc docstring)
+           (actions rest ...)))
+    ((_ (name proc) rest ...)
+     (cons (make-action 'name proc "[No documentation.]")
+           (actions rest ...)))
+    ((_)
+     '())))
+
+(define (default-service-termination-handler service process status)
+  "Handle the termination of @var{service} by respawning it if applicable.
+Log abnormal termination reported by @var{status}."
+  ;; NOTE this is used internally to SERVICE so it can be synchronous
+  (unless (zero? status)
+    ;; Most likely something went wrong; log it.
+    ;; TODO setup logging
+    (cond ((status:exit-val status)
+           =>
+           (lambda (code)
+             (local-output (l10n "Service ~a (PID ~a) exited with ~a.")
+                           ($ service 'canonical-name) ($ process 'id) code)))
+          ((status:term-sig status)
+           =>
+           (lambda (signal)
+             (local-output (l10n "Service ~a (PID ~a) terminated with signal 
~a.")
+                           ($ service 'canonical-name) ($ process 'id) 
signal)))
+          ((status:stop-sig status)
+           =>
+           (lambda (signal)
+             (local-output (l10n "Service ~a (PID ~a) stopped with signal ~a.")
+                           ($ service 'canonical-name) ($ process 'id) 
signal)))))
+
+  ($ service 'respawn))
+
+;; We don't want users to have to be aware of and use vats or actormaps when
+;; writing Shepherd configs, and we also want them to be able to use the same
+;; API they've been using. This format allows us to produce a thunk for 
spawning
+;; services as part of register-services so users don't have to worry about
+;; implementation details.
+(define* (service provision
+                  #:key
+                  (requirement '())
+                  (one-shot? #f)
+                  (transient? #f)
+                  (respawn? #f)
+                  ;; Delay in seconds (exact or inexact) before respawning a 
service.
+                  (respawn-limit (make-parameter 0.1))
+                  ;; Respawning CAR times in CDR seconds will disable the 
service.
+                  ;;
+                  ;; XXX: The terrible hack in (shepherd) using SIGALRM to 
work around
+                  ;; unreliable SIGCHLD delivery means that it might take up 
to 1 second for
+                  ;; SIGCHLD to be delivered.  Thus, arrange for the car to be 
lower than the
+                  ;; cdr.
+                  (respawn-delay (make-parameter '(5 . 7)))
+                  (start (lambda () #t))
+                  (stop (lambda (running) #f))
+                  (actions (actions))
+                  (termination-handler default-service-termination-handler)
+                  (documentation (l10n "[No description].")))
+  "Return a new service with the given @var{provision}, a list of symbols
+denoting what the service provides."
+  (match provision
+    (((? symbol?) ..1)
+     ;; XXX selfish-spawn-named does not exist yet
+     (selfish-spawn ^service provision requirement
+                    one-shot? transient? respawn? respawn-limit
+                    respawn-delay start stop actions
+                    termination-handler documentation))
+    (_ (raise-exception (&message "invalid service provision list")))))
+
+;; We combine a variety of functionality from across service.scm into this
+;; single actor. Optimally, anything operating on the old <service> record
+;; should be here. These are procedures starting with service- and most
+;; especially service-controller.
+;; Canonical list of what we need to replicate:
+;; - respawn-limit-hit? (this is not passed a service but uses data from 
inside one)
+;;   - 'respawn-limit-hit? method
+;; - default-service-termination-handle
+;;   - see procedure above
+;; - service record constructor
+;;   - see procedure immediately above
+;; - service record field accessors
+;;   - translated to methods, except control
+;; - service-controller methods:
+;;   - TODO
+(define-actor (^service bcom self provision requirement one-shot? transient?
+                        respawn? respawn-limit respawn-delay start stop actions
+                        termination-handler documentation)
+  "Constructor for an actor representing a system service/daemon"
+  ;; one of stopped, starting, running, or stopping
+  (define status (spawn ^cell 'stopped))
+  ;; XXX not sure what this is
+  ;; may be a <process> or pid but also other things?
+  (define running-value (spawn ^cell))
+  ;; list of respawn timestamps
+  (define respawn-times (spawn ^cell '()))
+  ;; list of recent startup failure timestamps
+  (define startup-failures (spawn ^cell '()))
+  ;; list of symbol/timestamp pairs representing recent state changes
+  ;; TODO use ring-buffer
+  (define status-changes (spawn ^cell '()))
+  ;; list of last exit statuses of main process, most recent first
+  ;; TODO use ring-buffer
+  (define process-exit-statuses (spawn ^cell '()))
+  ;; #t if this service is enabled, otherwise #f
+  (define enabled? (spawn ^cell))
+  ;; replacement for this service if there is one, else #f
+  (define replacement (spawn ^cell))
+  ;; logger for this service if there is one, else #f
+  ;; TODO implement as actor; for now just a list
+  ;; may be best to have this proxy service actor
+  ;; (unless we use Aurie for log?)
+  (define logger (spawn ^cell '()))
+  ;; file where log messages are stored, #f if none
+  ;; XXX logger should handle this
+  (define log-file (spawn ^cell))
+  (methods
+   ((provision) provision)
+   ((requirement) requirement)
+   ((one-shot?) one-shot?)
+   ((transient?) transient?)
+   ((respawn?) respawn?)
+   ((respawn-limit) respawn-limit)
+   ((respawn-limit-hit?)
+    "Return true of RESPAWNS, the list of times at which a given service was
+respawned, shows that it has been respawned more than TIMES in SECONDS."
+    (define now (current-time))
+    (define seconds (cdr respawn-limit))
+
+    ;; Note: This is O(TIMES), but TIMES is typically small.
+    (let loop ((times    (car respawn-limit))
+               (respawns ($ respawn-times)))
+      (match respawns
+        (()
+         #f)
+        ((last-respawn rest ...)
+         (or (zero? times)
+             (and (> (+ last-respawn seconds) now)
+                  (loop (- times 1) rest)))))))
+   ((respawn-delay) respawn-delay)
+   ((start) start)
+   ((stop) stop)
+   ((respawn)
+    (if (and respawn? (not ($ self 'respawn-limit-hit?)))
+        (begin
+          ;; Everything is okay, wait for a bit and restart it.
+          (sleep respawn-delay)
+          (local-output (l10n "Respawning ~a.")
+                        ($ self 'canonical-name))
+          ($ self 'record-respawn-time)
+          ;; XXX TODO
+          ($ self 'start-service))
+        (begin
+          (local-output (l10n "Service ~a has been disabled.")
+                        ($ self 'canonical-name))
+          (when respawn?
+            (local-output (l10n "  (Respawning too fast.)")))
+          ($ self 'disable)
+
+          (when transient?
+            ;; XXX TODO
+            ($ self 'unregister)
+            (local-output (l10n "Transient service ~a terminated, now 
unregistered.")
+                          ($ self 'canonical-name))))))
+   ((actions) actions)
+   ((termination-handler) termination-handler)
+   ;; TODO we could combine the docstrings of actions into our own at 
spawn-time
+   ((documentation) documentation)
+   ;; TODO make this a debug name?
+   ((canonical-name) (car provision))
+   ((running-value) ($ running-value))
+   ((status) ($ status))
+   ((status new-status)
+    ($ status new-status))
+   ((respawn-times) ($ respawn-times))
+   ((startup-failures) ($ startup-failures))
+   ((startup-failures new-time)
+    ($ startup-failures (cons new-time ($ startup-failures))))
+   ((status-changes) ($ status-changes))
+   ;; TODO generate timestamp ourself
+   ((status-changes new-status new-time)
+    ($ status-changes (cons (cons new-status new-time)
+                            ($ status-changes))))
+   ((process-exit-statuses) ($ process-exit-statuses))
+   ((process-exit-statuses status)
+    ($ process-exit-statuses (cons status ($ process-exit-statuses))))
+   ((enabled?) ($ enabled?))
+   ((replacement) ($ replacement))
+   ((replacement new) ($ replacement new))
+   ((logger) ($ logger))
+   ((recent-messages) #;($ ($ logger) 'recent-messages)
+    ($ logger))
+   ((log-file) ($ log-file))
+   ((log-file file) ($ log-file file))
+   ((enable) ($ enabled? #t))
+   ((disable) ($ enabled? #f))
+   ;; TODO
+   ((unregister) #t)
+   ((register-logger new-logger) ($ logger new-logger))
+   ((record-respawn-time new-time)
+    ($ respawn-times (cons new-time ($ respawn-times))))
+   ((running?) (not ($ self 'stopped?)))
+   ((stopped?) (eq? ($ status) 'stopped))
+   ;; TODO we should incorporate actions directly into service actors;
+   ;; see notes above
+   ((action-list) (map action-name actions))
+   ((lookup-action action)
+    (find (match-lambda
+            (($ <action> name)
+             (eq? name action)))
+          actions))
+   ((defines-action? action)
+    (and ($ self 'lookup-action action) #t))
+   ;; TODO
+   ((start-service . args)
+    #t
+    ;; WIP
+    ;; It is not running; go ahead and launch it.
+    ;; Resolve all dependencies.
+    ;; XXX need a cap on the registry to do this
+    ;; NOTE the registry is probably local, but requirements may not be
+    #;
+    "Start this service and its dependencies, passing @var{args} to 
@code{start} ; ;
+    methods.  Return its running value or @code{#f} on failure."
+    #;
+    (on (<- registry 'start-in-parallel ($ requirement)) ; ; ; ; ;
+    (lambda (problems)                  ; ; ; ; ;
+    (if (pair? problems)                ; ; ; ; ;
+    (on (all-of* (map (lambda (problem) ; ; ; ; ;
+    (<- problem 'canonical-name))       ; ; ; ; ;
+    problems))                          ; ; ; ; ;
+    (lambda (problem-names)             ; ; ; ; ;
+    (let ((self-name ($ self 'canonical-name))) ; ; ; ; ;
+    (for-each (lambda (name)            ; ; ; ; ;
+    (local-output (l10n "Service ~a depends on ~a.") ; ; ; ; ;
+    self-name name))                    ; ; ; ;
+    problems)                           ; ; ; ;
+    #f)))                               ; ; ; ;
+    ;; Start the service itself. ;      ; ; ;
+    (begin                              ; ; ; ;
+    (match ($ self 'start)              ; ; ; ;
+    (#f                                 ; ; ; ;
+    ;; We lost the race: SERVICE is already running. ; ; ; ;
+    ($ self 'running-value))            ; ; ; ;
+    ((? channel? notification)          ; ; ; ;
+    ;; We won the race: we're responsible for starting SERVICE ; ; ; ;
+    ;; and sending its running value on NOTIFICATION. ; ; ; ;
+    (let ((running                      ; ; ; ;
+    (catch #t                           ; ; ; ;
+    (lambda ()                          ; ; ; ;
+    ;; Make sure the 'start' method writes ; ; ; ;
+    ;; messages to the right port. ;    ; ; ;
+    (parameterize ((current-output-port ; ; ; ;
+    (%current-service-output-port))     ; ; ; ;
+    (current-error-port                 ; ; ; ;
+    (%current-service-output-port))     ; ; ; ;
+    (current-service service))          ; ; ; ;
+    (apply (service-start service) args))) ; ; ; ;
+    (lambda (key . args)                ; ; ; ;
+    (put-message notification #f)       ; ; ; ;
+    (report-exception 'start service key args))))) ; ; ; ;
+    (put-message notification running)  ; ; ; ;
+    (local-output (if running           ; ; ; ;
+    (l10n "Service ~a has been started.") ; ; ; ;
+    (l10n "Service ~a could not be started.")) ; ; ; ;
+    (service-canonical-name service))   ; ; ; ;
+    running))))))))
+   ;; TODO we want to change `stop-service' so that instead of checking for
+   ;; dependents and stopping them, we instead inform all the services we know
+   ;; about that a service is stopping and let them decide if they need to stop
+   ;;
+   ;; Rather than offer a direct reference to the stopping actor, we could
+   ;; either have a facet that only gives access to `provision' or, better yet,
+   ;; directly hand off `provision' for dependents to check themselves
+   ;;
+   ;; QUESTION: how do we handle the case of multiple active services providing
+   ;; the same thing, eg database? How does a dependent know it's depending on
+   ;; database-x instead of database-y if we have both in a network of 
machines?
+   ((required-by? dependent)
+    (on (<- dependent 'requirement)
+        (lambda (dependent-requirement)
+          (and (find (lambda (dependency)
+                       (memq dependency provision))
+                     dependent-requirement)
+               #t))
+        #:catch
+        (lambda (err)
+          (error "(<- ~a 'requirement) failed with error ~a"
+                 dependent err))))
+   ;; TODO
+   ((stop-service . args) #t)
+   ;; TODO
+   ((perform-action action . args) #t)
+   ((replace-if-running new-service)
+    (and (eq? ($ status) 'running)
+         (begin
+           (local-output (l10n "Recording replacement for ~a.")
+                         ($ self 'canonical-name))
+           ($ replacement new-service))
+         #t))
+   ;; TODO
+   ((display-documentation)
+    "A very cool and good service that does cool and good things :D")))
+
+;; XXX it may not be the right design to just port this as-is. we probably
+;; instead want to create a "remote registry" which is a facet of this and can
+;; be used with remote actors. otherwise we may end up with multiple
+;; registries holding onto the same capabilities with different
+;; understandings, eg the local registry knows a service has stopped but the
+;; remote registry does not so it hangs onto it in the "registered" vhash
+(define-actor (^service-registry bcom self)
+  "Construct an actor encapsulating Shepherd state (registered and running 
services)."
+  #:frozen
+  (define-pcell registered vlist-null) ;vhash with Symbol key and Service value
+  (define* (%register service provision
+                      #:optional (registered registered))
+    "Add @var{service} which provides @var{provision} to @var{registered}.
+Return @var{registered}."
+    ($ registered (fold (cut vhash-consq <> service <>)
+                        ($ registered)
+                        provision)))
+  (methods
+   ((unregister services)               ;no return
+    (on (all-of* (remove (lambda (service)
+                           ;; XXX I don't think this will work
+                           (<- service 'stopped?))
+                         services))
+        (match-lambda
+          (()
+           ;; Terminate the controller of each of SERVICES and return 
REGISTERED
+           ;; minus SERVICES.
+           (for-each (lambda (service)
+                       (<-np service 'terminate))
+                     services)
+           ($ registered (vhash-fold (lambda (name service result)
+                                       (if (memq service services)
+                                           result
+                                           (vhash-consq name service result)))
+                                     vlist-null
+                                     ($ registered))))
+          (running-services
+           ;; Inform the user that RUNNING-SERVICES are still running
+           (on (all-of* (map (lambda (service)
+                               (<- service 'canonical-name))
+                             running-services))
+               (lambda (running-service-names)
+                 (local-output
+                  (l10n "Cannot unregister service~{ ~a,~} which is still 
running"
+                        "Cannot unregister services~{ ~a,~} which are still 
running"
+                        (length running-service-names))
+                  running-service-names))
+               #:catch
+               (lambda (err)
+                 (error "Retrieving the 'canonical-names of ~a failed with 
error ~a"
+                        running-services err)))))
+        #:catch
+        (lambda (err)
+          (error "Removing 'stopped services from ~a failed with error ~a"
+                 services err))))
+   ((register service)                  ;no return
+    (pk 'registering-service service)
+    (on (<- service 'provision)
+        (lambda (provision)
+          (pk 'provision provision)
+          (match (any (lambda (name)
+                        (vhash-assq name ($ registered)))
+                      provision)
+            (#f (%register service provision))
+            ;; old is the first service whose canonical
+            ;; name is a symbol in provision
+            ((_ . old)
+             (on (<- old 'replace-if-running service)
+                 (lambda (replaced?)
+                   (unless replaced?
+                     (on (<- old 'enabled?)
+                         (lambda (enabled?)
+                           ;; Inherit the disabled flag.
+                           (unless enabled? (<-np service 'disable)))
+                         #:catch
+                         (lambda (err)
+                           (error "(<- ~a 'enabled?) failed with error ~a"
+                                  old err))))
+                   (%register service provision
+                              ($ self 'unregister (list old))))
+                 #:catch
+                 (lambda (err)
+                   (error "(<- ~a 'replace-if-running ~a) failed with error ~a"
+                          old service err))))))
+        #:catch
+        (lambda (err)
+          (error "(<- ~a 'provision) failed with error ~a" service err))))
+   ;; TODO
+   ((start-in-parallel services) #t)
+   ((lookup name)
+    ;; Look up NAME and return the associated Service, or #f
+    (match (vhash-assq name ($ registered))
+      (#f #f)
+      ((_ . service) service)))
+   ;; XXX hmmmmb... this needs to be referenced outside of here.
+   ;; two options:
+   ;; - current-service-registry parameter.
+   ;;   likely suboptimal beause ambient authority.
+   ;; - give each service a capability on its registry.
+   ;;   creates bidirectional authority. facets?
+   ((lookup* name)
+    (match ($ self 'lookup name)
+      (#f (raise-exception (make-missing-service-error (name name))))
+      (service service)))
+   ((service-list)
+    (vlist->list ($ registered)))
+   ((service-name-count)
+    (vlist-length ($ registered)))))
+
+(define register-services
+  (letrec ((warn-deprecated-form
+            ;; Up to 0.9.x, this procedure took a rest list.
+            (lambda ()
+              (issue-deprecation-warning
+               "Passing 'register-services' services a rest list is \
+now deprecated.")))
+           (list-of-symbols?
+            (lambda (obj)
+              (cond ((null? obj) #t)
+                   ((and (pair? obj)
+                         (symbol? (car obj)))
+                    (list-of-symbols? (cdr obj)))
+                   (else #f)))))
+    (case-lambda
+      ((services)
+       "Register @var{services} so that they can be looked up by name, for 
instance
+when resolving dependencies.
+
+Each name uniquely identifies one service.  If a service with a given name has
+already been registered, arrange to have it replaced when it is next stopped.
+If it is currently stopped, replace it immediately."
+       (define (register-single-service new)
+         ;; Ensure we receive the expected values.
+         ;; (assert (list-of-symbols? ($ new 'provision)))
+         ;; (assert (list-of-symbols? ($ new 'requirement)))
+         ;; (assert (boolean? ($ new 'respawn?)))
+
+         ($ (current-registry) 'register new))
+
+       (let ((services (if (not (list? services))
+                           (begin
+                             (warn-deprecated-form)
+                             (list services))
+                           services)))
+         (for-each register-single-service services)))
+      (services
+       (warn-deprecated-form)
+       (register-services services)))))
+
+;; TODO
+(define (make-forkexec-constructor args)
+  #t)
+
+(define default-process-termination-grace-period
+  ;; Default process termination "grace period" before we send SIGKILL.
+  (make-parameter 5))
+
+;; TODO
+(define* (make-kill-destructor #:optional (signal SIGTERM)
+                               #:key (grace-period
+                                      
(default-process-termination-grace-period)))
+  "Return a procedure that sends @var{signal} to the process group of the PID
+given as argument, where @var{signal} defaults to @code{SIGTERM}.  If the
+process is still running after @var{grace-period} seconds, send it
+@code{SIGKILL}.  The procedure returns once the process has terminated."
+  #t)
+
+(define shepherd-vat (spawn-vat #:name 'shepherd-vat))
+
+(define current-registry
+  (with-vat shepherd-vat
+    (make-parameter (selfish-spawn ^service-registry))))
+
+(with-vat shepherd-vat
+  (let ((cl (command-line)))
+    (if (> (length cl) 1)
+        (primitive-load* (cadr cl))
+        (primitive-load* (car cl)))
+    (let lp ()
+      (on (<- (current-registry) 'service-list)
+          (lambda (lst)
+            (format #t "Registered services: ~a~%" lst)))
+      (sleep 3) (lp))))