diff --git a/.gitignore b/.gitignore index afce858..2d0c686 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,5 @@ +private-key.pem +server-cert.pem MarketplaceChat.app.zip MarketplaceChat.app/ scratch/ diff --git a/Makefile b/Makefile index 1825172..4df59f9 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,21 @@ RESOURCES=$(wildcard app-resources/*) 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) zip -r $@ $< diff --git a/server.rkt b/server.rkt index 3bd6c7c..b6610d6 100644 --- a/server.rkt +++ b/server.rkt @@ -14,20 +14,22 @@ (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-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-demand-matcher (websocket-message any-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)] - [_ '()]))) + (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 @@ -73,26 +75,22 @@ (struct connection-state (client-id tunnelled-routes) #:transparent) -(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 rs) s) - (match rs - ['() (transition s (quit))] ;; websocket connection closed - [_ (transition s '())])) - -(define ((handle-tunnelled-routing-change 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)) - (transition s (send-event m s)) - (transition s '()))) - -(define (spawn-connection-handler c) +(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 rs) s) + (match rs + ['() (transition s (quit))] ;; websocket connection closed + [_ (transition s '())])) + (define ((handle-tunnelled-routing-change 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)) + (transition s (send-event m s)) + (transition s '()))) (define relay-connections (list (sub (timer-expired c ?) #:meta-level 1) (sub (websocket-message c server-id ?) #:meta-level 1)