2016-07-12 19:05:56 +00:00
|
|
|
#lang syndicate/actor
|
2016-05-12 14:48:34 +00:00
|
|
|
;; Websocket server that echoes all it receives
|
|
|
|
|
2016-07-30 17:02:07 +00:00
|
|
|
(require syndicate/protocol/advertise)
|
2016-07-12 19:05:56 +00:00
|
|
|
(require/activate syndicate/drivers/websocket)
|
2016-05-12 14:48:34 +00:00
|
|
|
|
2016-05-15 10:56:29 +00:00
|
|
|
(define any-client any-websocket-remote-client)
|
2016-05-12 14:48:34 +00:00
|
|
|
(define tcp-server-id (websocket-local-server 8081 #f))
|
|
|
|
(define ssl-server-id (websocket-local-server 8084 (websocket-ssl-options "server-cert.pem"
|
|
|
|
"private-key.pem")))
|
|
|
|
|
|
|
|
(actor (forever (assert (advertise (observe (websocket-message any-client tcp-server-id _))))
|
|
|
|
(on (asserted (advertise (websocket-message ($ c any-client) tcp-server-id _)))
|
|
|
|
(handle-connection tcp-server-id c))))
|
|
|
|
(actor (forever (assert (advertise (observe (websocket-message any-client ssl-server-id _))))
|
|
|
|
(on (asserted (advertise (websocket-message ($ c any-client) ssl-server-id _)))
|
|
|
|
(handle-connection ssl-server-id c))))
|
|
|
|
|
|
|
|
(define (handle-connection s c)
|
|
|
|
(actor (until (retracted (advertise (websocket-message c s _)))
|
|
|
|
(on (asserted (websocket-peer-details s c $la _ $ra _))
|
|
|
|
(log-info "~a: local ~v :: remote ~v" c la ra))
|
|
|
|
(on (message (websocket-message c s $body))
|
|
|
|
(log-info "~a: ~v" c body)
|
|
|
|
(send! (websocket-message s c body))))
|
|
|
|
(log-info "~a: disconnected" c)))
|