Exactly the code from the paper

This commit is contained in:
Tony Garnock-Jones 2012-07-23 12:12:14 -04:00
parent 5062895429
commit 0a5906e116
1 changed files with 59 additions and 0 deletions

59
chat-os2-paper.rkt Normal file
View File

@ -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))))