2013-10-28 19:08:41 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
|
|
|
(require racket/match)
|
|
|
|
(require net/rfc6455)
|
2014-05-22 03:22:21 +00:00
|
|
|
(require (only-in net/rfc6455/conn-api ws-conn-base-ip))
|
2013-10-28 19:08:41 +00:00
|
|
|
(require "../main.rkt")
|
|
|
|
(require "../demand-matcher.rkt")
|
|
|
|
|
2013-11-06 21:01:55 +00:00
|
|
|
(require racket/unit)
|
|
|
|
(require net/tcp-sig)
|
|
|
|
(require net/tcp-unit)
|
|
|
|
(require net/ssl-tcp-unit)
|
|
|
|
|
2013-10-28 19:08:41 +00:00
|
|
|
(provide (struct-out websocket-remote-client)
|
2014-01-14 00:33:48 +00:00
|
|
|
(struct-out websocket-local-server)
|
2013-11-06 21:01:55 +00:00
|
|
|
(struct-out websocket-ssl-options)
|
2013-10-28 19:08:41 +00:00
|
|
|
(struct-out websocket-message)
|
|
|
|
spawn-websocket-driver)
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Protocol messages
|
|
|
|
|
|
|
|
(struct websocket-remote-client (id) #:prefab)
|
2014-01-14 00:33:48 +00:00
|
|
|
(struct websocket-local-server (port ssl-options) #:prefab)
|
2013-11-06 21:01:55 +00:00
|
|
|
(struct websocket-ssl-options (cert-file key-file) #:prefab)
|
2013-10-28 19:08:41 +00:00
|
|
|
(struct websocket-message (from to body) #:prefab)
|
|
|
|
|
2014-06-11 20:03:22 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Ground-level communication messages
|
|
|
|
|
2014-06-15 00:50:03 +00:00
|
|
|
(struct websocket-accepted (id server-addr connection control-ch) #:prefab)
|
2014-06-11 20:03:22 +00:00
|
|
|
(struct websocket-incoming-message (id message) #:prefab)
|
|
|
|
|
2013-10-28 19:08:41 +00:00
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Driver
|
|
|
|
|
|
|
|
(define (spawn-websocket-driver)
|
2014-05-22 03:22:21 +00:00
|
|
|
(spawn-demand-matcher (websocket-message ? (?! (websocket-local-server ? ?)) ?)
|
2014-06-06 22:07:58 +00:00
|
|
|
#:demand-is-subscription? #t
|
2013-10-28 19:08:41 +00:00
|
|
|
#:demand-level 1
|
|
|
|
#:supply-level 2
|
2014-05-22 03:22:21 +00:00
|
|
|
spawn-websocket-listener))
|
2013-10-28 19:08:41 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Listener
|
|
|
|
|
2013-11-06 21:01:55 +00:00
|
|
|
(struct listener-state (shutdown-procedure server-addr) #:transparent)
|
2013-10-28 19:08:41 +00:00
|
|
|
|
|
|
|
(define (websocket-listener e state)
|
|
|
|
(match e
|
2014-05-22 03:22:21 +00:00
|
|
|
[(routing-update g)
|
2013-11-06 21:01:55 +00:00
|
|
|
(match-define (listener-state shutdown-procedure server-addr) state)
|
2014-05-22 03:22:21 +00:00
|
|
|
(if (gestalt-empty? (gestalt-filter g (pub (websocket-message ? server-addr ?) #:level 2)))
|
2013-10-28 19:08:41 +00:00
|
|
|
(begin (when shutdown-procedure (shutdown-procedure))
|
2014-05-22 03:22:21 +00:00
|
|
|
(transition (struct-copy listener-state state [shutdown-procedure #f]) (quit)))
|
|
|
|
#f)]
|
2014-06-15 00:50:03 +00:00
|
|
|
[(message (websocket-accepted id _ c control-ch) 1 #f)
|
2013-10-28 19:08:41 +00:00
|
|
|
(transition state
|
2014-06-11 20:03:22 +00:00
|
|
|
(spawn-connection (listener-state-server-addr state) id c control-ch))]
|
2013-10-28 19:08:41 +00:00
|
|
|
[_ #f]))
|
|
|
|
|
2014-06-15 00:50:03 +00:00
|
|
|
(define ((connection-handler server-addr) c dummy-state)
|
2014-06-11 20:03:22 +00:00
|
|
|
(define control-ch (make-channel))
|
|
|
|
(define c-input-port (ws-conn-base-ip c))
|
|
|
|
(define id (gensym 'ws))
|
2014-06-15 00:50:03 +00:00
|
|
|
(send-ground-message (websocket-accepted id server-addr c control-ch))
|
2014-06-11 20:03:22 +00:00
|
|
|
(let loop ((blocked? #t))
|
|
|
|
(sync (handle-evt control-ch
|
|
|
|
(match-lambda
|
|
|
|
['unblock (loop #f)]
|
|
|
|
['quit (void)]))
|
|
|
|
(if blocked?
|
|
|
|
never-evt
|
|
|
|
(handle-evt c-input-port
|
|
|
|
(lambda (dummy)
|
|
|
|
(define msg (ws-recv c #:payload-type 'text))
|
|
|
|
(send-ground-message (websocket-incoming-message id msg))
|
|
|
|
(loop (or blocked? (eof-object? msg))))))))
|
2013-10-28 19:08:41 +00:00
|
|
|
(ws-close! c))
|
|
|
|
|
2013-11-06 21:01:55 +00:00
|
|
|
(define (ssl-options->ssl-tcp@ ssl-options)
|
|
|
|
(match-define (websocket-ssl-options cert-file key-file) ssl-options)
|
|
|
|
(define-unit-binding ssl-tcp@
|
|
|
|
(make-ssl-tcp@ cert-file key-file #f #f #f #f #f)
|
|
|
|
(import)
|
|
|
|
(export tcp^))
|
|
|
|
ssl-tcp@)
|
|
|
|
|
|
|
|
(define (spawn-websocket-listener server-addr)
|
2014-01-14 00:33:48 +00:00
|
|
|
(match-define (websocket-local-server port ssl-options) server-addr)
|
2013-11-06 21:01:55 +00:00
|
|
|
(define shutdown-procedure (ws-serve #:port port
|
|
|
|
#:tcp@ (if ssl-options
|
|
|
|
(ssl-options->ssl-tcp@ ssl-options)
|
|
|
|
tcp@)
|
2014-06-15 00:50:03 +00:00
|
|
|
(connection-handler server-addr)))
|
2013-10-28 19:08:41 +00:00
|
|
|
(spawn websocket-listener
|
2013-11-06 21:01:55 +00:00
|
|
|
(listener-state shutdown-procedure server-addr)
|
2014-05-22 03:22:21 +00:00
|
|
|
(gestalt-union (pub (websocket-message ? server-addr ?) #:level 2)
|
2014-06-15 00:50:03 +00:00
|
|
|
(sub (websocket-accepted ? server-addr ? ?) #:meta-level 1))))
|
2013-10-28 19:08:41 +00:00
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Connection
|
|
|
|
|
2014-06-11 20:03:22 +00:00
|
|
|
(struct connection-state (seen-peer? local-addr server-addr c control-ch) #:transparent)
|
2013-10-28 19:08:41 +00:00
|
|
|
|
|
|
|
(define (shutdown-connection state)
|
2014-06-11 20:03:22 +00:00
|
|
|
(transition (match (connection-state-control-ch state)
|
|
|
|
[#f state]
|
|
|
|
[ch (channel-put ch 'quit)
|
|
|
|
(struct-copy connection-state state [control-ch #f])])
|
|
|
|
(quit)))
|
2013-10-28 19:08:41 +00:00
|
|
|
|
|
|
|
(define (websocket-connection e state)
|
2013-10-30 14:25:48 +00:00
|
|
|
(with-handlers [((lambda (exn) #t)
|
|
|
|
(lambda (exn) (shutdown-connection state)))]
|
|
|
|
(match e
|
2014-06-11 20:03:22 +00:00
|
|
|
[(message (websocket-incoming-message _ m) 1 #f)
|
|
|
|
(if (eof-object? m)
|
|
|
|
(shutdown-connection state)
|
|
|
|
(transition state (send (websocket-message (connection-state-local-addr state)
|
|
|
|
(connection-state-server-addr state)
|
|
|
|
m))))]
|
2013-10-30 14:25:48 +00:00
|
|
|
[(message (websocket-message _ _ m) 0 #f)
|
|
|
|
(ws-send! (connection-state-c state) m)
|
|
|
|
#f]
|
2014-05-22 03:22:21 +00:00
|
|
|
[(routing-update g)
|
2013-10-30 14:25:48 +00:00
|
|
|
(cond
|
2014-05-22 03:22:21 +00:00
|
|
|
[(and (connection-state-seen-peer? state) (gestalt-empty? g))
|
2013-10-30 14:25:48 +00:00
|
|
|
(shutdown-connection state)]
|
2014-05-22 03:22:21 +00:00
|
|
|
[(and (not (connection-state-seen-peer? state)) (not (gestalt-empty? g)))
|
2014-06-11 20:03:22 +00:00
|
|
|
(channel-put (connection-state-control-ch state) 'unblock)
|
2013-10-30 14:25:48 +00:00
|
|
|
(transition (struct-copy connection-state state [seen-peer? #t]) '())]
|
|
|
|
[else
|
|
|
|
#f])]
|
|
|
|
[#f #f])))
|
2013-10-28 19:08:41 +00:00
|
|
|
|
2014-06-11 20:03:22 +00:00
|
|
|
(define (spawn-connection server-addr id c control-ch)
|
|
|
|
(define local-addr (websocket-remote-client id))
|
2013-10-28 19:08:41 +00:00
|
|
|
(spawn websocket-connection
|
2014-06-11 20:03:22 +00:00
|
|
|
(connection-state #f local-addr server-addr c control-ch)
|
2014-05-22 03:22:21 +00:00
|
|
|
(gestalt-union (pub (websocket-message local-addr server-addr ?))
|
|
|
|
(sub (websocket-message server-addr local-addr ?))
|
|
|
|
(sub (websocket-message server-addr local-addr ?) #:level 1)
|
2014-06-11 20:03:22 +00:00
|
|
|
(sub (websocket-incoming-message id ?) #:meta-level 1))))
|