[shepherd] 07/17: scratch: First pass at service startup code.

[Juliana Sims]

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

commit 5ad348d3f33f6d5e5134cf1e4fa444d3f24135eb
Author: Juliana Sims <juli@incana.org>
AuthorDate: Thu Oct 10 09:19:22 2024 -0400

    scratch: First pass at service startup code.
    
    This code hasn't been tested.
    
    * scratch.scm (^service)[start]: Combine start and start-service into one
    method, write initial code for it.
---
 scratch.scm | 120 ++++++++++++++++++++++++++++++------------------------------
 1 file changed, 60 insertions(+), 60 deletions(-)

diff --git a/scratch.scm b/scratch.scm
index d80846b..3a908d9 100644
--- a/scratch.scm
+++ b/scratch.scm
@@ -271,8 +271,8 @@ denoting what the service provides."
                         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))
+  ;; either running or stopped
+  (define-pcell running?)
   ;; XXX not sure what this is
   ;; may be a <process> or pid but also other things?
   (define running-value (spawn ^cell))
@@ -287,7 +287,7 @@ denoting what the service provides."
   ;; TODO use ring-buffer
   (define process-exit-statuses (spawn ^cell '()))
   ;; #t if this service is enabled, otherwise #f
-  (define enabled? (spawn ^cell))
+  (define-pcell enabled?)
   ;; replacement for this service if there is one, else #f
   (define replacement (spawn ^cell))
   ;; logger for this service if there is one, else #f
@@ -320,7 +320,61 @@ denoting what the service provides."
              (and (> (+ last-respawn seconds) now)
                   (loop (- times 1) rest)))))))
    ((respawn-delay) respawn-delay)
-   ((start) start)
+   ((start . args)
+    (if ($ enabled?)
+        ;; Resolve all dependencies.
+        ;; XXX need a cap on the registry to do this
+        ;; alternatively, we could reword dependency management so that instead
+        ;; of a list of symbols, it's a list of actors. this seems inadvisable
+        ;; NOTE the registry is probably local, but requirements may not be
+        (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)))
+                  ;; Service is not running; go ahead and launch it.
+                  ;; NOTE because we're using Goblins and combining the
+                  ;; service-controller and service actors, we don't need the
+                  ;; statuses starting and stopping. This allows us to collapse
+                  ;; two match statements with multiple clauses into this
+                  (and (not ($ running?))
+                       (begin
+                         ;; Become the one that starts SERVICE.
+                         (local-output (l10n "Starting service ~a...")
+                                       ($ self 'canonical-name))
+                         (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 self))
+                                      (apply start args)))
+                                  (lambda (key . args)
+                                    (report-exception 'start self key args)
+                                    #f))))
+                           (local-output (if running
+                                             (l10n "Service ~a has been 
started.")
+                                             (l10n "Service ~a could not be 
started."))
+                                         ($ self 'canonical-name))
+                           ;; TODO mimic update-status-changes
+                           ;; XXX this changes behavior, returning a boolean
+                           ;; rather than a symbol
+                           ($ running? running)))))))
+        ;; Return #f
+        (not (local-output (l10n "Service ~a is currently disabled.")
+                           ($ self 'canonical-name)))))
    ((stop) stop)
    ((respawn)
     (if (and respawn? (not ($ self 'respawn-limit-hit?)))
@@ -381,8 +435,8 @@ denoting what the service provides."
    ((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))
+   ((running?) ($ running?))
+   ((stopped?) (not ($ running?)))
    ;; TODO we should incorporate actions directly into service actors;
    ;; see notes above
    ((action-list) (map action-name actions))
@@ -393,60 +447,6 @@ denoting what the service provides."
           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