syndicate-rkt/syndicate/broker/server.rkt

#lang imperative-syndicate

(provide server-facet/tcp
         server-facet/websocket)

(require "wire-protocol.rkt")

(require/activate imperative-syndicate/drivers/tcp)
(require/activate imperative-syndicate/drivers/web)
(require/activate imperative-syndicate/drivers/timer)
(require/activate imperative-syndicate/broker/server-connection)

(define-logger syndicate/broker)

(define (server-facet/tcp id scope)
  (assert (tcp-accepted id))
  (assert (server-connection id scope))
  (define accumulate! (packet-accumulator (lambda (p) (send! (server-inbound id p)))))
  (on (message (tcp-in id $bs))
      (accumulate! bs))
  (on (message (server-outbound id $p))
      (send! (tcp-out id (encode p)))))

(define (server-facet/websocket id scope)
  (assert (http-accepted id))
  (assert (http-response-websocket id))
  (assert (server-connection id scope))

  (field [ping-time-deadline 0])
  (on (asserted (later-than (ping-time-deadline)))
      (ping-time-deadline (+ (current-inexact-milliseconds) (ping-interval)))
      (send! (server-outbound id (Ping))))

  (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"))
      (send! (server-inbound id packet)))
  (on (message (server-outbound id $p))
      (send! (websocket-out id (encode p)))))

(when (log-level? syndicate/broker-logger 'debug)
  (spawn #:name 'server-debug
         (on (asserted (server-connection $id $scope))
             (log-syndicate/broker-debug "C+ ~v ~v" id scope))
         (on (retracted (server-connection $id $scope))
             (log-syndicate/broker-debug "C- ~v ~v" id scope))
         (on (message (server-inbound $id $p))
             (log-syndicate/broker-debug "CIN  ~v ~v" id p))
         (on (message (server-outbound $id $p))
             (log-syndicate/broker-debug "COUT ~v ~v" id p))))