syndicate shutdown ...

boring.rkt

#lang syndicate

(require racket/set)
(require/activate syndicate/drivers/external-event)

(provide shutdown!)

(define-logger top)

(define log-receiver
  (make-log-receiver top-logger 'debug))

(spawn #:name "log-receiver"
       (stop-when (asserted (stop 'log-receiver)))
       (on (message (inbound (external-event log-receiver (list $log))))
           (match log
             [(vector level message _ _)
              (printf "[~a] ~a~%" level message)])))

(assertion-struct shutdown (ch))
(assertion-struct stop (name))
(assertion-struct stopped (name))
(define shutdown-ch* (make-channel))
(define (shutdown!)
  (define ch (make-channel))
  (channel-put shutdown-ch* ch)
  (channel-get ch))

(spawn #:name "shutdown-handler"
       (on-start
        (log-top-info "starting"))
       (on (message (inbound (external-event shutdown-ch* (list $ack-ch))))
           (assert! (shutdown ack-ch)))
       (during
        (shutdown $ack-ch)
        (define/query-value pending-shutdown
          (set 'server 'client)
          (stopped $who)
          (set-remove (pending-shutdown) who)
          #:on-add
          (log-top-info "saw stopped: ~a" who))
        (begin/dataflow
          (log-top-info "actors pending: ~a" (pending-shutdown)))
        (stop-when-true
         (set-empty? (pending-shutdown))
         (channel-put ack-ch #t))
        (on-start
         (log-top-info "channel shutdown received")
         (assert! (stop 'server))
         (assert! (stop 'client)))))

(define-logger server #:parent top-logger)
(spawn #:name "server"
       (stop-when (asserted (stop 'server))
                  (react (assert (stopped 'server)))
                  (log-server-warning "stopped"))
       (on-stop
        (log-server-warning "shutting down")))

(define-logger client #:parent top-logger)
(spawn #:name "client"
       (stop-when (asserted (stop 'client))
                  (react (assert (stopped 'client)))
                  (log-client-warning "stopped"))
       (on-stop
        (log-client-warning "shutting down")))

main.rkt

#lang racket/base

(require (only-in (submod "boring.rkt" syndicate-main)
                  activate!)
         (only-in "boring.rkt" shutdown!)
         (only-in syndicate/ground
                  run-ground)
         (only-in syndicate/lang
                  current-activated-modules
                  current-ground-dataspace))

(define syndicate-thd
  (thread
   (lambda ()
     (parameterize ([current-ground-dataspace run-ground]
                    [current-activated-modules (make-hasheq)])
       ((current-ground-dataspace) activate!)))))

(with-handlers* ([exn:break? (lambda (e) (shutdown!))])
  (thread-wait syndicate-thd))