[shepherd] 09/17: scratch: Return demo to working state.

[Juliana Sims]

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

commit 958f3052b516cb52479ec04cf2ccc4d9b79d636b
Author: Juliana Sims <juli@incana.org>
AuthorDate: Thu Oct 10 09:19:24 2024 -0400

    scratch: Return demo to working state.
    
    * scratch.scm: Return demo to working state.
---
 goblins-port-manifest.scm |   8 +-
 scratch.scm               | 185 ++++++++++++++++++++++++----------------------
 2 files changed, 100 insertions(+), 93 deletions(-)

diff --git a/goblins-port-manifest.scm b/goblins-port-manifest.scm
index f1de292..26cfa46 100644
--- a/goblins-port-manifest.scm
+++ b/goblins-port-manifest.scm
@@ -27,7 +27,7 @@
 
 (define guile-git
   (let ((rev "0")
-        (commit "b2cc237a02dcb13625885e76df28bc254a522100"))
+        (commit "d0790d766bedf08fb65231eff53f6c8044eb94f1"))
     (package
       (inherit guile-3.0)
       (name "guile-git")
@@ -40,7 +40,7 @@
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "13qv73c6w8gc5f7zx05f3jagaid078x0khwai43whr0513011hbg"))))
+                  "16z5qq281swvm666hyh7j38lnxzjxkkvzwsqbayzmlypy1vj1al2"))))
       (native-inputs
        (modify-inputs (package-native-inputs guile-3.0)
          (prepend autoconf
@@ -76,7 +76,7 @@
 
 (define guile-goblins-git
   (let ((rev "0")
-        (commit "203d710a8af13af2b894a9bac711df8e800af708"))
+        (commit "949eb9ec3e24d78fd98e69bce530ea75b9c04b38"))
     (package
       (inherit guile-goblins)
       (name "guile-goblins-git")
@@ -89,7 +89,7 @@
                 (file-name (git-file-name name version))
                 (sha256
                  (base32
-                  "0qwh46fn3p9hv8jqa86mins5j30b93g9aflk8maf27x5g304m3vs"))))
+                  "0ycs7sm4kkd21415f4pmqbl89isnjyanybiqjk0yzx0ih78l9801"))))
       (propagated-inputs
        (modify-inputs (package-propagated-inputs guile-goblins)
          (replace "guile-fibers" guile-fibers-git)))
diff --git a/scratch.scm b/scratch.scm
index 3a908d9..5b488a9 100644
--- a/scratch.scm
+++ b/scratch.scm
@@ -275,29 +275,29 @@ denoting what the service provides."
   (define-pcell running?)
   ;; XXX not sure what this is
   ;; may be a <process> or pid but also other things?
-  (define running-value (spawn ^cell))
+  (define-cell running-value)
   ;; list of respawn timestamps
-  (define respawn-times (spawn ^cell '()))
+  (define-cell respawn-times '())
   ;; list of recent startup failure timestamps
-  (define startup-failures (spawn ^cell '()))
+  (define-cell startup-failures '())
   ;; list of symbol/timestamp pairs representing recent state changes
   ;; TODO use ring-buffer
-  (define status-changes (spawn ^cell '()))
+  (define-cell status-changes '())
   ;; list of last exit statuses of main process, most recent first
   ;; TODO use ring-buffer
-  (define process-exit-statuses (spawn ^cell '()))
+  (define-cell process-exit-statuses '())
   ;; #t if this service is enabled, otherwise #f
   (define-pcell enabled?)
   ;; replacement for this service if there is one, else #f
-  (define replacement (spawn ^cell))
+  (define-cell replacement)
   ;; 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 '()))
+  (define-cell logger '())
   ;; file where log messages are stored, #f if none
   ;; XXX logger should handle this
-  (define log-file (spawn ^cell))
+  (define-cell log-file)
   (methods
    ((provision) provision)
    ((requirement) requirement)
@@ -321,60 +321,62 @@ denoting what the service provides."
                   (loop (- times 1) rest)))))))
    ((respawn-delay) respawn-delay)
    ((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)))))
+    #t
+    #;
+    (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?)))
@@ -385,7 +387,7 @@ denoting what the service provides."
                         ($ self 'canonical-name))
           ($ self 'record-respawn-time)
           ;; XXX TODO
-          ($ self 'start-service))
+          ($ self 'start))
         (begin
           (local-output (l10n "Service ~a has been disabled.")
                         ($ self 'canonical-name))
@@ -405,18 +407,19 @@ denoting what the service provides."
    ;; TODO make this a debug name?
    ((canonical-name) (car provision))
    ((running-value) ($ running-value))
-   ((status) ($ status))
-   ((status new-status)
-    ($ status new-status))
+   ;; XXX changes to start deprecated status property
+   ;; ((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))))
+   ;; ((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))))
@@ -476,7 +479,7 @@ denoting what the service provides."
    ;; TODO
    ((perform-action action . args) #t)
    ((replace-if-running new-service)
-    (and (eq? ($ status) 'running)
+    (and ($ running?)
          (begin
            (local-output (l10n "Recording replacement for ~a.")
                          ($ self 'canonical-name))
@@ -495,7 +498,7 @@ denoting what the service provides."
 (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-cell 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}.
@@ -542,10 +545,8 @@ Return @var{registered}."
           (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)
@@ -684,8 +685,8 @@ If it is currently stopped, replace it immediately."
         0)))) ;PID is gone or a pseudo-process
 
 ;; TODO
-(define spawn-process-monitor
-  (essential-task-launcher 'process-monitor process-monitor))
+;; (define spawn-process-monitor
+;;   (essential-task-launcher 'process-monitor process-monitor))
 
 (define current-process-monitor
   ;; Channel to communicate with the process monitoring fiber.
@@ -817,17 +818,23 @@ 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 shepherd-vat
+  (spawn-vat #:name 'shepherd-vat #:log? #t))
 
 (define current-registry
-  (with-vat shepherd-vat
-    (make-parameter (selfish-spawn ^service-registry))))
-
-(with-vat shepherd-vat
-  (let ((cl (command-line)))
-    (primitive-load* ((if (> (length cl) 1) cadr car) cl))
-    (let lp ()
-      (on (<- (current-registry) 'service-list)
-          (lambda (lst)
-            (format #t "Registered services: ~a~%" lst)))
-      (sleep 3) (lp))))
+  (make-parameter (with-vat shepherd-vat (selfish-spawn ^service-registry))))
+
+(let* ((args (command-line))
+       (len (length args)))
+  (match (command-line)
+    ((_ file)
+     (with-vat shepherd-vat
+       (primitive-load* file))
+     (with-vat shepherd-vat
+       (on (<- (current-registry) 'service-list)
+           (lambda (lst)
+             (format #t "Registered services: ~a~%" lst))
+           #:catch
+           (lambda (err)
+             (error (format #f "Got error ~a" err))))))
+    (_ (format (current-error-port) "Please provide exactly one file.~%"))))