Reimplement supervise.rkt to use spawn->process+transition at each reboot.
This commit is contained in:
Tony Garnock-Jones
parent
726b936ed3
commit
8cd60417c4
|
|
@ -5,7 +5,10 @@
|
|||
(require/activate syndicate/drivers/timestate)
|
||||
|
||||
(supervise
|
||||
#:name 'ward-supervisor
|
||||
(actor #:name 'ward
|
||||
(on-start (log-info "Starting ward"))
|
||||
(on-stop (log-info "Stopping ward"))
|
||||
(on (message 'crash)
|
||||
(log-info "Crashing")
|
||||
(error 'ward "Eep!"))
|
||||
|
|
|
|||
|
|
@ -11,162 +11,112 @@
|
|||
(require "store.rkt")
|
||||
|
||||
(require (submod "actor.rkt" implementation-details))
|
||||
(require (for-syntax syntax/parse))
|
||||
|
||||
(require/activate "drivers/timestate.rkt")
|
||||
|
||||
(define-syntax-rule (supervise expr ...)
|
||||
(supervise* (lambda () expr ...)))
|
||||
(define-syntax (supervise stx)
|
||||
(syntax-parse stx
|
||||
[(_ name:actor-name expr ...)
|
||||
(syntax/loc stx
|
||||
(supervise* #:name name.N (lambda () expr ...)))]))
|
||||
|
||||
(define (supervise* actor-producing-thunk)
|
||||
(with-store [(current-action-transformer (supervise-spawn (current-action-transformer)))]
|
||||
(define (supervise* #:name [supervisor-name #f] 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 (current-action-transformer)))]
|
||||
(actor-producing-thunk)))
|
||||
|
||||
(define ((supervise-spawn previous-action-transformer) ac)
|
||||
(define ((supervise-spawn supervisor-name previous-action-transformer) ac)
|
||||
(match (previous-action-transformer ac)
|
||||
[(? spawn? s) (supervise** s)]
|
||||
[(? spawn? s) (supervise** supervisor-name s)]
|
||||
[other other]))
|
||||
|
||||
(define (supervise** s)
|
||||
(make-spawn (lambda ()
|
||||
;; TODO: Consider closing supervisor-main over s
|
||||
;; rather than over st0 and acs. That way, effects
|
||||
;; from spawn->process+transition will reappear at
|
||||
;; each reboot.
|
||||
;;
|
||||
;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
;; BUG: Exception thrown inside
|
||||
;; spawn->process+transition will kill the supervisor!
|
||||
;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||||
;;
|
||||
(define-values (proc initial-transition) (spawn->process+transition s))
|
||||
(match initial-transition
|
||||
[(transition st0 acs)
|
||||
(list actor-behavior
|
||||
(boot-actor (lambda ()
|
||||
(react
|
||||
(supervisor-main proc st0 acs))))
|
||||
(list 'supervised (process-name proc)))]
|
||||
[other
|
||||
(list (process-behavior proc)
|
||||
other
|
||||
(list 'supervised (process-name proc)))]))))
|
||||
(define (supervise** supervisor-name supervisee-spawn-action)
|
||||
(actor-action #:name supervisor-name
|
||||
(react
|
||||
|
||||
(define (supervisor-main proc boot-state boot-actions)
|
||||
(field [done? #f])
|
||||
(stop-when (rising-edge (done?)))
|
||||
(field [done? #f])
|
||||
(stop-when (rising-edge (done?)))
|
||||
|
||||
(field [should-run? #f]
|
||||
[ready? #f])
|
||||
(field [supervisee-name 'unknown])
|
||||
|
||||
(define inner-handle-event (process-behavior proc))
|
||||
(define intensity 1)
|
||||
(define period 5000) ;; milliseconds
|
||||
(define sleep-time 10) ;; seconds
|
||||
(field [restarts '()])
|
||||
|
||||
(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)))
|
||||
|
||||
(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 ~v ~a reached max restart intensity. Sleeping for ~a seconds"
|
||||
(process-name proc)
|
||||
(current-actor-path)
|
||||
sleep-time)
|
||||
(sleep sleep-time)))
|
||||
(field [should-run? #f]
|
||||
[ok? #f])
|
||||
|
||||
(on (rising-edge (not (ready?)))
|
||||
(should-run? #f)
|
||||
(retract! ?)
|
||||
(flush!)
|
||||
(should-run? #t))
|
||||
(on (rising-edge (not (ok?)))
|
||||
(should-run? #f)
|
||||
(ok? #t)
|
||||
(retract! ?)
|
||||
(flush!)
|
||||
(should-run? #t))
|
||||
|
||||
(on (rising-edge (should-run?))
|
||||
(react (stop-when (rising-edge (not (should-run?))))
|
||||
(field [inner-state boot-state])
|
||||
(on-start (perform-actions! boot-actions)
|
||||
(ready? #t))
|
||||
(on-event
|
||||
[e (with-handlers ([(lambda (exn) #t)
|
||||
(lambda (e)
|
||||
(log-error "Supervised process ~v ~a died with exception:\n~a"
|
||||
(process-name proc)
|
||||
(current-actor-path)
|
||||
(if (exn? e)
|
||||
(exn->string e)
|
||||
(format "~v" e)))
|
||||
(add-restart!)
|
||||
(ready? #f))])
|
||||
(match (inner-handle-event e (inner-state))
|
||||
[#f (void)] ;; 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.
|
||||
[(<quit> _ acs) (perform-actions! acs) (done? #t)]
|
||||
;; N.B. TODO: what to do with the exception carried
|
||||
;; in the quit struct?
|
||||
[(transition st acs) (perform-actions! acs) (inner-state st)]))]))))
|
||||
(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)))
|
||||
|
||||
;; BROKENish APPROACH: See uni.org (search for 30048bda-b5c2-11e6-afe4-73eb3e5180cc)
|
||||
(on (rising-edge (should-run?))
|
||||
(react (stop-when (rising-edge (not (should-run?))))
|
||||
(field [proc #f])
|
||||
|
||||
;; (define (supervisor-main proc boot-state boot-actions)
|
||||
;; (field [done? #f])
|
||||
;; (stop-when (rising-edge (done?)))
|
||||
(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?
|
||||
(done? #t)]
|
||||
[(transition st acs)
|
||||
(perform-actions! acs)
|
||||
(proc (update-process-state (proc) st))]))
|
||||
|
||||
;; (log-info "ORIGINAL: ~v ~v" (process-name proc) boot-state)
|
||||
(on-start
|
||||
(catch-exns
|
||||
(lambda ()
|
||||
(define-values (initial-proc initial-transition)
|
||||
(spawn->process+transition supervisee-spawn-action))
|
||||
(proc initial-proc)
|
||||
(supervisee-name (process-name initial-proc))
|
||||
initial-transition)
|
||||
handle-transition!))
|
||||
|
||||
;; (define inner-handle-event (process-behavior proc))
|
||||
;; (field [inner-state boot-state] [running? #t])
|
||||
;; (on-start (perform-actions! boot-actions))
|
||||
;; (define (reboot!)
|
||||
;; (log-info "--------------------------------------------------")
|
||||
;; (running? #f)
|
||||
;; (retract! ?)
|
||||
;; ;; (flush!)
|
||||
;; (inner-state boot-state)
|
||||
;; (log-info "--------------------------------------------------")
|
||||
;; (running? #t)
|
||||
;; (log-info "REBOOT: ~v ~v" (process-name proc) boot-state)
|
||||
;; (perform-actions! boot-actions))
|
||||
|
||||
;; (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 ~v ~a reached max restart intensity. Sleeping for ~a seconds"
|
||||
;; (process-name proc)
|
||||
;; (current-actor-path)
|
||||
;; sleep-time)
|
||||
;; (sleep sleep-time)))
|
||||
|
||||
;; (on-event [e (when (running?)
|
||||
;; (with-handlers ([(lambda (exn) #t)
|
||||
;; (lambda (e)
|
||||
;; (log-error "Supervised process ~v ~a died with exception:\n~a"
|
||||
;; (process-name proc)
|
||||
;; (current-actor-path)
|
||||
;; (if (exn? e)
|
||||
;; (exn->string e)
|
||||
;; (format "~v" e)))
|
||||
;; (add-restart!)
|
||||
;; (reboot!))])
|
||||
;; (match (inner-handle-event e (inner-state))
|
||||
;; [#f (void)] ;; 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.
|
||||
;; [(<quit> _ acs) (perform-actions! acs) (done? #t)]
|
||||
;; ;; N.B. TODO: what to do with the exception carried
|
||||
;; ;; in the quit struct?
|
||||
;; [(transition st acs) (perform-actions! acs) (inner-state st)])))]))
|
||||
(on-event
|
||||
[e (when (proc)
|
||||
(catch-exns
|
||||
(lambda () ((process-behavior (proc)) e (process-state (proc))))
|
||||
handle-transition!))]))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue