Support WSS as well as WS
This commit is contained in:
parent
acc783dc24
commit
5c8948d820
|
@ -1,3 +1,5 @@
|
||||||
|
private-key.pem
|
||||||
|
server-cert.pem
|
||||||
MarketplaceChat.app.zip
|
MarketplaceChat.app.zip
|
||||||
MarketplaceChat.app/
|
MarketplaceChat.app/
|
||||||
scratch/
|
scratch/
|
||||||
|
|
15
Makefile
15
Makefile
|
@ -4,6 +4,21 @@ RESOURCES=$(wildcard app-resources/*)
|
||||||
|
|
||||||
all: $(APP_NAME).zip
|
all: $(APP_NAME).zip
|
||||||
|
|
||||||
|
keys: private-key.pem server-cert.pem
|
||||||
|
|
||||||
|
private-key.pem:
|
||||||
|
openssl genrsa -des3 -passout pass:a -out $@ 1024
|
||||||
|
openssl rsa -passin pass:a -in $@ -out $@
|
||||||
|
|
||||||
|
server-cert.pem: private-key.pem
|
||||||
|
openssl req -new -x509 -nodes -sha1 -days 365 \
|
||||||
|
-subj /CN=chat-demo.js-marketplace.leastfixedpoint.com \
|
||||||
|
-passin pass:a \
|
||||||
|
-key private-key.pem > $@
|
||||||
|
|
||||||
|
clean-keys:
|
||||||
|
rm -f private-key.pem server-cert.pem
|
||||||
|
|
||||||
$(APP_NAME).zip: $(APP_NAME)
|
$(APP_NAME).zip: $(APP_NAME)
|
||||||
zip -r $@ $<
|
zip -r $@ $<
|
||||||
|
|
||||||
|
|
58
server.rkt
58
server.rkt
|
@ -14,20 +14,22 @@
|
||||||
|
|
||||||
(define ping-interval (* 1000 (max (- (ws-idle-timeout) 10) (* (ws-idle-timeout) 0.8))))
|
(define ping-interval (* 1000 (max (- (ws-idle-timeout) 10) (* (ws-idle-timeout) 0.8))))
|
||||||
|
|
||||||
(define any-client (websocket-remote-client ?))
|
|
||||||
(define server-id (websocket-server 8000))
|
|
||||||
|
|
||||||
(spawn-timer-driver)
|
(spawn-timer-driver)
|
||||||
(spawn-websocket-driver)
|
(spawn-websocket-driver)
|
||||||
|
|
||||||
|
(define (spawn-server-listener port ssl-options)
|
||||||
|
(define server-id (websocket-server port ssl-options))
|
||||||
|
(spawn-demand-matcher (websocket-message (websocket-remote-client ?) server-id ?)
|
||||||
|
#:meta-level 1
|
||||||
|
#:demand-is-subscription? #f
|
||||||
|
(match-lambda ;; arrived-demand-route, i.e. new connection publisher
|
||||||
|
[(route _ (websocket-message c _ _) 1 _)
|
||||||
|
(spawn-connection-handler c server-id)]
|
||||||
|
[_ '()])))
|
||||||
|
|
||||||
(spawn-world
|
(spawn-world
|
||||||
(spawn-demand-matcher (websocket-message any-client server-id ?)
|
(spawn-server-listener 8000 #f)
|
||||||
#:meta-level 1
|
(spawn-server-listener 8443 (websocket-ssl-options "server-cert.pem" "private-key.pem")))
|
||||||
#:demand-is-subscription? #f
|
|
||||||
(match-lambda ;; arrived-demand-route, i.e. new connection publisher
|
|
||||||
[(route _ (websocket-message c _ _) 1 _)
|
|
||||||
(spawn-connection-handler c)]
|
|
||||||
[_ '()])))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Wire protocol representation of events and actions
|
;; Wire protocol representation of events and actions
|
||||||
|
@ -73,26 +75,22 @@
|
||||||
|
|
||||||
(struct connection-state (client-id tunnelled-routes) #:transparent)
|
(struct connection-state (client-id tunnelled-routes) #:transparent)
|
||||||
|
|
||||||
(define (send-event e s)
|
(define (spawn-connection-handler c server-id)
|
||||||
(send (websocket-message server-id
|
(define (send-event e s)
|
||||||
(connection-state-client-id s)
|
(send (websocket-message server-id
|
||||||
(jsexpr->string (lift-json-event e)))
|
(connection-state-client-id s)
|
||||||
#:meta-level 1))
|
(jsexpr->string (lift-json-event e)))
|
||||||
|
#:meta-level 1))
|
||||||
(define ((handle-connection-routing-change rs) s)
|
(define ((handle-connection-routing-change rs) s)
|
||||||
(match rs
|
(match rs
|
||||||
['() (transition s (quit))] ;; websocket connection closed
|
['() (transition s (quit))] ;; websocket connection closed
|
||||||
[_ (transition s '())]))
|
[_ (transition s '())]))
|
||||||
|
(define ((handle-tunnelled-routing-change rs) s)
|
||||||
(define ((handle-tunnelled-routing-change rs) s)
|
(transition s (send-event (routing-update rs) s)))
|
||||||
(transition s (send-event (routing-update rs) s)))
|
(define ((handle-tunnellable-message m) s)
|
||||||
|
(if (ormap (lambda (r) (route-accepts? r m)) (connection-state-tunnelled-routes s))
|
||||||
(define ((handle-tunnellable-message m) s)
|
(transition s (send-event m s))
|
||||||
(if (ormap (lambda (r) (route-accepts? r m)) (connection-state-tunnelled-routes s))
|
(transition s '())))
|
||||||
(transition s (send-event m s))
|
|
||||||
(transition s '())))
|
|
||||||
|
|
||||||
(define (spawn-connection-handler c)
|
|
||||||
(define relay-connections
|
(define relay-connections
|
||||||
(list (sub (timer-expired c ?) #:meta-level 1)
|
(list (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)
|
||||||
|
|
Loading…
Reference in New Issue