;;; SPDX-License-Identifier: LGPL-3.0-or-later
;;; SPDX-FileCopyrightText: Copyright © 2010-2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>

#lang syndicate
;; Extremely simple single-actor supervision
;; Vastly simplified compared to the available options in OTP

(provide (struct-out supervisor)
         supervise)

(require racket/exn)

(require (for-syntax syntax/parse))
(require "syntax-classes.rkt")
(require "reflection.rkt")

(require/activate syndicate/drivers/timer)

(define-logger syndicate/supervise)

(assertion-struct supervisor (id name))

(define-syntax (supervise stx)
  (syntax-parse stx
    [(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f])
                        #:name "#:name")
             (~optional (~seq #:linkage [linkage-expr ...]) #:defaults ([(linkage-expr 1) '()])
                        #:name "#:linkage"))
        ...
        O ...)
     (syntax/loc stx
       (supervise* name-expr
                   (lambda () linkage-expr ... (void))
                   (lambda () O ...)))]))

(define (supervise* name0 linkage-thunk root-facet-thunk)
  (define id (gensym 'supervisor))
  (define name (or name0 (gensym 'supervisee)))
  (spawn #:name (supervisor id name)
         #:linkage [(linkage-thunk)] ;; may contain e.g. linkage instructions from during/spawn

         (assert (supervisor id name))

         (define root-supervisor-facet (current-facet))

         (define intensity 1)
         (define period 5000) ;; milliseconds
         (define sleep-time 10) ;; seconds
         (field [restarts '()])

         (define (add-restart!)
           (define now (current-inexact-milliseconds))
           (define oldest-to-keep (- now period))
           (restarts (filter (lambda (r) (>= r oldest-to-keep)) (cons now (restarts))))
           (when (> (length (restarts)) intensity)
             (log-syndicate/supervise-error
              "Supervised process ~s reached max restart intensity. Sleeping for ~a seconds"
              name
              sleep-time)
             (sleep sleep-time)))

         (define (start-supervisee!)
           (spawn #:name name
                  (stop-when (retracted (supervisor id name)))
                  (root-facet-thunk)))

         (on (message (terminated name $reason))
             (when reason
               (log-syndicate/supervise-error "Supervised process ~s died" name)
               ;; (log-syndicate/supervise-error
               ;;  "Supervised process ~s died with exception:\n~a"
               ;;  name
               ;;  (if (exn? reason) (exn->string reason) (format "~v" reason)))
               (add-restart!)
               (start-supervisee!)))

         (on-start (start-supervisee!))))