[shepherd] 04/15: scratch: Begin prototyping process monitoring.

[Juliana Sims]

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

commit 234dcad8e6499bc49039821a9275e182e7c5c1e0
Author: Juliana Sims <juli@incana.org>
AuthorDate: Thu Oct 10 09:19:20 2024 -0400

    scratch: Begin prototyping process monitoring.
    
    * scratch.scm: Begin prototyping process monitoring.
---
 scratch.scm | 164 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 164 insertions(+)

diff --git a/scratch.scm b/scratch.scm
index cda1b81..79d42d4 100644
--- a/scratch.scm
+++ b/scratch.scm
@@ -626,10 +626,174 @@ If it is currently stopped, replace it immediately."
 (define (make-forkexec-constructor args)
   #t)
 
+(define-actor (^process-monitor bcom)
+  "Run a process monitor that handles requests received over @var{channel}."
+  ;; WAITERS is a vhash of pid keys and channel values. we should be able to
+  ;; just return things directly to callers
+  (define-cell waiters vlist-null)
+  (methods
+   ((handle-process-termination pid status)
+    (let ((waiters-list ($ waiters)))
+      ;; Notify any waiters.
+      (vhash-foldv* (lambda (waiter _)
+                      (<-np waiter status)
+                      #t)
+                    #t pid waiters-list)
+
+      ;; XXX: The call below is linear in the size of WAITERS, but WAITERS is
+      ;; usually empty or small.
+      ($ waiters (vhash-fold (lambda (key value result)
+                               (if (= key pid)
+                                   result
+                                   (vhash-consv key value result)))
+                             vlist-null
+                             waiters-list))))
+   ((spawn arguments service)
+    ;; Spawn the command as specified by ARGUMENTS; send the spawn result
+    ;; (PID or exception) to REPLY; send its exit status to REPLY when it
+    ;; terminates.  This operation is atomic: the WAITERS table is updated
+    ;; before termination of PID can possibly be handled.
+    (let ((result (boxed-errors
+                   ;; Set 'current-service' so the logger for that process
+                   ;; can be attached to SERVICE.
+                   (parameterize ((current-service service))
+                     (apply fork+exec-command arguments)))))
+      (match result
+        (('exception . _) #f)
+        (('success (pid))
+         ($ waiters (vhash-consv pid reply ($ waiters)))))
+      result))
+   ((await pid)
+    ;; Await the termination of PID and return its status.
+    (if (and (catch-system-error (kill pid 0))
+             (not (pseudo-process? pid)))
+        ($ waiters (vhash-consv pid reply ($ waiters)))
+        0)))) ;PID is gone or a pseudo-process
+
+;; TODO
+(define spawn-process-monitor
+  (essential-task-launcher 'process-monitor process-monitor))
+
+(define current-process-monitor
+  ;; Channel to communicate with the process monitoring fiber.
+  (make-parameter #f))
+
+;; TODO: we probably just want to spawn process monitors
+;; inside the service actor
+(define (call-with-process-monitor thunk)
+  (parameterize ((current-process-monitor (spawn-process-monitor)))
+    (thunk)))
+
+(define-syntax-rule (with-process-monitor exp ...)
+  "Spawn a process monitoring fiber and evaluate @var{exp}... within that
+context.  The process monitoring fiber is responsible for handling
+@code{SIGCHLD} and generally dealing with process creation and termination."
+  (call-with-process-monitor (lambda () exp ...)))
+
+(define (start-command command . arguments)
+  "Start a process executing @var{command}, as per @code{fork+exec-command}, 
but
+immediately monitor its PID.  Return two values: its PID and a channel on
+which its completion status will be sent."
+  (assert (current-process-monitor))
+  (on (<- (current-process-monitor)
+          'spawn (cons command arguments) (current-service))
+      (lambda (result)
+        (unboxed-errors result))
+      #:catch
+      (lambda (err)
+        (error "(<- ~a 'spawn ~a ~a) failed with error ~a"
+               (current-process-monitor)
+               (cons command arguments)
+               (current-service)
+               err))
+      #:promise? #t))
+
+;; TODO
+;; (define spawn-command
+;;   (let ((warn-deprecated-form
+;;          ;; In 0.9.3, this procedure took a rest list.
+;;          (lambda ()
+;;            (issue-deprecation-warning
+;;             "This 'spawn-command' form is deprecated; use\
+;;  (spawn-command '(\"PROGRAM\" \"ARGS\"...))."))))
+;;     (case-lambda*
+;;      ((command #:key
+;;                (user #f)
+;;                (group #f)
+;;                (environment-variables (default-environment-variables))
+;;                (directory (default-service-directory))
+;;                (resource-limits '()))
+;;       "Like @code{system*}, spawn @var{command} (a list of strings) but do 
not block
+;; while waiting for @var{program} to terminate."
+;;       (let ((command (if (string? command)
+;;                          (begin
+;;                            (warn-deprecated-form)
+;;                            (list command))
+;;                          command)))
+;;         (if (current-process-monitor)
+;;             (spawn-via-monitor
+;;              (list command
+;;                    #:user user #:group group
+;;                    #:environment-variables environment-variables
+;;                    #:directory directory
+;;                    #:resource-limits resource-limits))
+;;             (let ((pid (fork+exec-command
+;;                         command
+;;                         #:user user #:group group
+;;                         #:environment-variables environment-variables
+;;                         #:directory directory
+;;                         #:resource-limits resource-limits)))
+;;               (match (waitpid pid)
+;;                 ((_ . status) status))))))
+;;      ((program . arguments)
+;;       ;; The old form, which appeared in 0.9.3.
+;;       (spawn-command (cons program arguments))))))
+
+(define (monitor-service-process notify pid)
+  "Monitor process @var{pid} and notify @var{service} when it terminates."
+  ;; NOTE: this procedure is only called inside service-controller and 
therefore
+  ;; we may be able to call it from inside the service actor. in that case, we
+  ;; pass in a facet capability to alert on the result
+  ;; TODO: implement above; notify is assumed to be said facet
+  (assert (current-process-monitor))
+  (on (<- (current-process-monitor) 'await pid)
+      (lambda (status)
+        (<-np notify pid status))
+      #:catch
+      (lambda (err)
+        (error "(<- ~a 'await ~a) failed with error ~a"
+               (current-process-monitor) pid err))))
+
 (define default-process-termination-grace-period
   ;; Default process termination "grace period" before we send SIGKILL.
   (make-parameter 5))
 
+(define* (terminate-process pid signal
+                            #:key (grace-period
+                                   (default-process-termination-grace-period)))
+  "Send @var{signal} to @var{pid}, which can be negative to denote a process
+group; wait for @var{pid} to terminate and return its exit status.  If
+@var{pid} is still running @var{grace-period} seconds after @var{signal} has
+been sent, send it @code{SIGKILL}."
+  ;; TODO: implement grace-period support
+  (assert (current-process-monitor))
+  (catch-system-error (kill pid signal))
+  (on (<- (current-process-monitor) 'await (abs pid))
+      (lambda (status)
+        (if status
+            status
+            (begin
+              (local-output
+               (l10n "Grace period of ~a seconds is over; sending ~a SIGKILL.")
+               grace-period pid)
+              (catch-system-error (kill pid SIGKILL))
+              0)))
+      #:catch
+      (lambda (err)
+        (error "(<- ~a 'await ~a) failed with error ~a"
+               (current-process-monitor) (abs pid) err))
+      #:promise? #t))
+
 ;; TODO
 (define* (make-kill-destructor #:optional (signal SIGTERM)
                                #:key (grace-period