juli pushed a commit to branch wip-goblinsify in repository shepherd. commit 0d6f2473db28f183bf6863cc5e44dc98149af4eb Author: Juliana Sims <j...@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