Exactly the code from the paper
This commit is contained in:
parent
5062895429
commit
0a5906e116
|
@ -0,0 +1,59 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/list)
|
||||
(require racket/port)
|
||||
(require racket/match)
|
||||
(require "os2.rkt")
|
||||
(require "fake-tcp.rkt")
|
||||
|
||||
(define (term->bytes v)
|
||||
(with-output-to-bytes (lambda () (write v) (newline))))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define listener-proc
|
||||
(transition 'no-state
|
||||
(at-meta-level
|
||||
(role/anon (tcp-listener 5999)
|
||||
#:topic t
|
||||
#:on-presence
|
||||
(spawn (connection-handler t))))))
|
||||
|
||||
(define (connection-handler t)
|
||||
(define me (gensym 'user))
|
||||
(define-values (cin cout in-topic out-topic) (tcp-accept t))
|
||||
(transition 'no-state
|
||||
(peer-to-peer-roles me cout)
|
||||
(relay-to-tcp-roles me cin cout in-topic out-topic)))
|
||||
|
||||
(define (peer-to-peer-roles me cout)
|
||||
(define (announce t did-what)
|
||||
(unless (equal? (speaker t) me)
|
||||
(at-meta-level (cout (term->bytes `(,(speaker t) ,did-what))))))
|
||||
(list (role/anon (topic-publisher `(,me says ,(wild))))
|
||||
(role/anon (topic-subscriber `(,(wild) says ,(wild)))
|
||||
#:topic t
|
||||
#:on-presence (announce t 'arrived)
|
||||
#:on-absence (announce t 'departed)
|
||||
[message (at-meta-level (cout (term->bytes message)))])))
|
||||
|
||||
(define (speaker t)
|
||||
(first (topic-pattern t)))
|
||||
|
||||
(define (relay-to-tcp-roles me cin cout in-topic out-topic)
|
||||
(at-meta-level
|
||||
(cout (term->bytes `(you-are ,me)))
|
||||
(cin (tcp-mode 'lines))
|
||||
(cin (tcp-credit 1))
|
||||
(role/anon out-topic)
|
||||
(role/anon in-topic
|
||||
#:on-absence (kill)
|
||||
[(tcp-channel _ _ (? bytes? line))
|
||||
(list (at-meta-level (cin (tcp-credit 1)))
|
||||
(send-message
|
||||
`(,me says ,line)))])))
|
||||
|
||||
(ground-vm
|
||||
(transition 'no-state
|
||||
(spawn tcp-driver)
|
||||
(spawn (nested-vm 'app-vm listener-proc))))
|
Loading…
Reference in New Issue