140 lines
5.1 KiB
Racket
140 lines
5.1 KiB
Racket
#lang syndicate
|
|
;; Extremely simple single-actor supervision
|
|
;; Vastly simplified compared to the available options in OTP
|
|
|
|
(provide supervise
|
|
supervise/spawn)
|
|
|
|
(require racket/exn)
|
|
(require "core.rkt")
|
|
(require "dataflow.rkt")
|
|
(require "hierarchy.rkt")
|
|
(require "store.rkt")
|
|
|
|
(require (submod "actor.rkt" implementation-details))
|
|
(require (for-syntax syntax/parse))
|
|
|
|
(require/activate "drivers/timestate.rkt")
|
|
|
|
(define-syntax (supervise stx)
|
|
(syntax-parse stx
|
|
[(_ name:actor-name expr ...)
|
|
(syntax/loc stx
|
|
(supervise* (lambda () name.N)
|
|
void
|
|
(lambda () expr ...)))]))
|
|
|
|
(define-syntax (supervise/spawn 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* (lambda () name-expr)
|
|
(lambda () linkage-expr ... (void))
|
|
(lambda () (spawn O ...))))]))
|
|
|
|
(define (supervise* supervisor-name-thunk linkage-thunk actor-producing-thunk)
|
|
;; Awkward: the name applies to any and all potential supervisors
|
|
;; produced by actor spawns in actor-producing-thunk.
|
|
(with-store [(current-action-transformer
|
|
(supervise-spawn supervisor-name-thunk linkage-thunk (current-action-transformer)))]
|
|
(actor-producing-thunk)))
|
|
|
|
(define ((supervise-spawn supervisor-name-thunk linkage-thunk previous-action-transformer) ac)
|
|
(match (previous-action-transformer ac)
|
|
[(? actor? s) (supervise** (or (supervisor-name-thunk) (gensym 'supervisor)) linkage-thunk s)]
|
|
[other other]))
|
|
|
|
(define (supervise** supervisor-name linkage-thunk supervisee-spawn-action)
|
|
(actor-action #:name supervisor-name
|
|
(react
|
|
(linkage-thunk) ;; may contain e.g. linkage instructions from during/spawn
|
|
|
|
(define root-supervisor-facet (current-facet-id))
|
|
|
|
(field [supervisee-name 'unknown])
|
|
|
|
(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 (current-inexact-milliseconds) (restarts))))
|
|
(when (> (length (restarts)) intensity)
|
|
(log-error "Supervised process ~s/~s ~a reached max restart intensity. Sleeping for ~a seconds"
|
|
supervisor-name
|
|
(supervisee-name)
|
|
(current-actor-path)
|
|
sleep-time)
|
|
(sleep sleep-time)))
|
|
|
|
(field [should-run? #f]
|
|
[ok? #f])
|
|
|
|
(on (rising-edge (not (ok?)))
|
|
(should-run? #f)
|
|
(ok? #t)
|
|
(retract! ?)
|
|
(flush!)
|
|
(should-run? #t))
|
|
|
|
(define (catch-exns thunk k)
|
|
(with-handlers ([(lambda (e) #t)
|
|
(lambda (e)
|
|
(log-error "Supervised process ~s/~s ~a died with exception:\n~a"
|
|
supervisor-name
|
|
(supervisee-name)
|
|
(current-actor-path)
|
|
(if (exn? e)
|
|
(exn->string e)
|
|
(format "~v" e)))
|
|
(add-restart!)
|
|
(ok? #f))])
|
|
(call-with-values thunk k)))
|
|
|
|
(on (rising-edge (should-run?))
|
|
(react (stop-when (rising-edge (not (should-run?))))
|
|
(field [proc #f])
|
|
|
|
(define (handle-transition! txn)
|
|
(match txn
|
|
[#f
|
|
;; N.B. TODO: Polling (event of #f) will never
|
|
;; reach the inner actor, since actor-behavior
|
|
;; doesn't bother executing anything if it is
|
|
;; given #f.
|
|
(void)]
|
|
[(<quit> _ acs)
|
|
(perform-actions! acs)
|
|
;; N.B. TODO: what to do with the exception
|
|
;; carried in the quit struct?
|
|
(stop-facet root-supervisor-facet)]
|
|
[(transition st acs)
|
|
(perform-actions! acs)
|
|
(proc (update-process-state (proc) st))]))
|
|
|
|
(on-start
|
|
(catch-exns
|
|
(lambda ()
|
|
(define-values (initial-proc initial-transition initial-assertions)
|
|
(actor->process+transition/assertions supervisee-spawn-action))
|
|
(proc initial-proc)
|
|
(supervisee-name (process-name initial-proc))
|
|
(patch! (patch initial-assertions trie-empty))
|
|
initial-transition)
|
|
handle-transition!))
|
|
|
|
(on-event
|
|
[e (when (proc)
|
|
(catch-exns
|
|
(lambda () ((process-behavior (proc)) e (process-state (proc))))
|
|
handle-transition!))]))))))
|