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")
|
|
|
|
|
|
|
|
(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
|
|
|
|
|
|
|
(define (server-facet/websocket id scope)
|
|
|
|
(assert (http-accepted id))
|
|
|
|
(assert (http-response-websocket id))
|
2019-05-05 15:37:03 +00:00
|
|
|
(assert (server-poa id scope))
|
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
|
|
|
|
|
|
|
(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-05 15:37:03 +00:00
|
|
|
(send! (message-poa->server id packet)))
|
|
|
|
(on (message (message-server->poa id $p))
|
2019-03-25 11:44:12 +00:00
|
|
|
(send! (websocket-out id (encode p)))))
|
|
|
|
|
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
|
|
|
|
(during/spawn (http-request $id 'get (http-resource (http-server _ port #f)
|
|
|
|
`(,$scope ())) _ _ _)
|
2019-05-05 15:37:03 +00:00
|
|
|
#:name `(server-poa ,scope ,id)
|
2019-03-25 11:44:12 +00:00
|
|
|
(server-facet/websocket id scope))))
|