diff --git a/server.rkt b/server.rkt index a9b739e..2fb7935 100644 --- a/server.rkt +++ b/server.rkt @@ -1,112 +1,12 @@ #lang minimart ;; Generic broker for WebSockets-based minimart/marketplace communication. -(require racket/set) -(require net/rfc6455) (require minimart/drivers/timer) (require minimart/drivers/websocket) -(require minimart/demand-matcher) -(require json) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Main: start WebSocket server - -(log-events-and-actions? #f) - -(define ping-interval (* 1000 (max (- (ws-idle-timeout) 10) (* (ws-idle-timeout) 0.8)))) +(require minimart/relay) (spawn-timer-driver) (spawn-websocket-driver) - -(define (spawn-server-listener port ssl-options) - (define server-id (websocket-local-server port ssl-options)) - (spawn-demand-matcher (websocket-message (?! (websocket-remote-client ?)) server-id ?) - #:meta-level 1 - (lambda (c) (spawn-connection-handler c server-id)))) - (spawn-world - (spawn-server-listener 8000 #f) - (spawn-server-listener 8443 (websocket-ssl-options "server-cert.pem" "private-key.pem"))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Wire protocol representation of events and actions - -(define (drop-json-action j) - (match j - ["ping" 'ping] - ["pong" 'pong] - [`("routes" ,gj) (routing-update (jsexpr->gestalt gj (lambda (v) (set 'peer))))] - [`("message" ,body ,meta-level ,feedback?) (message body meta-level feedback?)])) - -(define (lift-json-event j) - (match j - ['ping "ping"] - ['pong "pong"] - [(routing-update g) `("routes" ,(gestalt->jsexpr g (lambda (v) #t)))] - [(message body meta-level feedback?) `("message" ,body ,meta-level ,feedback?)])) - -(require racket/trace) -(trace drop-json-action) -(trace lift-json-event) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Connections - -(struct connection-state (client-id tunnelled-gestalt) #:transparent) - -(define (spawn-connection-handler c server-id) - (define (send-event e s) - (send (websocket-message server-id - (connection-state-client-id s) - (jsexpr->string (lift-json-event e))) - #:meta-level 1)) - (define ((handle-connection-routing-change g) s) - (if (gestalt-empty? g) - (transition s (quit)) ;; websocket connection closed - #f)) - (define ((handle-tunnelled-routing-change g) s) - (transition s (send-event (routing-update g) s))) - (define ((handle-tunnellable-message m) s) - (if (gestalt-accepts? (connection-state-tunnelled-gestalt s) m) - (transition s (send-event m s)) - (transition s '()))) - (define relay-connections - (gestalt-union (sub (timer-expired c ?) #:meta-level 1) - (sub (websocket-message c server-id ?) #:meta-level 1) - (sub (websocket-message c server-id ?) #:meta-level 1 #:level 1) - (pub (websocket-message server-id c ?) #:meta-level 1))) - (define (connection-handler e s) - (match e - [(routing-update g) - (sequence-transitions - (transition s '()) - (handle-connection-routing-change (gestalt-filter g relay-connections)) - (handle-tunnelled-routing-change - (gestalt-filter g (connection-state-tunnelled-gestalt s))))] - [(? message? m) - (sequence-transitions - (match m - [(message (websocket-message from to data) 1 #f) - (match (drop-json-action (string->jsexpr data)) - [(routing-update g-unfiltered) - (define g (gestalt-transform g-unfiltered - (lambda (ml l p) (if (zero? ml) p '(#f . #f))))) - (transition (struct-copy connection-state s [tunnelled-gestalt g]) - (routing-update (gestalt-union g relay-connections)))] - [(? message? m) - (transition s (if (zero? (message-meta-level m)) m '()))] - ['ping - (transition s (send-event 'pong s))] - ['pong - (transition s '())])] - [(message (timer-expired _ _) 1 #f) - (transition s (list (send (set-timer c ping-interval 'relative) #:meta-level 1) - (send-event 'ping s)))] - [_ - (transition s '())]) - (handle-tunnellable-message m))] - [#f #f])) - (list (send (set-timer c ping-interval 'relative) #:meta-level 1) - (spawn connection-handler - (connection-state c (gestalt-empty)) - relay-connections))) + (spawn-websocket-relay 8000) + (spawn-websocket-relay 8443 (websocket-ssl-options "server-cert.pem" "private-key.pem")))