More cosmetic tweaks
This commit is contained in:
parent
e7a630c6e9
commit
fc463db770
|
@ -20,17 +20,31 @@
|
||||||
#:on-presence
|
#:on-presence
|
||||||
(spawn (connection-handler t))))))
|
(spawn (connection-handler t))))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
(define (connection-handler t)
|
(define (connection-handler t)
|
||||||
(define me (gensym 'user))
|
(define me (gensym 'user))
|
||||||
(define-values
|
(define-values (cin cout in-t out-t)
|
||||||
(cin cout in-topic out-topic)
|
|
||||||
(tcp-accept t))
|
(tcp-accept t))
|
||||||
(transition 'no-state
|
(transition 'no-state
|
||||||
(net-roles me cin cout
|
(net-roles me cin cout in-t out-t)
|
||||||
in-topic out-topic)
|
|
||||||
(chat-roles me cout)))
|
(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 (kill)
|
||||||
|
[(tcp-channel _ _ (? bytes? line))
|
||||||
|
(list (at-meta-level
|
||||||
|
(cin (tcp-credit 1)))
|
||||||
|
(send-message
|
||||||
|
`(,me says ,line)))])))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
(define (chat-roles me cout)
|
(define (chat-roles me cout)
|
||||||
(define (announce t did-what)
|
(define (announce t did-what)
|
||||||
(define who (first (topic-pattern t)))
|
(define who (first (topic-pattern t)))
|
||||||
|
@ -49,22 +63,6 @@
|
||||||
[msg (at-meta-level
|
[msg (at-meta-level
|
||||||
(cout (term->bytes msg)))])))
|
(cout (term->bytes msg)))])))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
(define (net-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 out-topic)
|
|
||||||
(role in-topic
|
|
||||||
#:on-absence (kill)
|
|
||||||
[(tcp-channel _ _ (? bytes? line))
|
|
||||||
(list (at-meta-level
|
|
||||||
(cin (tcp-credit 1)))
|
|
||||||
(send-message
|
|
||||||
`(,me says ,line)))])))
|
|
||||||
|
|
||||||
(ground-vm
|
(ground-vm
|
||||||
(spawn tcp-driver)
|
(spawn tcp-driver)
|
||||||
(spawn listener))
|
(spawn listener))
|
||||||
|
|
Loading…
Reference in New Issue