Simple supervision

syndicate/supervise.rkt

@@ -0,0 +1,36 @@
+#lang syndicate
+;;; SPDX-License-Identifier: LGPL-3.0-or-later
+;;; SPDX-FileCopyrightText: Copyright © 2024 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
+
+(provide supervise
+         supervise*
+
+         default-restart-strategy)
+
+(require syndicate/driver-support)
+
+(define-logger syndicate/supervise)
+
+(define-syntax-rule (supervise (main-proc-name arg ...))
+  (supervise* 'main-proc-name (lambda () (main-proc-name arg ...))))
+
+(define (supervise* main-proc-name main-proc
+                    #:restart-strategy [restart-strategy (default-restart-strategy)])
+  (log-syndicate/supervise-info "supervisor starting ~a" main-proc-name)
+  (react
+    (on-stop
+     (when (facet-live? this-facet)
+       (log-syndicate/supervise-info "supervisor noticed exit of ~a" main-proc-name)
+       (restart-strategy
+        (lambda ([new-strategy restart-strategy])
+          (supervise* main-proc-name main-proc #:restart-strategy new-strategy)))))
+    (spawn/link #:name (list 'supervised main-proc-name) (main-proc))))
+
+(define ((default-restart-strategy [timeout-seconds 5] [plus-or-minus 1]) restart)
+  (react
+    (linked-thread
+     (lambda (facet)
+       (define t (+ timeout-seconds (* plus-or-minus (- (random) 0.5) 2)))
+       (log-syndicate/supervise-debug "restarting in ~v seconds" t)
+       (sleep t)
+       (turn! facet (lambda () (on-stop (restart))))))))