Update to new syntax (documentation not yet updated and does not build)
This commit is contained in:
parent
b1438317aa
commit
1f5b8d8251
|
@ -7,27 +7,24 @@
|
|||
|
||||
(: event-relay : (All (ParentState) Symbol -> (Spawn ParentState)))
|
||||
(define (event-relay self-id)
|
||||
(spawn: #:debug-name `(event-relay ,self-id)
|
||||
#:parent : ParentState
|
||||
#:child : Void
|
||||
(transition/no-state
|
||||
(endpoint: : Void
|
||||
#:publisher (cons ? ?) #:observer
|
||||
#:conversation (cons (? evt? e) _)
|
||||
#:on-presence (begin
|
||||
(printf "SUBSCRIBED ~v~n" e)
|
||||
(flush-output)
|
||||
(at-meta-level
|
||||
(endpoint: : Void
|
||||
#:subscriber (cons e ?)
|
||||
#:name `(event-relay ,self-id ,e)
|
||||
[msg
|
||||
(begin
|
||||
(printf "FIRED ~v -> ~v~n" e msg)
|
||||
(flush-output)
|
||||
(send-message msg))])))
|
||||
#:on-absence (begin
|
||||
(printf "UNSUBSCRIBED ~v~n" e)
|
||||
(flush-output)
|
||||
(at-meta-level
|
||||
(delete-endpoint `(event-relay ,self-id ,e))))))))
|
||||
(name-process `(event-relay ,self-id)
|
||||
(spawn: #:parent : ParentState
|
||||
#:child : Void
|
||||
(transition/no-state
|
||||
(observe-publishers: Void (cons ? ?)
|
||||
(match-conversation (cons (? evt? e) _)
|
||||
(on-presence (begin
|
||||
(printf "SUBSCRIBED ~v~n" e)
|
||||
(flush-output)
|
||||
(at-meta-level: Void
|
||||
(name-endpoint `(event-relay ,self-id ,e)
|
||||
(subscribe-to-topic: Void (cons e ?)
|
||||
(on-message
|
||||
[msg (begin (printf "FIRED ~v -> ~v~n" e msg)
|
||||
(flush-output)
|
||||
(send-message msg))]))))))
|
||||
(on-absence (begin
|
||||
(printf "UNSUBSCRIBED ~v~n" e)
|
||||
(flush-output)
|
||||
(at-meta-level: Void
|
||||
(delete-endpoint `(event-relay ,self-id ,e)))))))))))
|
||||
|
|
|
@ -26,50 +26,52 @@
|
|||
(define any-listener (tcp-listener (wild)))
|
||||
|
||||
(define (tcp-driver)
|
||||
(spawn #:debug-name 'tcp-driver
|
||||
#:child
|
||||
(transition (set)
|
||||
(endpoint #:subscriber (tcp-channel any-listener any-remote (wild)) #:everything
|
||||
#:state active-handles
|
||||
#:role r
|
||||
#:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
|
||||
#:on-absence (maybe-forget-socket r active-handles))
|
||||
(endpoint #:publisher (tcp-channel any-remote any-listener (wild)) #:everything
|
||||
#:state active-handles
|
||||
#:role r
|
||||
#:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
|
||||
#:on-absence (maybe-forget-socket r active-handles))
|
||||
(endpoint #:subscriber (tcp-channel any-handle any-remote (wild)) #:observer
|
||||
#:state active-handles
|
||||
#:role r
|
||||
#:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
|
||||
#:on-absence (maybe-forget-socket r active-handles))
|
||||
(endpoint #:publisher (tcp-channel any-remote any-handle (wild)) #:observer
|
||||
#:state active-handles
|
||||
#:role r
|
||||
#:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
|
||||
#:on-absence (maybe-forget-socket r active-handles)))))
|
||||
(name-process 'tcp-driver
|
||||
(spawn
|
||||
(transition (set)
|
||||
(observe-publishers/everything (tcp-channel any-listener any-remote (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation c
|
||||
(on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
|
||||
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
|
||||
(observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation c
|
||||
(on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
|
||||
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))
|
||||
(observe-publishers (tcp-channel any-handle any-remote (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation c
|
||||
(on-presence
|
||||
(maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
|
||||
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
|
||||
(observe-subscribers (tcp-channel any-handle any-remote (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation c
|
||||
(on-presence
|
||||
(maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager))
|
||||
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))))))
|
||||
|
||||
(define tcp (tcp-driver)) ;; pre-instantiated!
|
||||
|
||||
(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun)
|
||||
(match r
|
||||
[(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
|
||||
(role 'subscriber (tcp-channel remote-addr local-addr _) _))
|
||||
(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
|
||||
(match (list orientation c)
|
||||
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
|
||||
(list 'subscriber (tcp-channel remote-addr local-addr _)))
|
||||
(cond
|
||||
[(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
|
||||
[(not (ground? local-addr)) (transition active-handles)]
|
||||
[(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
|
||||
[else
|
||||
(transition (set-add active-handles (cons local-addr remote-addr))
|
||||
(spawn #:debug-name (cons local-addr remote-addr)
|
||||
#:child (driver-fun local-addr remote-addr)))])]))
|
||||
(name-process (cons local-addr remote-addr)
|
||||
(spawn (driver-fun local-addr remote-addr))))])]))
|
||||
|
||||
;; Role Set<HandleMapping> -> Transition
|
||||
(define (maybe-forget-socket r active-handles)
|
||||
(match r
|
||||
[(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
|
||||
(role 'subscriber (tcp-channel remote-addr local-addr _) _))
|
||||
;; Orientation Topic Set<HandleMapping> -> Transition
|
||||
(define (maybe-forget-socket orientation c active-handles)
|
||||
(match (list orientation c)
|
||||
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
|
||||
(list 'subscriber (tcp-channel remote-addr local-addr _)))
|
||||
(cond
|
||||
[(ground? remote-addr) (transition active-handles)]
|
||||
[(not (ground? local-addr)) (transition active-handles)]
|
||||
|
@ -80,40 +82,40 @@
|
|||
(match-define (tcp-listener port) local-addr)
|
||||
(define listener (tcp:tcp-listen port 4 #t))
|
||||
|
||||
(define (handle-absence r state)
|
||||
(define (handle-absence orientation c state)
|
||||
;; Hey, what if the presence we need went away between our manager
|
||||
;; spawning us, and us getting to this point? Presence being
|
||||
;; "edge-" rather than "level-triggered" means we'll hang around
|
||||
;; sadly forever, accepting connections to nowhere. TODO
|
||||
(match r
|
||||
[(or (role 'publisher (tcp-channel (== local-addr) remote-addr _) _)
|
||||
(role 'subscriber (tcp-channel remote-addr (== local-addr) _) _))
|
||||
(match (list orientation c)
|
||||
[(or (list 'publisher (tcp-channel (== local-addr) remote-addr _))
|
||||
(list 'subscriber (tcp-channel remote-addr (== local-addr) _)))
|
||||
(if (ground? remote-addr)
|
||||
(transition state)
|
||||
(transition 'listener-is-closed
|
||||
(quit)
|
||||
(when (eq? state 'listener-is-running)
|
||||
(spawn #:debug-name (list 'tcp-listener-closer local-addr)
|
||||
#:child
|
||||
(begin (tcp:tcp-close listener)
|
||||
(transition 'dummy (quit)))))))]))
|
||||
(name-process (list 'tcp-listener-closer local-addr)
|
||||
(spawn (begin (tcp:tcp-close listener)
|
||||
(transition 'dummy (quit))))))))]))
|
||||
|
||||
(transition 'listener-is-running
|
||||
(endpoint #:subscriber (tcp-channel local-addr any-remote (wild)) #:everything
|
||||
#:state state
|
||||
#:role r
|
||||
#:on-absence (handle-absence r state))
|
||||
(endpoint #:publisher (tcp-channel any-remote local-addr (wild)) #:everything
|
||||
#:state state
|
||||
#:role r
|
||||
#:on-absence (handle-absence r state))
|
||||
(endpoint #:subscriber (cons (tcp:tcp-accept-evt listener) (wild))
|
||||
[(cons _ (list cin cout))
|
||||
(let-values (((local-hostname local-port remote-hostname remote-port)
|
||||
(tcp:tcp-addresses cin #t)))
|
||||
(define remote-addr (tcp-address remote-hostname remote-port))
|
||||
(spawn #:debug-name (cons local-addr remote-addr)
|
||||
#:child (tcp-connection-manager* local-addr remote-addr cin cout)))])))
|
||||
(observe-publishers/everything (tcp-channel local-addr any-remote (wild))
|
||||
(match-state state
|
||||
(match-conversation c
|
||||
(on-absence (handle-absence 'publisher c state)))))
|
||||
(observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
|
||||
(match-state state
|
||||
(match-conversation c
|
||||
(on-absence (handle-absence 'subscriber c state)))))
|
||||
(subscribe-to-topic (cons (tcp:tcp-accept-evt listener) (wild))
|
||||
(on-message
|
||||
[(cons _ (list cin cout))
|
||||
(let-values (((local-hostname local-port remote-hostname remote-port)
|
||||
(tcp:tcp-addresses cin #t)))
|
||||
(define remote-addr (tcp-address remote-hostname remote-port))
|
||||
(name-process (cons local-addr remote-addr)
|
||||
(spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
|
||||
|
||||
;; TcpAddress TcpAddress -> Transition
|
||||
(define (tcp-connection-manager local-addr remote-addr)
|
||||
|
@ -142,33 +144,35 @@
|
|||
(when is-open
|
||||
(list (when send-eof?
|
||||
(send-message (tcp-channel remote-addr local-addr eof)))
|
||||
(spawn #:debug-name (list 'tcp-connection-closer local-addr remote-addr)
|
||||
#:child
|
||||
(begin (tcp:tcp-abandon-port cin)
|
||||
(tcp:tcp-abandon-port cout)
|
||||
(transition/no-state (quit))))))
|
||||
(name-process (list 'tcp-connection-closer local-addr remote-addr)
|
||||
(spawn (begin (tcp:tcp-abandon-port cin)
|
||||
(tcp:tcp-abandon-port cout)
|
||||
(transition/no-state (quit)))))))
|
||||
(quit)))
|
||||
|
||||
(transition #t ;; open
|
||||
(endpoint #:subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
|
||||
#:state is-open
|
||||
[(cons _ (? eof-object?)) (close-transition is-open #t)]
|
||||
[(cons _ (? bytes? bs)) (transition is-open (send-message (tcp-channel remote-addr local-addr bs)))])
|
||||
(endpoint #:subscriber (cons (eof-evt cin) (wild))
|
||||
#:state is-open
|
||||
[(cons (? evt?) _) (close-transition is-open #t)])
|
||||
(endpoint #:subscriber (tcp-channel local-addr remote-addr (wild))
|
||||
#:state is-open
|
||||
#:on-absence (close-transition is-open #f)
|
||||
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
|
||||
(match subpacket
|
||||
[(? eof-object?) (close-transition is-open #f)]
|
||||
[(? string? s) (begin (write-string s cout)
|
||||
(flush-output cout)
|
||||
(transition is-open))]
|
||||
[(? bytes? bs) (begin (write-bytes bs cout)
|
||||
(flush-output cout)
|
||||
(transition is-open))])])
|
||||
(endpoint #:publisher (tcp-channel remote-addr local-addr (wild))
|
||||
#:state is-open
|
||||
#:on-absence (close-transition is-open #f))))
|
||||
(subscribe-to-topic (cons (read-bytes-avail-evt 4096 cin) (wild))
|
||||
(match-state is-open
|
||||
(on-message
|
||||
[(cons _ (? eof-object?)) (close-transition is-open #t)]
|
||||
[(cons _ (? bytes? bs)) (transition is-open
|
||||
(send-message (tcp-channel remote-addr local-addr bs)))])))
|
||||
(subscribe-to-topic (cons (eof-evt cin) (wild))
|
||||
(match-state is-open
|
||||
(on-message [(cons (? evt?) _) (close-transition is-open #t)])))
|
||||
(subscribe-to-topic (tcp-channel local-addr remote-addr (wild))
|
||||
(match-state is-open
|
||||
(on-absence (close-transition is-open #f))
|
||||
(on-message
|
||||
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
|
||||
(match subpacket
|
||||
[(? eof-object?) (close-transition is-open #f)]
|
||||
[(? string? s) (begin (write-string s cout)
|
||||
(flush-output cout)
|
||||
(transition is-open))]
|
||||
[(? bytes? bs) (begin (write-bytes bs cout)
|
||||
(flush-output cout)
|
||||
(transition is-open))])])))
|
||||
(publish-on-topic (tcp-channel remote-addr local-addr (wild))
|
||||
(match-state is-open
|
||||
(on-absence (close-transition is-open #f))))))
|
||||
|
|
|
@ -81,49 +81,51 @@
|
|||
;; Spawn
|
||||
;; Process acting as a TCP socket factory.
|
||||
(define (tcp-driver)
|
||||
(spawn #:debug-name 'tcp-driver
|
||||
#:child
|
||||
(transition (set)
|
||||
(endpoint #:subscriber (tcp-channel any-listener any-remote (wild)) #:everything
|
||||
#:state active-handles
|
||||
#:role r
|
||||
#:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
|
||||
#:on-absence (maybe-forget-socket r active-handles))
|
||||
(endpoint #:publisher (tcp-channel any-remote any-listener (wild)) #:everything
|
||||
#:state active-handles
|
||||
#:role r
|
||||
#:on-presence (maybe-spawn-socket r active-handles #f tcp-listener-manager)
|
||||
#:on-absence (maybe-forget-socket r active-handles))
|
||||
(endpoint #:subscriber (tcp-channel any-handle any-remote (wild)) #:observer
|
||||
#:state active-handles
|
||||
#:role r
|
||||
#:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
|
||||
#:on-absence (maybe-forget-socket r active-handles))
|
||||
(endpoint #:publisher (tcp-channel any-remote any-handle (wild)) #:observer
|
||||
#:state active-handles
|
||||
#:role r
|
||||
#:on-presence (maybe-spawn-socket r active-handles #t tcp-connection-manager)
|
||||
#:on-absence (maybe-forget-socket r active-handles)))))
|
||||
(name-process 'tcp-driver
|
||||
(spawn
|
||||
(transition (set)
|
||||
(observe-publishers/everything (tcp-channel any-listener any-remote (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation c
|
||||
(on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
|
||||
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
|
||||
(observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation c
|
||||
(on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
|
||||
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))
|
||||
(observe-publishers (tcp-channel any-handle any-remote (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation c
|
||||
(on-presence
|
||||
(maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
|
||||
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
|
||||
(observe-subscribers (tcp-channel any-remote any-handle (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation c
|
||||
(on-presence
|
||||
(maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager))
|
||||
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))))))
|
||||
|
||||
;; Role Set<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
|
||||
(define (maybe-spawn-socket r active-handles remote-should-be-ground driver-fun)
|
||||
(match r
|
||||
[(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
|
||||
(role 'subscriber (tcp-channel remote-addr local-addr _) _))
|
||||
;; Orientation Topic Set<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
|
||||
(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
|
||||
(match (list orientation c)
|
||||
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
|
||||
(list 'subscriber (tcp-channel remote-addr local-addr _)))
|
||||
(cond
|
||||
[(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
|
||||
[(not (ground? local-addr)) (transition active-handles)]
|
||||
[(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
|
||||
[else
|
||||
(transition (set-add active-handles (cons local-addr remote-addr))
|
||||
(spawn #:debug-name (cons local-addr remote-addr)
|
||||
#:child (driver-fun local-addr remote-addr)))])]))
|
||||
(name-process (cons local-addr remote-addr)
|
||||
(spawn (driver-fun local-addr remote-addr))))])]))
|
||||
|
||||
;; Role Set<HandleMapping> -> Transition
|
||||
(define (maybe-forget-socket r active-handles)
|
||||
(match r
|
||||
[(or (role 'publisher (tcp-channel local-addr remote-addr _) _)
|
||||
(role 'subscriber (tcp-channel remote-addr local-addr _) _))
|
||||
;; Orientation Topic Set<HandleMapping> -> Transition
|
||||
(define (maybe-forget-socket orientation c active-handles)
|
||||
(match (list orientation c)
|
||||
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
|
||||
(list 'subscriber (tcp-channel remote-addr local-addr _)))
|
||||
(cond
|
||||
[(ground? remote-addr) (transition active-handles)]
|
||||
[(not (ground? local-addr)) (transition active-handles)]
|
||||
|
@ -134,40 +136,40 @@
|
|||
(match-define (tcp-listener port) local-addr)
|
||||
(define listener (tcp:tcp-listen port 4 #t))
|
||||
|
||||
(define (handle-absence r state)
|
||||
(define (handle-absence orientation c state)
|
||||
;; Hey, what if the presence we need went away between our manager
|
||||
;; spawning us, and us getting to this point? Presence being
|
||||
;; "edge-" rather than "level-triggered" means we'll hang around
|
||||
;; sadly forever, accepting connections to nowhere. TODO
|
||||
(match r
|
||||
[(or (role 'publisher (tcp-channel (== local-addr) remote-addr _) _)
|
||||
(role 'subscriber (tcp-channel remote-addr (== local-addr) _) _))
|
||||
(match (list orientation c)
|
||||
[(or (list 'publisher (tcp-channel (== local-addr) remote-addr _))
|
||||
(list 'subscriber (tcp-channel remote-addr (== local-addr) _)))
|
||||
(if (ground? remote-addr)
|
||||
(transition state)
|
||||
(transition 'listener-is-closed
|
||||
(quit)
|
||||
(when (eq? state 'listener-is-running)
|
||||
(spawn #:debug-name (list 'tcp-listener-closer local-addr)
|
||||
#:child
|
||||
(begin (tcp:tcp-close listener)
|
||||
(transition 'dummy (quit)))))))]))
|
||||
(name-process (list 'tcp-listener-closer local-addr)
|
||||
(spawn (begin (tcp:tcp-close listener)
|
||||
(transition 'dummy (quit))))))))]))
|
||||
|
||||
(transition 'listener-is-running
|
||||
(endpoint #:subscriber (tcp-channel local-addr any-remote (wild)) #:everything
|
||||
#:state state
|
||||
#:role r
|
||||
#:on-absence (handle-absence r state))
|
||||
(endpoint #:publisher (tcp-channel any-remote local-addr (wild)) #:everything
|
||||
#:state state
|
||||
#:role r
|
||||
#:on-absence (handle-absence r state))
|
||||
(endpoint #:subscriber (cons (tcp:tcp-accept-evt listener) (wild))
|
||||
[(cons _ (list cin cout))
|
||||
(let-values (((local-hostname local-port remote-hostname remote-port)
|
||||
(tcp:tcp-addresses cin #t)))
|
||||
(define remote-addr (tcp-address remote-hostname remote-port))
|
||||
(spawn #:debug-name (cons local-addr remote-addr)
|
||||
#:child (tcp-connection-manager* local-addr remote-addr cin cout)))])))
|
||||
(observe-publishers/everything (tcp-channel local-addr any-remote (wild))
|
||||
(match-state state
|
||||
(match-conversation c
|
||||
(on-absence (handle-absence 'publisher c state)))))
|
||||
(observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
|
||||
(match-state state
|
||||
(match-conversation c
|
||||
(on-absence (handle-absence 'subscriber c state)))))
|
||||
(subscribe-to-topic (cons (tcp:tcp-accept-evt listener) (wild))
|
||||
(on-message
|
||||
[(cons _ (list cin cout))
|
||||
(let-values (((local-hostname local-port remote-hostname remote-port)
|
||||
(tcp:tcp-addresses cin #t)))
|
||||
(define remote-addr (tcp-address remote-hostname remote-port))
|
||||
(name-process (cons local-addr remote-addr)
|
||||
(spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
|
||||
|
||||
;; TcpAddress TcpAddress -> Transition
|
||||
(define (tcp-connection-manager local-addr remote-addr)
|
||||
|
@ -185,11 +187,10 @@
|
|||
(when (not (eq? state #f))
|
||||
(list (when send-eof?
|
||||
(send-message (tcp-channel remote-addr local-addr eof)))
|
||||
(spawn #:debug-name (list 'tcp-connection-closer local-addr remote-addr)
|
||||
#:child
|
||||
(begin (tcp:tcp-abandon-port cin)
|
||||
(tcp:tcp-abandon-port cout)
|
||||
(transition 'dummy (quit))))))
|
||||
(name-process (list 'tcp-connection-closer local-addr remote-addr)
|
||||
(spawn(begin (tcp:tcp-abandon-port cin)
|
||||
(tcp:tcp-abandon-port cout)
|
||||
(transition 'dummy (quit)))))))
|
||||
(quit)))
|
||||
(define (adjust-credit state amount)
|
||||
(let ((new-credit (+ (tcp-connection-state-credit state) amount)))
|
||||
|
@ -198,56 +199,62 @@
|
|||
(when (positive? new-credit)
|
||||
(case (tcp-connection-state-mode state)
|
||||
[(lines)
|
||||
(endpoint #:subscriber (cons (read-bytes-line-evt cin 'any) (wild))
|
||||
#:name 'inbound-relay
|
||||
#:state state
|
||||
[(cons _ (? eof-object?))
|
||||
(close-transition state #t)]
|
||||
[(cons _ (? bytes? bs))
|
||||
(sequence-actions (adjust-credit state -1)
|
||||
(send-message (tcp-channel remote-addr local-addr bs)))])]
|
||||
(name-endpoint 'inbound-relay
|
||||
(subscribe-to-topic (cons (read-bytes-line-evt cin 'any) (wild))
|
||||
(match-state state
|
||||
(on-message
|
||||
[(cons _ (? eof-object?))
|
||||
(close-transition state #t)]
|
||||
[(cons _ (? bytes? bs))
|
||||
(sequence-actions (adjust-credit state -1)
|
||||
(send-message (tcp-channel remote-addr local-addr bs)))]))))]
|
||||
[(bytes)
|
||||
(endpoint #:subscriber (cons (read-bytes-evt new-credit cin) (wild))
|
||||
#:name 'inbound-relay
|
||||
#:state state
|
||||
[(cons _ (? eof-object?))
|
||||
(close-transition state #t)]
|
||||
[(cons _ (? bytes? bs))
|
||||
(let ((len (bytes-length bs)))
|
||||
(sequence-actions (adjust-credit state (- len))
|
||||
(send-message (tcp-channel remote-addr local-addr bs))))])])))))
|
||||
(name-endpoint 'inbound-relay
|
||||
(subscribe-to-topic (cons (read-bytes-evt new-credit cin) (wild))
|
||||
(match-state state
|
||||
(on-message
|
||||
[(cons _ (? eof-object?))
|
||||
(close-transition state #t)]
|
||||
[(cons _ (? bytes? bs))
|
||||
(let ((len (bytes-length bs)))
|
||||
(sequence-actions (adjust-credit state (- len))
|
||||
(send-message
|
||||
(tcp-channel remote-addr local-addr bs))))]))))])))))
|
||||
(transition (tcp-connection-state 'bytes 0)
|
||||
(endpoint #:subscriber (cons (eof-evt cin) (wild))
|
||||
#:state state
|
||||
[(cons (? evt?) _)
|
||||
(close-transition state #t)])
|
||||
(endpoint #:subscriber (tcp-channel local-addr remote-addr (wild))
|
||||
#:state state
|
||||
#:on-absence (close-transition state #f)
|
||||
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
|
||||
(match subpacket
|
||||
[(? eof-object?) (close-transition state #f)]
|
||||
[(? bytes? bs)
|
||||
(define len (bytes-length bs))
|
||||
(write-bytes bs cout)
|
||||
(flush-output cout)
|
||||
(transition state (send-tcp-credit local-addr remote-addr len))]
|
||||
[_
|
||||
(error 'tcp-connection-manager*
|
||||
"Publisher on a channel isn't supposed to issue channel control messages")])])
|
||||
(endpoint #:publisher (tcp-channel remote-addr local-addr (wild))
|
||||
#:state state
|
||||
#:on-absence (close-transition state #f)
|
||||
[(tcp-channel (== remote-addr) (== local-addr) subpacket)
|
||||
(match subpacket
|
||||
[(tcp-credit amount)
|
||||
(if state (adjust-credit state amount) (transition state))]
|
||||
[(tcp-mode new-mode)
|
||||
;; Also resets credit to zero.
|
||||
(if state (adjust-credit (tcp-connection-state new-mode 0) 0) (transition state))]
|
||||
[_
|
||||
(error 'tcp-connection-manager*
|
||||
"Subscriber on a channel may only send channel control messages")])])))
|
||||
(subscribe-to-topic (cons (eof-evt cin) (wild))
|
||||
(match-state state
|
||||
(on-message
|
||||
[(cons (? evt?) _)
|
||||
(close-transition state #t)])))
|
||||
(subscribe-to-topic (tcp-channel local-addr remote-addr (wild))
|
||||
(match-state state
|
||||
(on-absence (close-transition state #f))
|
||||
(on-message
|
||||
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
|
||||
(match subpacket
|
||||
[(? eof-object?) (close-transition state #f)]
|
||||
[(? bytes? bs)
|
||||
(define len (bytes-length bs))
|
||||
(write-bytes bs cout)
|
||||
(flush-output cout)
|
||||
(transition state (send-tcp-credit local-addr remote-addr len))]
|
||||
[_
|
||||
(error 'tcp-connection-manager*
|
||||
"Publisher on a channel isn't supposed to issue channel control messages")])])))
|
||||
(publish-on-topic (tcp-channel remote-addr local-addr (wild))
|
||||
(match-state state
|
||||
(on-absence (close-transition state #f))
|
||||
(on-message
|
||||
[(tcp-channel (== remote-addr) (== local-addr) subpacket)
|
||||
(match subpacket
|
||||
[(tcp-credit amount)
|
||||
(if state (adjust-credit state amount) (transition state))]
|
||||
[(tcp-mode new-mode)
|
||||
;; Also resets credit to zero.
|
||||
(if state (adjust-credit (tcp-connection-state new-mode 0) 0) (transition state))]
|
||||
[_
|
||||
(error 'tcp-connection-manager*
|
||||
"Subscriber on a channel may only send channel control messages")])])))))
|
||||
|
||||
;; Spawn
|
||||
;; Debugging aid: produces pretty hex dumps of TCP traffic sent on
|
||||
|
@ -271,8 +278,7 @@
|
|||
(write `(TCPOTHER ,other)) (newline)
|
||||
(void)]))
|
||||
|
||||
(spawn #:debug-name 'tcp-spy
|
||||
#:child
|
||||
(transition 'no-state
|
||||
(endpoint #:subscriber (wild) #:observer [m (display-message m)])
|
||||
(endpoint #:publisher (wild) #:observer [m (display-message m)]))))
|
||||
(name-process 'tcp-spy
|
||||
(spawn (transition 'no-state
|
||||
(observe-publishers (wild) (on-message [m (display-message m)]))
|
||||
(observe-subscribers (wild) (on-message [m (display-message m)]))))))
|
||||
|
|
|
@ -148,18 +148,18 @@
|
|||
;; events and back.
|
||||
(: timer-driver : (All (ParentState) -> (Spawn ParentState)))
|
||||
(define (timer-driver)
|
||||
(spawn: #:debug-name 'timer-driver
|
||||
#:parent : ParentState
|
||||
#:child : DriverState
|
||||
(transition: (driver-state (make-timer-heap)) : DriverState
|
||||
(endpoint: state : DriverState
|
||||
#:subscriber (set-timer-pattern (wild) (wild) (wild))
|
||||
[(set-timer label msecs 'relative)
|
||||
(install-timer! state label (+ (current-inexact-milliseconds) msecs))]
|
||||
[(set-timer label msecs 'absolute)
|
||||
(install-timer! state label msecs)])
|
||||
(endpoint: : DriverState
|
||||
#:publisher (timer-expired-pattern (wild) (wild))))))
|
||||
(name-process 'timer-driver
|
||||
(spawn: #:parent : ParentState
|
||||
#:child : DriverState
|
||||
(transition: (driver-state (make-timer-heap)) : DriverState
|
||||
(subscribe-to-topic: DriverState (set-timer-pattern (wild) (wild) (wild))
|
||||
(match-state state
|
||||
(on-message
|
||||
[(set-timer label msecs 'relative)
|
||||
(install-timer! state label (+ (current-inexact-milliseconds) msecs))]
|
||||
[(set-timer label msecs 'absolute)
|
||||
(install-timer! state label msecs)])))
|
||||
(publish-on-topic: DriverState (timer-expired-pattern (wild) (wild)))))))
|
||||
|
||||
(: install-timer! : DriverState TimerLabel Real -> (Transition DriverState))
|
||||
(define (install-timer! state label deadline)
|
||||
|
@ -172,42 +172,44 @@
|
|||
(transition: state : DriverState
|
||||
(delete-endpoint 'time-listener)
|
||||
(and next
|
||||
(endpoint: state : DriverState
|
||||
#:subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
|
||||
#:name 'time-listener
|
||||
[(cons (? evt?) (? real? now))
|
||||
(let ((to-send (fire-timers! (driver-state-heap state) now)))
|
||||
;; Note: compute to-send before recursing, because of side-effects on heap
|
||||
(sequence-actions (transition: state : DriverState)
|
||||
update-time-listener!
|
||||
to-send))]))))
|
||||
(name-endpoint 'time-listener
|
||||
(subscribe-to-topic: DriverState (cons (timer-evt (pending-timer-deadline next)) (wild))
|
||||
(match-state state
|
||||
(on-message
|
||||
[(cons (? evt?) (? real? now))
|
||||
(let ((to-send (fire-timers! (driver-state-heap state) now)))
|
||||
;; Note: compute to-send before recursing, because of side-effects on heap
|
||||
(sequence-actions (transition: state : DriverState)
|
||||
update-time-listener!
|
||||
to-send))])))))))
|
||||
|
||||
;; Process for mapping this-level timer requests to meta-level timer
|
||||
;; requests. Useful when running nested VMs: essentially extends timer
|
||||
;; support up the branches of the VM tree toward the leaves.
|
||||
(: timer-relay : (All (ParentState) Symbol -> (Spawn ParentState)))
|
||||
(define (timer-relay self-id)
|
||||
(spawn: #:debug-name `(timer-relay ,self-id)
|
||||
#:parent : ParentState
|
||||
#:child : RelayState
|
||||
(transition: (relay-state 0 (make-immutable-hash '())) : RelayState
|
||||
(at-meta-level
|
||||
(endpoint: (relay-state next-counter active-timers) : RelayState
|
||||
#:subscriber (timer-expired-pattern (wild) (wild))
|
||||
[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
|
||||
now)
|
||||
(transition: (relay-state next-counter (hash-remove active-timers counter))
|
||||
: RelayState
|
||||
(and (hash-has-key? active-timers counter)
|
||||
(send-message (timer-expired (hash-ref active-timers counter)
|
||||
now))))]))
|
||||
(endpoint: (relay-state next-counter active-timers) : RelayState
|
||||
#:subscriber (set-timer-pattern (wild) (wild) (wild))
|
||||
[(set-timer label msecs kind)
|
||||
(transition: (relay-state (+ next-counter 1)
|
||||
(hash-set active-timers next-counter label))
|
||||
: RelayState
|
||||
(at-meta-level: : RelayState
|
||||
(send-message (set-timer (list self-id next-counter) msecs kind))))])
|
||||
(endpoint: : RelayState
|
||||
#:publisher (timer-expired-pattern (wild) (wild))))))
|
||||
(name-process `(timer-relay ,self-id)
|
||||
(spawn: #:parent : ParentState
|
||||
#:child : RelayState
|
||||
(transition: (relay-state 0 (make-immutable-hash '())) : RelayState
|
||||
(at-meta-level: RelayState
|
||||
(subscribe-to-topic: RelayState (timer-expired-pattern (wild) (wild))
|
||||
(match-state (relay-state next-counter active-timers)
|
||||
(on-message
|
||||
[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
|
||||
now)
|
||||
(transition: (relay-state next-counter (hash-remove active-timers counter))
|
||||
: RelayState
|
||||
(and (hash-has-key? active-timers counter)
|
||||
(send-message (timer-expired (hash-ref active-timers counter)
|
||||
now))))]))))
|
||||
(subscribe-to-topic: RelayState (set-timer-pattern (wild) (wild) (wild))
|
||||
(match-state (relay-state next-counter active-timers)
|
||||
(on-message
|
||||
[(set-timer label msecs kind)
|
||||
(transition: (relay-state (+ next-counter 1)
|
||||
(hash-set active-timers next-counter label))
|
||||
: RelayState
|
||||
(at-meta-level: RelayState
|
||||
(send-message (set-timer (list self-id next-counter) msecs kind))))])))
|
||||
(publish-on-topic: RelayState (timer-expired-pattern (wild) (wild)))))))
|
||||
|
|
|
@ -133,41 +133,38 @@
|
|||
(transition: (set-add active-handles local-addr) : DriverState
|
||||
(udp-socket-manager local-addr))]))
|
||||
|
||||
(spawn: #:debug-name 'udp-driver
|
||||
#:parent : ParentState
|
||||
#:child : DriverState
|
||||
(transition: ((inst set UdpLocalAddress)) : DriverState
|
||||
(endpoint: active-handles : DriverState
|
||||
#:publisher
|
||||
(udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
|
||||
#:observer
|
||||
#:conversation topic
|
||||
#:on-presence (handle-presence topic active-handles))
|
||||
(endpoint: active-handles : DriverState
|
||||
#:publisher
|
||||
(udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
|
||||
#:observer
|
||||
#:conversation topic
|
||||
#:on-presence (handle-presence topic active-handles))
|
||||
(endpoint: active-handles : DriverState
|
||||
#:subscriber
|
||||
(udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
|
||||
#:observer
|
||||
#:conversation topic
|
||||
#:on-presence (handle-presence topic active-handles))
|
||||
(endpoint: active-handles : DriverState
|
||||
#:subscriber
|
||||
(udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
|
||||
#:observer
|
||||
#:conversation topic
|
||||
#:on-presence (handle-presence topic active-handles))
|
||||
(endpoint: active-handles : DriverState
|
||||
#:subscriber (handle-mapping-pattern (wild) (wild))
|
||||
#:observer
|
||||
#:conversation (handle-mapping local-addr socket)
|
||||
#:on-absence
|
||||
(transition: (set-remove active-handles local-addr) : DriverState))
|
||||
)))
|
||||
(name-process 'udp-driver
|
||||
(spawn: #:parent : ParentState
|
||||
#:child : DriverState
|
||||
(transition: ((inst set UdpLocalAddress)) : DriverState
|
||||
|
||||
(observe-subscribers: DriverState
|
||||
(udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation topic
|
||||
(on-presence (handle-presence topic active-handles)))))
|
||||
(observe-subscribers: DriverState
|
||||
(udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation topic
|
||||
(on-presence (handle-presence topic active-handles)))))
|
||||
(observe-publishers: DriverState
|
||||
(udp-packet-pattern any-remote (udp-handle-pattern (wild)) (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation topic
|
||||
(on-presence (handle-presence topic active-handles)))))
|
||||
(observe-publishers: DriverState
|
||||
(udp-packet-pattern any-remote (udp-listener-pattern (wild)) (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation topic
|
||||
(on-presence (handle-presence topic active-handles)))))
|
||||
|
||||
(observe-publishers: DriverState (handle-mapping-pattern (wild) (wild))
|
||||
(match-state active-handles
|
||||
(match-conversation (handle-mapping local-addr socket)
|
||||
(on-absence
|
||||
(transition: (set-remove active-handles local-addr) : DriverState)))))
|
||||
))))
|
||||
|
||||
(: bind-socket! : UDP-Socket UdpLocalAddress -> Void)
|
||||
(define (bind-socket! s local-addr)
|
||||
|
@ -192,43 +189,46 @@
|
|||
(transition: #f : SocketManagerState
|
||||
(quit)
|
||||
(when socket-is-open?
|
||||
(spawn: #:debug-name `(udp-socket-closer ,local-addr)
|
||||
#:parent : SocketManagerState
|
||||
#:child : Void
|
||||
(begin (udp-close s)
|
||||
(transition: (void) : Void (quit)))))))
|
||||
(name-process `(udp-socket-closer ,local-addr)
|
||||
(spawn: #:parent : SocketManagerState
|
||||
#:child : Void
|
||||
(begin (udp-close s)
|
||||
(transition: (void) : Void (quit))))))))
|
||||
|
||||
(spawn: #:debug-name `(udp-socket-manager ,local-addr)
|
||||
#:parent : DriverState
|
||||
#:child : SocketManagerState
|
||||
(transition: #t : SocketManagerState
|
||||
;; Offers a handle-mapping on the local network so that
|
||||
;; the driver/factory can clean up when this process dies.
|
||||
(endpoint: : SocketManagerState #:publisher (handle-mapping local-addr s))
|
||||
;; If our counterparty removes either of their endpoints
|
||||
;; as the subscriber end of the remote-to-local stream or
|
||||
;; the publisher end of the local-to-remote stream, shut
|
||||
;; ourselves down. Also, relay messages published on the
|
||||
;; local-to-remote stream out on the actual socket.
|
||||
(endpoint: socket-is-open? : SocketManagerState
|
||||
#:publisher (udp-packet-pattern any-remote local-addr (wild))
|
||||
#:on-absence (handle-absence socket-is-open?))
|
||||
(endpoint: socket-is-open? : SocketManagerState
|
||||
#:subscriber (udp-packet-pattern local-addr any-remote (wild))
|
||||
#:on-absence (handle-absence socket-is-open?)
|
||||
[(udp-packet (== local-addr)
|
||||
(udp-remote-address remote-host remote-port)
|
||||
body)
|
||||
(begin (udp-send-to s remote-host remote-port body)
|
||||
(transition: socket-is-open? : SocketManagerState))])
|
||||
;; Listen for messages arriving on the actual socket using
|
||||
;; a ground event, and relay them at this level.
|
||||
(endpoint: : SocketManagerState
|
||||
#:subscriber (cons (udp-receive!-evt s buffer) (wild))
|
||||
[(cons (? evt?) (list (? exact-integer? packet-length)
|
||||
(? string? remote-host)
|
||||
(? valid-port-number? remote-port)))
|
||||
(let ((packet (subbytes buffer 0 packet-length)))
|
||||
(send-message (udp-packet (udp-remote-address remote-host remote-port)
|
||||
local-addr
|
||||
packet)))]))))
|
||||
(name-process `(udp-socket-manager ,local-addr)
|
||||
(spawn: #:parent : DriverState
|
||||
#:child : SocketManagerState
|
||||
(transition: #t : SocketManagerState
|
||||
;; Offers a handle-mapping on the local network so that
|
||||
;; the driver/factory can clean up when this process dies.
|
||||
(publish-on-topic: SocketManagerState (handle-mapping local-addr s))
|
||||
;; If our counterparty removes either of their endpoints
|
||||
;; as the subscriber end of the remote-to-local stream or
|
||||
;; the publisher end of the local-to-remote stream, shut
|
||||
;; ourselves down. Also, relay messages published on the
|
||||
;; local-to-remote stream out on the actual socket.
|
||||
(publish-on-topic: SocketManagerState
|
||||
(udp-packet-pattern any-remote local-addr (wild))
|
||||
(match-state socket-is-open?
|
||||
(on-absence (handle-absence socket-is-open?))))
|
||||
(subscribe-to-topic: SocketManagerState
|
||||
(udp-packet-pattern local-addr any-remote (wild))
|
||||
(match-state socket-is-open?
|
||||
(on-absence (handle-absence socket-is-open?))
|
||||
(on-message
|
||||
[(udp-packet (== local-addr)
|
||||
(udp-remote-address remote-host remote-port)
|
||||
body)
|
||||
(begin (udp-send-to s remote-host remote-port body)
|
||||
(transition: socket-is-open? : SocketManagerState))])))
|
||||
;; Listen for messages arriving on the actual socket using
|
||||
;; a ground event, and relay them at this level.
|
||||
(subscribe-to-topic: SocketManagerState (cons (udp-receive!-evt s buffer) (wild))
|
||||
(on-message
|
||||
[(cons (? evt?) (list (? exact-integer? packet-length)
|
||||
(? string? remote-host)
|
||||
(? valid-port-number? remote-port)))
|
||||
(let ((packet (subbytes buffer 0 packet-length)))
|
||||
(send-message (udp-packet (udp-remote-address remote-host remote-port)
|
||||
local-addr
|
||||
packet)))]))))))
|
||||
|
|
|
@ -4,44 +4,43 @@
|
|||
|
||||
;; Usually it's OK to just use display and friends directly.
|
||||
;; Here we have a console output driver just to show how it's done.
|
||||
(spawn #:debug-name 'console-output-driver
|
||||
#:child
|
||||
(transition/no-state
|
||||
(endpoint #:subscriber (list 'console-output ?)
|
||||
[(list 'console-output item)
|
||||
(begin (printf "~a" item)
|
||||
(void))])))
|
||||
(name-process 'console-output-driver
|
||||
(spawn (transition/no-state
|
||||
(subscribe-to-topic (list 'console-output ?)
|
||||
(on-message [(list 'console-output item)
|
||||
(printf "~a" item)
|
||||
(void)])))))
|
||||
|
||||
(spawn #:debug-name 'console-input-driver
|
||||
#:child
|
||||
(transition/no-state
|
||||
(endpoint #:publisher (list 'console-input ?)
|
||||
#:name 'input-relay
|
||||
#:on-absence
|
||||
(list (send-message (list 'console-output "Connection terminated.\n"))
|
||||
(quit)))
|
||||
(endpoint #:subscriber (cons (read-line-evt (current-input-port) 'any) ?)
|
||||
[(cons _ (? eof-object?))
|
||||
(list (send-message (list 'console-output "Terminating on local EOF.\n"))
|
||||
(delete-endpoint 'input-relay))]
|
||||
[(cons _ (? string? line))
|
||||
(send-message (list 'console-input line))])))
|
||||
(name-process 'console-input-driver
|
||||
(spawn (transition/no-state
|
||||
(name-endpoint 'input-relay
|
||||
(publish-on-topic (list 'console-input ?)
|
||||
(on-absence
|
||||
(send-message (list 'console-output "Connection terminated.\n"))
|
||||
(quit))))
|
||||
(subscribe-to-topic (cons (read-line-evt (current-input-port) 'any) ?)
|
||||
(on-message
|
||||
[(cons _ (? eof-object?))
|
||||
(send-message (list 'console-output "Terminating on local EOF.\n"))
|
||||
(delete-endpoint 'input-relay)]
|
||||
[(cons _ (? string? line))
|
||||
(send-message (list 'console-input line))])))))
|
||||
|
||||
(spawn #:debug-name 'outbound-connection
|
||||
#:child
|
||||
(let ((local (tcp-handle 'outbound))
|
||||
(remote (tcp-address "localhost" 5999)))
|
||||
(transition/no-state
|
||||
(endpoint #:subscriber (list 'console-input ?)
|
||||
#:on-absence (quit)
|
||||
[(list 'console-input line)
|
||||
(list (send-message (list 'console-output (format "> ~a \n" line)))
|
||||
(send-message (tcp-channel local remote (string-append line "\n"))))])
|
||||
(endpoint #:publisher (tcp-channel local remote ?))
|
||||
(endpoint #:subscriber (tcp-channel remote local ?)
|
||||
#:on-absence (quit)
|
||||
[(tcp-channel _ _ (? eof-object?))
|
||||
(quit)]
|
||||
[(tcp-channel _ _ data)
|
||||
(list (send-message (list 'console-output (format "< ~a" data)))
|
||||
(void))]))))
|
||||
(name-process 'outbound-connection
|
||||
(spawn (let ((local (tcp-handle 'outbound))
|
||||
(remote (tcp-address "localhost" 5999)))
|
||||
(transition/no-state
|
||||
(subscribe-to-topic (list 'console-input ?)
|
||||
(on-absence (quit))
|
||||
(on-message
|
||||
[(list 'console-input line)
|
||||
(send-message (list 'console-output (format "> ~a \n" line)))
|
||||
(send-message (tcp-channel local remote (string-append line "\n")))]))
|
||||
(publish-on-topic (tcp-channel local remote ?))
|
||||
(subscribe-to-topic (tcp-channel remote local ?)
|
||||
(on-absence (quit))
|
||||
(on-message
|
||||
[(tcp-channel _ _ (? eof-object?))
|
||||
(quit)]
|
||||
[(tcp-channel _ _ data)
|
||||
(send-message (list 'console-output (format "< ~a" data)))]))))))
|
||||
|
|
|
@ -1,47 +0,0 @@
|
|||
#lang marketplace
|
||||
(require "../extrasugar.rkt")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(nested-vm
|
||||
(at-meta-level
|
||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
||||
(match-conversation (tcp-channel them us _)
|
||||
(on-presence (spawn #:child (chat-session them us)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (chat-session them us)
|
||||
(define user (gensym 'user))
|
||||
(transition stateless
|
||||
(listen-to-user user them us)
|
||||
(speak-to-user user them us)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (listen-to-user user them us)
|
||||
(list
|
||||
(publish-on-topic `(,user says ,?))
|
||||
(at-meta-level
|
||||
(subscribe-to-topic (tcp-channel them us ?)
|
||||
(on-absence (quit))
|
||||
(on-message
|
||||
[(tcp-channel _ _ (? bytes? text))
|
||||
(send-message `(,user says ,text))])))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (speak-to-user user them us)
|
||||
(define (say fmt . args)
|
||||
(at-meta-level
|
||||
(send-message
|
||||
(tcp-channel us them (apply format fmt args)))))
|
||||
(define (announce who did-what)
|
||||
(unless (equal? who user)
|
||||
(say "~s ~s.~n" who did-what)))
|
||||
(list
|
||||
(say "You are ~s.~n" user)
|
||||
(at-meta-level
|
||||
(publish-on-topic (tcp-channel us them ?)))
|
||||
(subscribe-to-topic `(,? says ,?)
|
||||
(match-conversation `(,who says ,_)
|
||||
(on-presence (announce who 'arrived))
|
||||
(on-absence (announce who 'departed))
|
||||
(on-message [`(,who says ,what)
|
||||
(say "~a: ~a" who what)])))))
|
|
@ -1,29 +1,31 @@
|
|||
#lang marketplace
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(nested-vm
|
||||
(at-meta-level
|
||||
(endpoint
|
||||
#:subscriber (tcp-channel ? (tcp-listener 5999) ?)
|
||||
#:observer
|
||||
#:conversation (tcp-channel them us _)
|
||||
#:on-presence
|
||||
(spawn #:child (chat-session them us)))))
|
||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
||||
(match-conversation (tcp-channel them us _)
|
||||
(on-presence (spawn (chat-session them us)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (chat-session them us)
|
||||
(define user (gensym 'user))
|
||||
(transition stateless
|
||||
(listen-to-user user them us)
|
||||
(speak-to-user user them us)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (listen-to-user user them us)
|
||||
(list
|
||||
(endpoint #:publisher `(,user says ,?))
|
||||
(publish-on-topic `(,user says ,?))
|
||||
(at-meta-level
|
||||
(endpoint #:subscriber (tcp-channel them us ?)
|
||||
#:on-absence (quit)
|
||||
[(tcp-channel _ _ (? bytes? text))
|
||||
(send-message `(,user says ,text))]))))
|
||||
(subscribe-to-topic (tcp-channel them us ?)
|
||||
(on-absence (quit))
|
||||
(on-message
|
||||
[(tcp-channel _ _ (? bytes? text))
|
||||
(send-message `(,user says ,text))])))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (speak-to-user user them us)
|
||||
(define (say fmt . args)
|
||||
(at-meta-level
|
||||
|
@ -35,9 +37,10 @@
|
|||
(list
|
||||
(say "You are ~s.~n" user)
|
||||
(at-meta-level
|
||||
(endpoint #:publisher (tcp-channel us them ?)))
|
||||
(endpoint #:subscriber `(,? says ,?)
|
||||
#:conversation `(,who says ,_)
|
||||
#:on-presence (announce who 'arrived)
|
||||
#:on-absence (announce who 'departed)
|
||||
[`(,who says ,what) (say "~a: ~a" who what)])))
|
||||
(publish-on-topic (tcp-channel us them ?)))
|
||||
(subscribe-to-topic `(,? says ,?)
|
||||
(match-conversation `(,who says ,_)
|
||||
(on-presence (announce who 'arrived))
|
||||
(on-absence (announce who 'departed))
|
||||
(on-message [`(,who says ,what)
|
||||
(say "~a: ~a" who what)])))))
|
||||
|
|
|
@ -4,16 +4,12 @@
|
|||
|
||||
(debug
|
||||
(nested-vm
|
||||
#:debug-name 'echo
|
||||
(at-meta-level
|
||||
(endpoint
|
||||
#:subscriber (tcp-channel ? (tcp-listener 5999) ?)
|
||||
#:observer
|
||||
#:conversation (tcp-channel them us _)
|
||||
#:on-presence
|
||||
(debug
|
||||
(spawn #:debug-name (list 'session them)
|
||||
#:child (chat-session them us)))))))
|
||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
||||
(match-conversation (tcp-channel them us _)
|
||||
(on-presence
|
||||
(debug (name-process (list 'session them)
|
||||
(spawn (chat-session them us))))))))))
|
||||
|
||||
(define (chat-session them us)
|
||||
(define user (gensym 'user))
|
||||
|
@ -23,12 +19,13 @@
|
|||
|
||||
(define (listen-to-user user them us)
|
||||
(list
|
||||
(endpoint #:publisher `(,user says ,?))
|
||||
(publish-on-topic `(,user says ,?))
|
||||
(at-meta-level
|
||||
(endpoint #:subscriber (tcp-channel them us ?)
|
||||
#:on-absence (quit)
|
||||
[(tcp-channel _ _ (? bytes? text))
|
||||
(send-message `(,user says ,text))]))))
|
||||
(subscribe-to-topic (tcp-channel them us ?)
|
||||
(on-absence (quit))
|
||||
(on-message
|
||||
[(tcp-channel _ _ (? bytes? text))
|
||||
(send-message `(,user says ,text))])))))
|
||||
|
||||
(define (speak-to-user user them us)
|
||||
(define (say fmt . args)
|
||||
|
@ -41,9 +38,10 @@
|
|||
(list
|
||||
(say "You are ~s.~n" user)
|
||||
(at-meta-level
|
||||
(endpoint #:publisher (tcp-channel us them ?)))
|
||||
(endpoint #:subscriber `(,? says ,?)
|
||||
#:conversation `(,who says ,_)
|
||||
#:on-presence (announce who 'arrived)
|
||||
#:on-absence (announce who 'departed)
|
||||
[`(,who says ,what) (say "~a: ~a" who what)])))
|
||||
(publish-on-topic (tcp-channel us them ?)))
|
||||
(subscribe-to-topic `(,? says ,?)
|
||||
(match-conversation `(,who says ,_)
|
||||
(on-presence (announce who 'arrived))
|
||||
(on-absence (announce who 'departed))
|
||||
(on-message [`(,who says ,what)
|
||||
(say "~a: ~a" who what)])))))
|
||||
|
|
|
@ -1,14 +1,13 @@
|
|||
#lang marketplace
|
||||
|
||||
(endpoint
|
||||
#:subscriber (tcp-channel ? (tcp-listener 5999) ?)
|
||||
#:conversation (tcp-channel from to _)
|
||||
#:on-presence (spawn #:child (echoer from to)))
|
||||
(subscribe-to-topic (tcp-channel ? (tcp-listener 5999) ?)
|
||||
(match-conversation (tcp-channel from to _)
|
||||
(on-presence (spawn (echoer from to)))))
|
||||
|
||||
(define (echoer from to)
|
||||
(transition stateless
|
||||
(endpoint
|
||||
#:subscriber (tcp-channel from to ?)
|
||||
#:on-absence (quit)
|
||||
[(tcp-channel _ _ data)
|
||||
(send-message (tcp-channel to from data))])))
|
||||
(subscribe-to-topic (tcp-channel from to ?)
|
||||
(on-absence (quit))
|
||||
(on-message
|
||||
[(tcp-channel _ _ data)
|
||||
(send-message (tcp-channel to from data))]))))
|
||||
|
|
|
@ -6,13 +6,13 @@
|
|||
|
||||
(define (echoer from to)
|
||||
(transition/no-state
|
||||
(endpoint
|
||||
#:subscriber (tcp-channel from to ?)
|
||||
#:on-absence (quit)
|
||||
[(tcp-channel _ _ data)
|
||||
(send-message (tcp-channel to from data))])))
|
||||
(subscribe-to-topic (tcp-channel from to ?)
|
||||
(on-absence (quit))
|
||||
(on-message
|
||||
[(tcp-channel _ _ data)
|
||||
(send-message (tcp-channel to from data))]))))
|
||||
|
||||
(ground-vm tcp
|
||||
(endpoint #:subscriber (tcp-channel ? (tcp-listener 5999) ?)
|
||||
#:conversation (tcp-channel from to _)
|
||||
#:on-presence (spawn #:child (echoer from to))))
|
||||
(subscribe-to-topic (tcp-channel ? (tcp-listener 5999) ?)
|
||||
(match-conversation (tcp-channel from to _)
|
||||
(on-presence (spawn (echoer from to))))))
|
||||
|
|
|
@ -0,0 +1,257 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require (for-syntax syntax/parse))
|
||||
(require (for-syntax racket/base))
|
||||
(require "support/dsl-typed.rkt")
|
||||
(require (for-syntax "support/dsl-typed.rkt"))
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(require (prefix-in core: "main.rkt"))
|
||||
|
||||
(provide name-endpoint
|
||||
let-fresh
|
||||
observe-subscribers:
|
||||
observe-subscribers/everything:
|
||||
observe-publishers:
|
||||
observe-publishers/everything:
|
||||
publish-on-topic:
|
||||
subscribe-to-topic:
|
||||
build-endpoint:)
|
||||
|
||||
(define&provide-dsl-helper-syntaxes "endpoint definition context"
|
||||
[match-state
|
||||
match-orientation
|
||||
match-conversation
|
||||
match-interest-type
|
||||
match-reason
|
||||
on-presence
|
||||
on-absence
|
||||
on-message])
|
||||
|
||||
;; Must handle:
|
||||
;; - orientation
|
||||
;; - interest-type
|
||||
;; - let-name
|
||||
;; - naming of endpoints
|
||||
;; - state matching
|
||||
;; - conversation (and generally role) matching
|
||||
;; - presence event handling
|
||||
;; - absence event handling (including reason matching)
|
||||
;; - message event handling (including message matching)
|
||||
|
||||
(: name-endpoint : (All (State) Any (core:AddEndpoint State) -> (core:AddEndpoint State)))
|
||||
(define (name-endpoint n e)
|
||||
(match e
|
||||
[(core:add-endpoint _ role handler)
|
||||
(core:add-endpoint (cast n core:PreEID) role handler)]))
|
||||
|
||||
(define-syntax-rule (let-fresh (id ...) exp ...)
|
||||
(let ((id (gensym 'id)) ...) exp ...))
|
||||
|
||||
(define-syntax-rule (observe-subscribers: State topic clause ...)
|
||||
(build-endpoint: State
|
||||
(gensym 'anonymous-endpoint)
|
||||
(core:role 'publisher (cast topic core:Topic) 'observer)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (observe-subscribers/everything: State topic clause ...)
|
||||
(build-endpoint: State
|
||||
(gensym 'anonymous-endpoint)
|
||||
(core:role 'publisher (cast topic core:Topic) 'everything)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (observe-publishers: State topic clause ...)
|
||||
(build-endpoint: State
|
||||
(gensym 'anonymous-endpoint)
|
||||
(core:role 'subscriber (cast topic core:Topic) 'observer)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (observe-publishers/everything: State topic clause ...)
|
||||
(build-endpoint: State
|
||||
(gensym 'anonymous-endpoint)
|
||||
(core:role 'subscriber (cast topic core:Topic) 'everything)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (publish-on-topic: State topic clause ...)
|
||||
(build-endpoint: State
|
||||
(gensym 'anonymous-endpoint)
|
||||
(core:role 'publisher (cast topic core:Topic) 'participant)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (subscribe-to-topic: State topic clause ...)
|
||||
(build-endpoint: State
|
||||
(gensym 'anonymous-endpoint)
|
||||
(core:role 'subscriber (cast topic core:Topic) 'participant)
|
||||
clause ...))
|
||||
|
||||
(define-syntax build-endpoint:
|
||||
(lambda (stx)
|
||||
(define (combine-handler-clauses State
|
||||
clauses-stx
|
||||
stateful?
|
||||
state-stx
|
||||
orientation-stx
|
||||
conversation-stx
|
||||
interest-type-stx
|
||||
reason-stx)
|
||||
|
||||
(define (do-tail new-clauses-stx)
|
||||
(combine-handler-clauses State
|
||||
new-clauses-stx
|
||||
stateful?
|
||||
state-stx
|
||||
orientation-stx
|
||||
conversation-stx
|
||||
interest-type-stx
|
||||
reason-stx))
|
||||
|
||||
(define (stateful-lift context exprs-stx)
|
||||
(if stateful?
|
||||
(syntax-case exprs-stx ()
|
||||
[(expr)
|
||||
#`(lambda: ([state : #,State]) (match state [#,state-stx expr]))]
|
||||
[_
|
||||
(raise-syntax-error #f
|
||||
(format "Expected exactly one expression resulting in a transition, in ~a handler"
|
||||
context)
|
||||
stx
|
||||
exprs-stx)])
|
||||
(syntax-case exprs-stx ()
|
||||
[(expr ...)
|
||||
#`(lambda: ([state : #,State]) (core:transition state (list expr ...)))])))
|
||||
|
||||
(syntax-case clauses-stx ()
|
||||
[() '()]
|
||||
|
||||
[((maybe-match-state pat-stx inner-clause ...) outer-clause ...)
|
||||
(literal-identifier=? #'maybe-match-state #'match-state)
|
||||
(append (combine-handler-clauses State
|
||||
(syntax (inner-clause ...))
|
||||
#t
|
||||
#'pat-stx
|
||||
orientation-stx
|
||||
conversation-stx
|
||||
interest-type-stx
|
||||
reason-stx)
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((maybe-match-orientation pat-stx inner-clause ...) outer-clause ...)
|
||||
(literal-identifier=? #'maybe-match-orientation #'match-orientation)
|
||||
(append (combine-handler-clauses State
|
||||
(syntax (inner-clause ...))
|
||||
stateful?
|
||||
state-stx
|
||||
#'pat-stx
|
||||
conversation-stx
|
||||
interest-type-stx
|
||||
reason-stx)
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((maybe-match-conversation pat-stx inner-clause ...) outer-clause ...)
|
||||
(literal-identifier=? #'maybe-match-conversation #'match-conversation)
|
||||
(append (combine-handler-clauses State
|
||||
(syntax (inner-clause ...))
|
||||
stateful?
|
||||
state-stx
|
||||
orientation-stx
|
||||
#'pat-stx
|
||||
interest-type-stx
|
||||
reason-stx)
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((maybe-match-interest-type pat-stx inner-clause ...) outer-clause ...)
|
||||
(literal-identifier=? #'maybe-match-interest-type #'match-interest-type)
|
||||
(append (combine-handler-clauses State
|
||||
(syntax (inner-clause ...))
|
||||
stateful?
|
||||
state-stx
|
||||
orientation-stx
|
||||
conversation-stx
|
||||
#'pat-stx
|
||||
reason-stx)
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((maybe-match-reason pat-stx inner-clause ...) outer-clause ...)
|
||||
(literal-identifier=? #'maybe-match-reason #'match-reason)
|
||||
(append (combine-handler-clauses State
|
||||
(syntax (inner-clause ...))
|
||||
stateful?
|
||||
state-stx
|
||||
orientation-stx
|
||||
conversation-stx
|
||||
interest-type-stx
|
||||
#'pat-stx)
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((maybe-on-presence expr ...) outer-clause ...)
|
||||
(literal-identifier=? #'maybe-on-presence #'on-presence)
|
||||
(cons #`[(core:presence-event (core:role #,orientation-stx
|
||||
#,conversation-stx
|
||||
#,interest-type-stx))
|
||||
#,(stateful-lift 'on-presence (syntax (expr ...)))]
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((maybe-on-absence expr ...) outer-clause ...)
|
||||
(literal-identifier=? #'maybe-on-absence #'on-absence)
|
||||
(cons #`[(core:absence-event (core:role #,orientation-stx
|
||||
#,conversation-stx
|
||||
#,interest-type-stx)
|
||||
#,reason-stx)
|
||||
#,(stateful-lift 'on-absence (syntax (expr ...)))]
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((maybe-on-message [message-pat expr ...] ...) outer-clause ...)
|
||||
(literal-identifier=? #'maybe-on-message #'on-message)
|
||||
(cons #`[(core:message-event (core:role #,orientation-stx
|
||||
#,conversation-stx
|
||||
#,interest-type-stx)
|
||||
message)
|
||||
(match message
|
||||
#,@(map (lambda (message-clause)
|
||||
(syntax-case message-clause ()
|
||||
([message-pat expr ...]
|
||||
#`[message-pat #,(stateful-lift 'on-message
|
||||
(syntax (expr ...)))])))
|
||||
(syntax->list (syntax ([message-pat expr ...] ...))))
|
||||
[_ (lambda: ([state : #,State]) (core:transition state '()))])]
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[(unknown-clause outer-clause ...)
|
||||
(raise-syntax-error #f
|
||||
"Illegal clause in endpoint definition"
|
||||
stx
|
||||
#'unknown-clause)]))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(dummy State pre-eid-exp role-exp handler-clause ...)
|
||||
#`(core:add-endpoint (cast pre-eid-exp core:PreEID)
|
||||
role-exp
|
||||
(match-lambda
|
||||
#,@(reverse
|
||||
(combine-handler-clauses
|
||||
#'State
|
||||
(syntax (handler-clause ...))
|
||||
#f
|
||||
(syntax old-state)
|
||||
(syntax _)
|
||||
(syntax _)
|
||||
(syntax _)
|
||||
(syntax _)))
|
||||
[_ (lambda: ([state : State]) (core:transition state '()))]))])))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'name-endpoint 'scheme-indent-function 1)
|
||||
;;; eval: (put 'let-fresh 'scheme-indent-function 1)
|
||||
;;; eval: (put 'observe-subscribers: 'scheme-indent-function 2)
|
||||
;;; eval: (put 'observe-subscribers/everything: 'scheme-indent-function 2)
|
||||
;;; eval: (put 'observe-publishers: 'scheme-indent-function 2)
|
||||
;;; eval: (put 'observe-publishers/everything: 'scheme-indent-function 2)
|
||||
;;; eval: (put 'publish-on-topic: 'scheme-indent-function 2)
|
||||
;;; eval: (put 'subscribe-to-topic: 'scheme-indent-function 2)
|
||||
;;; eval: (put 'match-state 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-orientation 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-conversation 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-interest-type 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-reason 'scheme-indent-function 1)
|
||||
;;; End:
|
|
@ -2,52 +2,31 @@
|
|||
|
||||
(require (for-syntax syntax/parse))
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(require racket/stxparam)
|
||||
(require racket/splicing)
|
||||
(require "support/dsl-untyped.rkt")
|
||||
|
||||
(require racket/match)
|
||||
|
||||
(require (prefix-in core: "main.rkt"))
|
||||
(require (except-in "main.rkt"
|
||||
at-meta-level
|
||||
spawn
|
||||
yield
|
||||
transition
|
||||
delete-endpoint
|
||||
send-message
|
||||
quit))
|
||||
(require "sugar-untyped.rkt")
|
||||
|
||||
(provide (except-out (all-from-out "sugar-untyped.rkt") endpoint)
|
||||
(all-from-out "main.rkt")
|
||||
name-endpoint
|
||||
(provide name-endpoint
|
||||
let-fresh
|
||||
observe-subscribers
|
||||
observe-subscribers/everything
|
||||
observe-publishers
|
||||
observe-publishers/everything
|
||||
publish-on-topic
|
||||
subscribe-to-topic
|
||||
build-endpoint)
|
||||
|
||||
(define-syntax-rule (define&provide-endpoint-helper-syntaxes identifier ...)
|
||||
(begin (provide identifier ...)
|
||||
(define-syntax identifier
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f
|
||||
(format "Illegal use of ~a outside endpoint definition context"
|
||||
'identifier)
|
||||
stx)))
|
||||
...))
|
||||
|
||||
(define&provide-endpoint-helper-syntaxes
|
||||
match-state
|
||||
match-orientation
|
||||
match-conversation
|
||||
match-interest-type
|
||||
match-reason
|
||||
on-presence
|
||||
on-absence
|
||||
on-message)
|
||||
(define&provide-dsl-helper-syntaxes "endpoint definition context"
|
||||
[match-state
|
||||
match-orientation
|
||||
match-conversation
|
||||
match-interest-type
|
||||
match-reason
|
||||
on-presence
|
||||
on-absence
|
||||
on-message])
|
||||
|
||||
;; Must handle:
|
||||
;; - orientation
|
||||
|
@ -73,11 +52,21 @@
|
|||
(core:role 'publisher topic 'observer)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (observe-subscribers/everything topic clause ...)
|
||||
(build-endpoint (gensym 'anonymous-endpoint)
|
||||
(core:role 'publisher topic 'everything)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (observe-publishers topic clause ...)
|
||||
(build-endpoint (gensym 'anonymous-endpoint)
|
||||
(core:role 'subscriber topic 'observer)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (observe-publishers/everything topic clause ...)
|
||||
(build-endpoint (gensym 'anonymous-endpoint)
|
||||
(core:role 'subscriber topic 'everything)
|
||||
clause ...))
|
||||
|
||||
(define-syntax-rule (publish-on-topic topic clause ...)
|
||||
(build-endpoint (gensym 'anonymous-endpoint)
|
||||
(core:role 'publisher topic 'participant)
|
||||
|
@ -107,10 +96,20 @@
|
|||
interest-type-stx
|
||||
reason-stx))
|
||||
|
||||
(define (stateful-lift expr-stx)
|
||||
(define (stateful-lift context exprs-stx)
|
||||
(if stateful?
|
||||
#`(match-lambda [#,state-stx #,expr-stx])
|
||||
#`(lambda (state) (core:transition state #,expr-stx))))
|
||||
(syntax-case exprs-stx ()
|
||||
[(expr)
|
||||
#`(match-lambda [#,state-stx expr])]
|
||||
[_
|
||||
(raise-syntax-error #f
|
||||
(format "Expected exactly one expression resulting in a transition, in ~a handler"
|
||||
context)
|
||||
stx
|
||||
exprs-stx)])
|
||||
(syntax-case exprs-stx ()
|
||||
[(expr ...)
|
||||
#`(lambda (state) (core:transition state (list expr ...)))])))
|
||||
|
||||
(syntax-case clauses-stx (match-state
|
||||
match-orientation
|
||||
|
@ -176,7 +175,7 @@
|
|||
(cons #`[(core:presence-event (core:role #,orientation-stx
|
||||
#,conversation-stx
|
||||
#,interest-type-stx))
|
||||
#,(stateful-lift (syntax (begin expr ...)))]
|
||||
#,(stateful-lift 'on-presence (syntax (expr ...)))]
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((on-absence expr ...) outer-clause ...)
|
||||
|
@ -184,7 +183,7 @@
|
|||
#,conversation-stx
|
||||
#,interest-type-stx)
|
||||
#,reason-stx)
|
||||
#,(stateful-lift (syntax (begin expr ...)))]
|
||||
#,(stateful-lift 'on-absence (syntax (expr ...)))]
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[((on-message [message-pat expr ...] ...) outer-clause ...)
|
||||
|
@ -196,10 +195,17 @@
|
|||
#,@(map (lambda (message-clause)
|
||||
(syntax-case message-clause ()
|
||||
([message-pat expr ...]
|
||||
#`[message-pat #,(stateful-lift (syntax (begin expr ...)))])))
|
||||
#`[message-pat #,(stateful-lift 'on-message
|
||||
(syntax (expr ...)))])))
|
||||
(syntax->list (syntax ([message-pat expr ...] ...))))
|
||||
[_ (lambda (state) (core:transition state '()))])]
|
||||
(do-tail (syntax (outer-clause ...))))]))
|
||||
(do-tail (syntax (outer-clause ...))))]
|
||||
|
||||
[(unknown-clause outer-clause ...)
|
||||
(raise-syntax-error #f
|
||||
"Illegal clause in endpoint definition"
|
||||
stx
|
||||
#'unknown-clause)]))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(dummy pre-eid-exp role-exp handler-clause ...)
|
||||
|
@ -216,3 +222,19 @@
|
|||
(syntax _)
|
||||
(syntax _)))
|
||||
[_ (lambda (state) (core:transition state '()))]))])))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'name-endpoint 'scheme-indent-function 1)
|
||||
;;; eval: (put 'let-fresh 'scheme-indent-function 1)
|
||||
;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)
|
||||
;;; eval: (put 'observe-subscribers/everything 'scheme-indent-function 1)
|
||||
;;; eval: (put 'observe-publishers 'scheme-indent-function 1)
|
||||
;;; eval: (put 'observe-publishers/everything 'scheme-indent-function 1)
|
||||
;;; eval: (put 'publish-on-topic 'scheme-indent-function 1)
|
||||
;;; eval: (put 'subscribe-to-topic 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-state 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-orientation 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-conversation 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-interest-type 'scheme-indent-function 1)
|
||||
;;; eval: (put 'match-reason 'scheme-indent-function 1)
|
||||
;;; End:
|
|
@ -15,14 +15,17 @@
|
|||
quit
|
||||
wild))
|
||||
(require "sugar-values.rkt")
|
||||
(require "sugar-endpoints-typed.rkt")
|
||||
|
||||
(provide (all-from-out "sugar-values.rkt")
|
||||
(all-from-out "sugar-endpoints-typed.rkt")
|
||||
(all-from-out "main.rkt")
|
||||
?
|
||||
transition:
|
||||
transition/no-state
|
||||
endpoint:
|
||||
spawn:
|
||||
spawn/continue:
|
||||
name-process
|
||||
yield:
|
||||
at-meta-level:
|
||||
nested-vm:
|
||||
|
@ -40,132 +43,50 @@
|
|||
(define-syntax-rule (transition/no-state action ...)
|
||||
(transition: (void) : Void action ...))
|
||||
|
||||
(define-syntax endpoint:
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~or (~seq (~literal :) State)
|
||||
(~seq state-pattern (~literal :) State))
|
||||
(~or (~seq #:subscriber (~bind [is-subscriber #'#t]))
|
||||
(~seq #:publisher (~bind [is-publisher #'#t])))
|
||||
topic-expr
|
||||
(~or (~seq #:participant (~bind [is-participant #'#t]))
|
||||
(~seq #:observer (~bind [is-observer #'#t]))
|
||||
(~seq #:everything (~bind [is-everything #'#t]))
|
||||
(~seq))
|
||||
(~or (~optional (~seq #:let-name name-binding)
|
||||
#:defaults ([name-binding #'n0])
|
||||
#:name "#:let-name binding for endpoint name")
|
||||
(~optional (~seq #:name pre-eid) #:name "#:name of endpoint")
|
||||
(~optional (~seq #:on-presence presence) #:name "#:on-presence handler")
|
||||
(~optional (~seq #:on-absence absence) #:name "#:on-absence handler")
|
||||
|
||||
(~optional (~seq #:role role) #:name "#:role")
|
||||
(~optional (~seq #:peer-orientation orientation) #:name "#:peer-orientation")
|
||||
(~optional (~seq #:conversation conversation) #:name "#:conversation")
|
||||
(~optional (~seq #:peer-interest-type interest) #:name "#:peer-interest-type")
|
||||
|
||||
(~optional (~seq #:reason reason) #:defaults ([reason #'r0]) #:name "#:reason"))
|
||||
...
|
||||
[message-pattern clause-body]
|
||||
...)
|
||||
(define-syntax-rule (build-handler event-pattern e-attr)
|
||||
(if (attribute e-attr)
|
||||
#`([event-pattern
|
||||
#,(if (attribute state-pattern)
|
||||
#`(lambda: ([state : State]) (match state [state-pattern e-attr]))
|
||||
#`(lambda: ([state : State]) ((inst core:transition State) state e-attr)))])
|
||||
#`([event-pattern (lambda: ([state : State])
|
||||
(core:transition state '()))])))
|
||||
(define role-pattern
|
||||
(cond
|
||||
[(attribute role)
|
||||
(when (or (attribute orientation)
|
||||
(attribute conversation)
|
||||
(attribute interest))
|
||||
(raise-syntax-error #f "Supply either #:role or any of (#:peer-orientation, #:conversation, #:peer-interest-type)" stx))
|
||||
#'role]
|
||||
[else
|
||||
#`(core:role #,(if (attribute orientation) #'orientation #'_)
|
||||
#,(if (attribute conversation) #'conversation #'_)
|
||||
#,(if (attribute interest) #'interest #'_))]))
|
||||
#`(let ((name-binding (cast #,(if (attribute pre-eid)
|
||||
#'pre-eid
|
||||
#'(gensym 'anonymous-endpoint))
|
||||
core:PreEID)))
|
||||
(core:add-endpoint
|
||||
name-binding
|
||||
(core:role #,(cond
|
||||
[(attribute is-subscriber) #''subscriber]
|
||||
[(attribute is-publisher) #''publisher]
|
||||
[else (raise-syntax-error #f
|
||||
"Missing #:subscriber or #:publisher"
|
||||
stx)])
|
||||
(cast topic-expr core:Topic)
|
||||
#,(cond
|
||||
[(attribute is-participant) #''participant]
|
||||
[(attribute is-observer) #''observer]
|
||||
[(attribute is-everything) #''everything]
|
||||
[else #''participant]))
|
||||
(match-lambda
|
||||
#,@(build-handler (core:presence-event #,role-pattern) presence)
|
||||
#,@(build-handler (core:absence-event #,role-pattern reason) absence)
|
||||
[(core:message-event #,role-pattern message)
|
||||
#,(if (attribute state-pattern)
|
||||
#`(lambda: ([state : State])
|
||||
(match state
|
||||
[state-pattern
|
||||
(match message
|
||||
[message-pattern clause-body] ...
|
||||
[_ (core:transition state '())])]))
|
||||
#`(lambda: ([state : State])
|
||||
((inst core:transition State)
|
||||
state
|
||||
(match message
|
||||
[message-pattern clause-body] ...
|
||||
[_ '()]))))]
|
||||
[_
|
||||
(lambda: ([state : State]) (core:transition state '()))])))])))
|
||||
|
||||
(define-syntax spawn:
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")
|
||||
(~optional (~seq #:debug-name debug-name)
|
||||
#:defaults ([debug-name #'#f])
|
||||
#:name "#:debug-name")) ...
|
||||
(~or (~seq #:parent parent-state-pattern (~literal :) ParentState
|
||||
(~and (~not #:child) parent-k-exp))
|
||||
(~seq #:parent (~literal :) ParentState
|
||||
(~and (~not #:child) parent-k-exp))
|
||||
(~seq #:parent (~literal :) ParentState))
|
||||
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
|
||||
#:parent (~literal :) ParentState
|
||||
#:child (~literal :) State exp)
|
||||
#`((inst core:spawn ParentState)
|
||||
(core:process-spec (lambda (pid)
|
||||
(lambda (k) ((inst k State) exp))))
|
||||
#,(if (attribute parent-k-exp)
|
||||
(if (attribute parent-state-pattern)
|
||||
#`(lambda (pid)
|
||||
(lambda: ([parent-state : ParentState])
|
||||
(core:process-spec (lambda (pid) (lambda (k) ((inst k State) exp))))
|
||||
#f
|
||||
#f)])))
|
||||
|
||||
(define-syntax spawn/continue:
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
|
||||
#:parent parent-state-pattern (~literal :) ParentState parent-k-exp
|
||||
#:child (~literal :) State exp)
|
||||
#`((inst core:spawn ParentState)
|
||||
(core:process-spec (lambda (pid) (lambda (k) ((inst k State) exp))))
|
||||
(lambda (pid) (lambda: ([parent-state : ParentState])
|
||||
(match parent-state [parent-state-pattern parent-k-exp])))
|
||||
#`(lambda (pid)
|
||||
(lambda: ([parent-state : ParentState])
|
||||
((inst core:transition ParentState) parent-state parent-k-exp))))
|
||||
#'#f)
|
||||
debug-name)])))
|
||||
#f)])))
|
||||
|
||||
(: name-process : (All (State) Any (core:Spawn State) -> (core:Spawn State)))
|
||||
(define (name-process n p)
|
||||
(match p
|
||||
[(core:spawn spec parent-k _)
|
||||
(core:spawn spec parent-k n)]))
|
||||
|
||||
(define-syntax yield:
|
||||
(lambda (stx)
|
||||
(syntax-case stx (:)
|
||||
[(_ state-pattern : State exp)
|
||||
#'((inst core:yield State) (lambda (state) (match state [state-pattern exp])))]
|
||||
[(_ : State exp)
|
||||
#'((inst core:yield State) (lambda (state) (core:transition state exp)))])))
|
||||
#'((inst core:yield State) (lambda (state) (match state [state-pattern exp])))])))
|
||||
|
||||
(define-syntax at-meta-level:
|
||||
(lambda (stx)
|
||||
(syntax-case stx (:)
|
||||
[(_ : State preaction ...)
|
||||
#'((inst at-meta-level State) preaction ...)])))
|
||||
(syntax-case stx ()
|
||||
[(_ State)
|
||||
#''()]
|
||||
[(_ State preaction)
|
||||
#'((inst core:at-meta-level State) preaction)]
|
||||
[(_ State preaction ...)
|
||||
#'(list ((inst core:at-meta-level State) preaction) ...)])))
|
||||
|
||||
(define-syntax nested-vm:
|
||||
(lambda (stx)
|
||||
|
@ -208,5 +129,5 @@
|
|||
(list exp ...)))))))])))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'at-meta-level: 'scheme-indent-function 2)
|
||||
;;; eval: (put 'at-meta-level: 'scheme-indent-function 1)
|
||||
;;; End:
|
||||
|
|
|
@ -14,14 +14,18 @@
|
|||
send-message
|
||||
quit))
|
||||
(require "sugar-values.rkt")
|
||||
(require "sugar-endpoints-untyped.rkt")
|
||||
|
||||
(provide (all-from-out "sugar-values.rkt")
|
||||
(all-from-out "sugar-endpoints-untyped.rkt")
|
||||
(all-from-out "main.rkt")
|
||||
?
|
||||
transition/no-state
|
||||
endpoint
|
||||
spawn
|
||||
spawn/continue
|
||||
name-process
|
||||
yield
|
||||
at-meta-level
|
||||
nested-vm
|
||||
ground-vm)
|
||||
|
||||
|
@ -31,117 +35,40 @@
|
|||
;; A fresh unification variable, as identifier-syntax.
|
||||
(define-syntax ? (syntax-id-rules () (_ (wild))))
|
||||
|
||||
(define-syntax endpoint
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~or (~seq #:subscriber (~bind [is-subscriber #'#t]))
|
||||
(~seq #:publisher (~bind [is-publisher #'#t])))
|
||||
topic-expr
|
||||
(~or (~seq #:participant (~bind [is-participant #'#t]))
|
||||
(~seq #:observer (~bind [is-observer #'#t]))
|
||||
(~seq #:everything (~bind [is-everything #'#t]))
|
||||
(~seq))
|
||||
(~or (~optional (~seq #:let-name name-binding)
|
||||
#:defaults ([name-binding #'n0])
|
||||
#:name "#:let-name binding for endpoint name")
|
||||
(~optional (~seq #:name pre-eid) #:name "#:name of endpoint")
|
||||
(~optional (~seq #:state state-pattern) #:name "#:state pattern")
|
||||
(~optional (~seq #:on-presence presence) #:name "#:on-presence handler")
|
||||
(~optional (~seq #:on-absence absence) #:name "#:on-absence handler")
|
||||
|
||||
(~optional (~seq #:role role) #:name "#:role")
|
||||
(~optional (~seq #:peer-orientation orientation) #:name "#:peer-orientation")
|
||||
(~optional (~seq #:conversation conversation) #:name "#:conversation")
|
||||
(~optional (~seq #:peer-interest-type interest) #:name "#:peer-interest-type")
|
||||
|
||||
(~optional (~seq #:reason reason) #:defaults ([reason #'r0]) #:name "#:reason"))
|
||||
...
|
||||
[message-pattern clause-body]
|
||||
...)
|
||||
(define-syntax-rule (build-handler event-pattern e-attr)
|
||||
(if (attribute e-attr)
|
||||
#`([event-pattern
|
||||
#,(if (attribute state-pattern)
|
||||
#`(match-lambda [state-pattern e-attr])
|
||||
#`(lambda (state) (core:transition state e-attr)))])
|
||||
#`([event-pattern (lambda (state) (core:transition state '()))])))
|
||||
(define role-pattern
|
||||
(cond
|
||||
[(attribute role)
|
||||
(when (or (attribute orientation)
|
||||
(attribute conversation)
|
||||
(attribute interest))
|
||||
(raise-syntax-error #f "Supply either #:role or any of (#:peer-orientation, #:conversation, #:peer-interest-type)" stx))
|
||||
#'role]
|
||||
[else
|
||||
#`(core:role #,(if (attribute orientation) #'orientation #'_)
|
||||
#,(if (attribute conversation) #'conversation #'_)
|
||||
#,(if (attribute interest) #'interest #'_))]))
|
||||
#`(let ((name-binding #,(if (attribute pre-eid)
|
||||
#'pre-eid
|
||||
#'(gensym 'anonymous-endpoint))))
|
||||
(core:add-endpoint
|
||||
name-binding
|
||||
(core:role #,(cond
|
||||
[(attribute is-subscriber) #''subscriber]
|
||||
[(attribute is-publisher) #''publisher]
|
||||
[else (raise-syntax-error #f
|
||||
"Missing #:subscriber or #:publisher"
|
||||
stx)])
|
||||
topic-expr
|
||||
#,(cond
|
||||
[(attribute is-participant) #''participant]
|
||||
[(attribute is-observer) #''observer]
|
||||
[(attribute is-everything) #''everything]
|
||||
[else #''participant]))
|
||||
(match-lambda
|
||||
#,@(build-handler (core:presence-event #,role-pattern) presence)
|
||||
#,@(build-handler (core:absence-event #,role-pattern reason) absence)
|
||||
[(core:message-event #,role-pattern message)
|
||||
#,(if (attribute state-pattern)
|
||||
#`(match-lambda
|
||||
[(and state state-pattern)
|
||||
(match message
|
||||
[message-pattern clause-body] ...
|
||||
[_ (core:transition state '())])])
|
||||
#`(lambda (state)
|
||||
(core:transition state
|
||||
(match message
|
||||
[message-pattern clause-body] ...
|
||||
[_ '()]))))]
|
||||
[_
|
||||
(lambda (state) (core:transition state '()))])))])))
|
||||
|
||||
(define-syntax spawn
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")
|
||||
(~optional (~seq #:debug-name debug-name)
|
||||
#:defaults ([debug-name #'#f])
|
||||
#:name "#:debug-name")) ...
|
||||
(~or (~seq #:parent parent-state-pattern (~and (~not #:child) parent-k-exp))
|
||||
(~seq #:parent (~and (~not #:child) parent-k-exp))
|
||||
(~seq))
|
||||
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
|
||||
exp)
|
||||
#`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
|
||||
#f
|
||||
#f)])))
|
||||
|
||||
(define-syntax spawn/continue
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
|
||||
#:parent parent-state-pattern parent-k-exp
|
||||
#:child exp)
|
||||
#`(core:spawn (core:process-spec (lambda (pid)
|
||||
(lambda (k) (k exp))))
|
||||
#,(if (attribute parent-k-exp)
|
||||
(if (attribute parent-state-pattern)
|
||||
#`(lambda (pid)
|
||||
(match-lambda [parent-state-pattern parent-k-exp]))
|
||||
#`(lambda (pid)
|
||||
(lambda (state)
|
||||
(core:transition state parent-k-exp))))
|
||||
#'#f)
|
||||
debug-name)])))
|
||||
#`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
|
||||
(lambda (pid) (match-lambda [parent-state-pattern parent-k-exp]))
|
||||
#f)])))
|
||||
|
||||
(define (name-process n p)
|
||||
(match p
|
||||
[(core:spawn spec parent-k _)
|
||||
(core:spawn spec parent-k n)]))
|
||||
|
||||
(define-syntax yield
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ #:state state-pattern exp)
|
||||
#'(core:yield (match-lambda [state-pattern exp]))]
|
||||
[(_ exp)
|
||||
#'(core:yield (lambda (state) (core:transition state exp)))])))
|
||||
[(_ state-pattern exp)
|
||||
#'(core:yield (match-lambda [state-pattern exp]))])))
|
||||
|
||||
(define (at-meta-level . preactions)
|
||||
(match preactions
|
||||
[(cons preaction '()) (core:at-meta-level preaction)]
|
||||
[_ (map core:at-meta-level preactions)]))
|
||||
|
||||
(define-syntax nested-vm
|
||||
(lambda (stx)
|
||||
|
@ -179,3 +106,8 @@
|
|||
(core:process-spec (lambda (boot-pid)
|
||||
(lambda (k) (k (core:transition initial-state
|
||||
(list exp ...)))))))])))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'name-process 'scheme-indent-function 1)
|
||||
;;; eval: (put 'yield 'scheme-indent-function 1)
|
||||
;;; End:
|
||||
|
|
|
@ -4,7 +4,6 @@
|
|||
(require (prefix-in core: "main.rkt"))
|
||||
|
||||
(provide transition
|
||||
at-meta-level
|
||||
delete-endpoint
|
||||
send-message
|
||||
send-feedback
|
||||
|
@ -16,14 +15,6 @@
|
|||
(define (transition state . actions)
|
||||
((inst core:transition State) state actions))
|
||||
|
||||
(: at-meta-level : (All (State)
|
||||
(core:PreAction State) *
|
||||
-> (core:ActionTree State)))
|
||||
(define (at-meta-level . preactions)
|
||||
(match preactions
|
||||
[(cons preaction '()) (core:at-meta-level preaction)]
|
||||
[_ ((inst map (core:Action State) (core:PreAction State)) core:at-meta-level preactions)]))
|
||||
|
||||
(define (delete-endpoint #{id : Any}
|
||||
[#{reason : Any} #f])
|
||||
(core:delete-endpoint (cast id core:PreEID) (cast reason core:Reason)))
|
||||
|
|
|
@ -0,0 +1,26 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require (for-syntax typed/racket/base))
|
||||
(provide define&provide-dsl-helper-syntaxes)
|
||||
(provide literal-identifier=?)
|
||||
|
||||
(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...))
|
||||
(begin (provide identifier ...)
|
||||
(define-syntax identifier
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f
|
||||
(format "Illegal use of ~a outside ~a"
|
||||
'identifier
|
||||
context)
|
||||
stx)))
|
||||
...))
|
||||
|
||||
;; Typed racket wraps literal identifiers during provide. Here we dig
|
||||
;; through the renamings to see if they're the same thing. Gross!
|
||||
;; Fragile?
|
||||
(: literal-identifier=? : Syntax Identifier -> Boolean)
|
||||
(define (literal-identifier=? actual expected)
|
||||
(and (identifier? actual)
|
||||
(identifier-binding actual)
|
||||
(eq? (syntax-local-value actual)
|
||||
(syntax-local-value expected))))
|
|
@ -0,0 +1,15 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(provide define&provide-dsl-helper-syntaxes)
|
||||
|
||||
(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...))
|
||||
(begin (provide identifier ...)
|
||||
(define-syntax identifier
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f
|
||||
(format "Illegal use of ~a outside ~a"
|
||||
'identifier
|
||||
context)
|
||||
stx)))
|
||||
...))
|
|
@ -6,27 +6,27 @@
|
|||
|
||||
(: generic-spy : (All (ParentState) Any -> (Spawn ParentState)))
|
||||
(define (generic-spy label)
|
||||
(spawn: #:debug-name `(generic-spy ,label)
|
||||
#:parent : ParentState
|
||||
#:child : Void
|
||||
(transition: (void) : Void
|
||||
(endpoint: : Void
|
||||
#:subscriber (wild) #:observer
|
||||
#:peer-orientation orientation
|
||||
#:conversation topic
|
||||
#:peer-interest-type interest
|
||||
#:reason reason
|
||||
#:on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
|
||||
(name-process `(generic-spy ,label)
|
||||
(spawn: #:parent : ParentState
|
||||
#:child : Void
|
||||
(transition: (void) : Void
|
||||
(observe-publishers: Void (wild)
|
||||
(match-orientation orientation
|
||||
(match-conversation topic
|
||||
(match-interest-type interest
|
||||
(match-reason reason
|
||||
(on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
|
||||
(newline)
|
||||
(flush-output)
|
||||
'())
|
||||
#:on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
|
||||
'()))
|
||||
(on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
|
||||
(newline)
|
||||
(display reason)
|
||||
(newline)
|
||||
(flush-output)
|
||||
'())
|
||||
[p (begin (write `(,label MSG ,p))
|
||||
(newline)
|
||||
(flush-output)
|
||||
'())]))))
|
||||
'()))
|
||||
(on-message
|
||||
[p (begin (write `(,label MSG ,p))
|
||||
(newline)
|
||||
(flush-output)
|
||||
'())]))))))))))
|
||||
|
|
Loading…
Reference in New Issue