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

#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
  (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)
    (tcp-accept 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-driver)
	   (spawn listener))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;