From 8cd60417c42d2d2c46d3e17533f261c94c26d09e Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 29 Nov 2016 14:47:22 +1300 Subject: [PATCH] Reimplement supervise.rkt to use spawn->process+transition at each reboot. --- .../examples/actor/example-supervise.rkt | 3 + racket/syndicate/supervise.rkt | 228 +++++++----------- 2 files changed, 92 insertions(+), 139 deletions(-) diff --git a/racket/syndicate/examples/actor/example-supervise.rkt b/racket/syndicate/examples/actor/example-supervise.rkt index a934ba7..3eb2ccf 100644 --- a/racket/syndicate/examples/actor/example-supervise.rkt +++ b/racket/syndicate/examples/actor/example-supervise.rkt @@ -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!")) diff --git a/racket/syndicate/supervise.rkt b/racket/syndicate/supervise.rkt index 1426508..3dfb3de 100644 --- a/racket/syndicate/supervise.rkt +++ b/racket/syndicate/supervise.rkt @@ -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. - [( _ 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)] + [( _ 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. -;; [( _ 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!))]))))))