racket-matrix-2012/chat-os2-paper.rkt

69 lines
1.7 KiB
Racket

#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 tcp tcp-driver)
;;---------------------------------------------------------------------------
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define listener
(nested-vm
(at-meta-level
(role (tcp-listener 5999)
#:topic t
#:on-presence
(spawn (connection-handler t))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (connection-handler t)
(define me (gensym 'user))
(define-values (cin cout in-t out-t)
(topic->tcp-connection t))
(transition 'no-state
(net-roles me cin cout in-t out-t)
(chat-roles me cout)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (net-roles me cin cout in-t out-t)
(at-meta-level
(cout (term->bytes `(you-are ,me)))
(cin (tcp-mode 'lines))
(cin (tcp-credit 1))
(role out-t)
(role in-t
#:on-absence (quit)
[(tcp-channel _ _ (? bytes? line))
(list (at-meta-level
(cin (tcp-credit 1)))
(send-message
`(,me says ,line)))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (chat-roles me cout)
(define (announce t did-what)
(define who (first (topic-pattern t)))
(unless (equal? who me)
(at-meta-level
(cout (term->bytes
`(,who ,did-what))))))
(list
(role (topic-publisher `(,me says ,?)))
(role (topic-subscriber `(,? says ,?))
#:topic t
#:on-presence (announce t 'arrived)
#:on-absence (announce t 'departed)
[msg (at-meta-level
(cout (term->bytes msg)))])))
(ground-vm (spawn tcp) (spawn listener))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;