2012-07-16 21:01:56 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
|
|
|
(require racket/port)
|
|
|
|
(require racket/match)
|
|
|
|
(require "os2.rkt")
|
|
|
|
(require "fake-tcp.rkt")
|
|
|
|
|
|
|
|
(define (main)
|
|
|
|
(ground-vm
|
|
|
|
(transition 'none
|
|
|
|
(spawn tcp-driver)
|
|
|
|
(spawn (nested-vm 'chat-vm
|
|
|
|
(transition 'no-state
|
|
|
|
(at-meta-level
|
|
|
|
(role/anon (tcp-listener 5999)
|
|
|
|
#:topic t
|
|
|
|
#:on-presence (spawn (connection-handler t))))))))))
|
|
|
|
|
|
|
|
(define (connection-handler t)
|
|
|
|
(match-define (topic _ (tcp-channel connection-id _ _) _) t)
|
|
|
|
(define-values (cin cout in-topic out-topic) (tcp-accept t))
|
|
|
|
(transition 'no-state
|
|
|
|
(role/anon (topic-publisher `(,connection-id says ,(wild))))
|
|
|
|
(role/anon (topic-subscriber `(,(wild) says ,(wild)))
|
|
|
|
#:topic t
|
2012-07-17 15:58:39 +00:00
|
|
|
#:on-presence (match t [(topic _ (list who _ _) _)
|
|
|
|
(unless (equal? who connection-id)
|
2012-07-16 21:07:42 +00:00
|
|
|
(at-meta-level (cout (term->bytes `(,who arrived)))))])
|
2012-07-17 15:58:39 +00:00
|
|
|
#:on-absence (match t [(topic _ (list who _ _) _)
|
|
|
|
(unless (equal? who connection-id)
|
|
|
|
(at-meta-level (cout (term->bytes `(,who departed)))))])
|
|
|
|
[message (at-meta-level (cout (term->bytes message)))])
|
|
|
|
(at-meta-level (cout (term->bytes `(you-are ,connection-id)))
|
|
|
|
(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 `(,connection-id says ,line)))]))))
|
2012-07-16 21:01:56 +00:00
|
|
|
|
|
|
|
(define (term->bytes v)
|
|
|
|
(with-output-to-bytes (lambda () (write v) (newline))))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
|
|
(main)
|