2019-03-25 11:44:12 +00:00
|
|
|
#lang imperative-syndicate
|
|
|
|
|
|
|
|
(provide server-facet/websocket
|
2019-05-05 15:37:03 +00:00
|
|
|
default-http-server-port
|
|
|
|
spawn-websocket-server!)
|
2019-03-25 11:44:12 +00:00
|
|
|
|
|
|
|
(require "../wire-protocol.rkt")
|
2019-05-09 10:17:37 +00:00
|
|
|
(require "../internal-protocol.rkt")
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-12 12:07:38 +00:00
|
|
|
(require imperative-syndicate/protocol/credit)
|
|
|
|
|
2019-03-25 11:44:12 +00:00
|
|
|
(require/activate imperative-syndicate/drivers/web)
|
|
|
|
(require/activate imperative-syndicate/drivers/timer)
|
2019-05-05 15:51:23 +00:00
|
|
|
(require/activate imperative-syndicate/distributed/server)
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-07 11:56:22 +00:00
|
|
|
(define (server-facet/websocket id)
|
2019-03-25 11:44:12 +00:00
|
|
|
(assert (http-accepted id))
|
|
|
|
(assert (http-response-websocket id))
|
2019-05-07 11:56:22 +00:00
|
|
|
(assert (server-poa id))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
|
|
|
(field [ping-time-deadline 0])
|
|
|
|
(on (asserted (later-than (ping-time-deadline)))
|
|
|
|
(ping-time-deadline (+ (current-inexact-milliseconds) (ping-interval)))
|
2019-05-05 15:37:03 +00:00
|
|
|
(send! (message-server->poa id (Ping))))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-12 12:07:38 +00:00
|
|
|
(define !! (make-flow-controlled-sender message-poa->server id))
|
2019-03-25 11:44:12 +00:00
|
|
|
(on (message (websocket-in id $body))
|
|
|
|
(define-values (packet remainder) (decode body))
|
|
|
|
(when (not (equal? remainder #""))
|
|
|
|
(error 'server-facet/websocket "Multiple packets in a single websocket message"))
|
2019-05-12 12:07:38 +00:00
|
|
|
(!! (message-poa->server id packet)))
|
2019-05-05 15:37:03 +00:00
|
|
|
(on (message (message-server->poa id $p))
|
2019-05-16 12:12:21 +00:00
|
|
|
(send! (websocket-out id (encode p)))
|
|
|
|
(when (Err? p) (stop-current-facet))))
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-05 15:37:03 +00:00
|
|
|
(define default-http-server-port 8000)
|
2019-03-25 11:44:12 +00:00
|
|
|
|
2019-05-05 15:37:03 +00:00
|
|
|
(define (spawn-websocket-server! [port default-http-server-port])
|
2019-03-25 11:44:12 +00:00
|
|
|
(spawn #:name 'websocket-server-listener
|
2019-05-16 11:37:39 +00:00
|
|
|
(during/spawn (http-request $id 'get (http-resource (http-server _ port #f) `("" ())) _ _ _)
|
2019-05-07 11:56:22 +00:00
|
|
|
#:name `(server-poa ,id)
|
|
|
|
(server-facet/websocket id))))
|