78 lines
2.7 KiB
Racket
78 lines
2.7 KiB
Racket
;;; 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!))))
|