tcp2

racket/syndicate/drivers/tcp2.rkt

@@ -0,0 +1,53 @@
+#lang syndicate
+;; Crude simplified TCP/IP driver interface. Should probably be fleshed out and made the primary
+;; one, with tcp.rkt becoming deprecated and ultimately deleted.
+;;
+;; A nice refinement would be to introduce something like a `(tcp-error id _)` assertion, for when
+;; something goes wrong listening or connecting. At present, for example, if connecting to some
+;; other host that isn't listening, the tcp.rkt driver pretends the connection is open for an
+;; infinitesimal instant before closing. This would be nicer if it never signalled "open" at all,
+;; instead asserting something like `tcp-error` until interest in the connection goes away.
+
+(provide (struct-out tcp-connection)
+         (struct-out tcp-accepted)
+         (struct-out tcp-out)
+         (struct-out tcp-in)
+         (struct-out tcp-address)  ;; \_ From syndicate/drivers/tcp
+         (struct-out tcp-listener) ;; /
+         )
+
+(require syndicate/protocol/advertise)
+(require/activate syndicate/drivers/tcp)
+
+(struct tcp-connection (id spec) #:prefab)
+(struct tcp-accepted (id) #:prefab)
+(struct tcp-out (id text) #:prefab)
+(struct tcp-in (id text) #:prefab)
+
+(spawn #:name 'tcp2-listen-driver
+       (during/spawn (observe (tcp-connection _ (tcp-listener $port)))
+         #:name (list 'tcp2-listener port)
+         (define us (tcp-listener port))
+         (assert (advertise (observe (tcp-channel _ us _))))
+         (on (asserted (advertise (tcp-channel $them us _)))
+             (define id (seal (list them us)))
+             (spawn #:name (list 'tcp2 'inbound id us)
+                    (stop-when (retracted (advertise (tcp-channel them us _))))
+                    (stop-when (retracted (tcp-accepted id)))
+                    (assert (tcp-connection id us))
+                    (on (message (tcp-channel them us $bs)) (send! (tcp-in id bs)))
+                    (on (message (tcp-out id $bs)) (send! (tcp-channel us them bs)))))))
+
+(spawn #:name 'tcp2-connect-driver
+       (during/spawn (tcp-connection $id (tcp-address $host $port))
+         #:name (list 'tcp2 'outbound (tcp-address host port) id)
+         (define root-facet (current-facet-id))
+         (define them (tcp-address host port))
+         (define us (tcp-handle (seal id)))
+         (during (advertise (tcp-channel them us _))
+           (assert (tcp-accepted id))
+           (on-stop (stop-facet root-facet)))
+         (assert (advertise (tcp-channel us them _)))
+         (on (message (tcp-channel them us $bs)) (send! (tcp-in id bs)))
+         (on (message (tcp-out id $bs)) (send! (tcp-channel us them bs)))))
+

racket/syndicate/examples/actor/chat-client-tcp2.rkt

@@ -0,0 +1,16 @@
+#lang syndicate
+
+(require/activate syndicate/drivers/tcp2)
+(require (only-in racket/port read-bytes-line-evt))
+
+(spawn (define id 'chat)
+       (assert (tcp-connection id (tcp-address "localhost" 5999)))
+       (stop-when (retracted (tcp-accepted id)))
+       (on (message (tcp-in id $bs))
+           (write-bytes bs)
+           (flush-output))
+
+       (define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
+       (stop-when (message (inbound (external-event stdin-evt (list (? eof-object? _))))))
+       (on (message (inbound (external-event stdin-evt (list (? bytes? $line)))))
+           (send! (tcp-out id line))))

racket/syndicate/examples/actor/chat-tcp2.rkt

@@ -0,0 +1,23 @@
+#lang syndicate
+;; A version of chat-simplified-internals2.rkt that has the simplified TCP
+;; driver split out into syndicate/drivers/tcp2.
+
+(require/activate syndicate/drivers/tcp2)
+(require (only-in racket/string string-trim))
+(require racket/format)
+
+(struct speak (who what) #:prefab)
+(struct present (who) #:prefab)
+
+(spawn #:name 'chat-server
+ (during/spawn (tcp-connection $id (tcp-listener 5999))
+   (assert (tcp-accepted id))
+   (let ((me (gensym 'user)))
+     (assert (present me))
+     (on (message (tcp-in id $bs))
+         (send! (speak me (string-trim (bytes->string/utf-8 bs))))))
+   (during (present $user)
+     (on-start (send! (tcp-out id (string->bytes/utf-8 (~a user " arrived\n")))))
+     (on-stop  (send! (tcp-out id (string->bytes/utf-8 (~a user " left\n")))))
+     (on (message (speak user $text))
+         (send! (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))