From 9da480ed0a696f068c8a179d6716b5ea03aa2fb0 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Fri, 1 Nov 2013 10:16:53 -0400
Subject: [PATCH] Keepalive pings

---
 index.js   |  6 ++++++
 server.rkt | 50 ++++++++++++++++++++++++++++++++++----------------
 2 files changed, 40 insertions(+), 16 deletions(-)

diff --git a/index.js b/index.js
index 2cd9c04..41cbc44 100644
--- a/index.js
+++ b/index.js
@@ -231,7 +231,13 @@ WebSocketConnection.prototype.onopen = function (e) {
 
 WebSocketConnection.prototype.onmessage = function (wse) {
     // console.log("onmessage", wse);
+
     var j = JSON.parse(wse.data);
+    if (j === "ping") {
+	this.sock.send(JSON.stringify("pong"));
+	return;
+    }
+
     var e = decodeAction(j);
     switch (e.type) {
     case "routes":
diff --git a/server.rkt b/server.rkt
index 22986e8..f2571c7 100644
--- a/server.rkt
+++ b/server.rkt
@@ -1,6 +1,7 @@
 #lang minimart
 
 (require net/rfc6455)
+(require minimart/drivers/timer)
 (require minimart/drivers/websocket)
 (require minimart/demand-matcher)
 (require minimart/pattern)
@@ -9,14 +10,16 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Main: start WebSocket server
 
-;; (ws-idle-timeout 3) ;; TODO: deal with reconnects, and then remove
 (log-events-and-actions? #f)
 
-(spawn-websocket-driver)
+(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)
+
 (spawn-world
  (spawn-demand-matcher (websocket-message any-client server-id ?)
 		       #:meta-level 1
@@ -42,6 +45,8 @@
 
 (define (drop-json-action j)
   (match j
+    ["ping" 'ping]
+    ["pong" 'pong]
     [`("routes" ,routes) (routing-update (map drop-json-route routes))]
     [`("message" ,body ,meta-level ,feedback?) (message body meta-level feedback?)]))
 
@@ -54,6 +59,8 @@
 
 (define (lift-json-event j)
   (match j
+    ['ping "ping"]
+    ['pong "pong"]
     [(routing-update rs) `("routes" ,(map lift-json-route rs))]
     [(message body meta-level feedback?) `("message" ,body ,meta-level ,feedback?)]))
 
@@ -87,7 +94,8 @@
 
 (define (spawn-connection-handler c)
   (define relay-connections
-    (list (sub (websocket-message c server-id ?) #: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 #:level 1)
 	  (pub (websocket-message server-id c ?) #:meta-level 1)))
   (define (connection-handler e s)
@@ -98,18 +106,28 @@
 	(handle-connection-routing-change (intersect-routes rs relay-connections))
 	(handle-tunnelled-routing-change
 	 (intersect-routes rs (connection-state-tunnelled-routes s))))]
-      [(and wsm (message (websocket-message from to data) 1 #f))
-       (sequence-transitions
-	(match (drop-json-action (string->jsexpr data))
-	  [(routing-update rs)
-	   (transition (struct-copy connection-state s [tunnelled-routes rs])
-		       (routing-update (append rs relay-connections)))]
-	  [(? message? m)
-	   (transition s m)])
-	(handle-tunnellable-message wsm))]
       [(? message? m)
-       ((handle-tunnellable-message m) s)]
+       (sequence-transitions
+	(match m
+	  [(message (websocket-message from to data) 1 #f)
+	   (match (drop-json-action (string->jsexpr data))
+	     [(routing-update rs)
+	      (transition (struct-copy connection-state s [tunnelled-routes rs])
+			  (routing-update (append rs relay-connections)))]
+	     [(? message? m)
+	      (transition s 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]))
-  (spawn connection-handler
-	 (connection-state c '())
-	 relay-connections))
+  (list (send (set-timer c ping-interval 'relative) #:meta-level 1)
+	(spawn connection-handler
+	       (connection-state c '())
+	       relay-connections)))