@@ -19,7 +19,8 @@ module Language.Javascript.JSaddle.WebSockets (
1919) where
2020
2121import Control.Monad (forever)
22−import Control.Concurrent (forkIO)
22+import Control.Concurrent (forkIO, threadDelay)
23+import Control.Exception (handle, AsyncException, throwIO, fromException)
2324
2425import Data.Monoid ((<>))
2526import Data.Aeson (encode, decode)
@@ -27,7 +28,7 @@ import Data.Aeson (encode, decode)
2728import Network.Wai (Application)
2829import Network.WebSockets
2930 (ConnectionOptions(..), sendTextData, receiveDataMessage,
30− acceptRequest, ServerApp)
31+ acceptRequest, ServerApp, sendPing)
3132import qualified Network.WebSockets as WS (DataMessage(..))
3233import Network.Wai.Handler.WebSockets (websocketsOr)
3334
@@ -35,6 +36,7 @@ import Language.Javascript.JSaddle.Types (JSM(..))
3536import qualified Network.Wai as W
3637 (responseLBS, requestMethod, Application, pathInfo)
3738import Data.Text (Text)
39+import qualified Data.Text as T (pack)
3840import qualified Network.HTTP.Types as H
3941 (status403, status200, status405)
4042import Language.Javascript.JSaddle.Run (runJavaScript)
@@ -55,6 +57,20 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp
5557 Just r -> processResult r
5658 _ -> error "jsaddle WebSocket unexpected binary data"
5759 start
60+ waitTillClosed conn
61+
62+ -- Based on Network.WebSocket.forkPingThread
63+ waitTillClosed conn = ignore `handle` go 1
64+ where
65+ go :: Int -> IO ()
66+ go i = do
67+ threadDelay (1 * 1000 * 1000)
68+ sendPing conn (T.pack $ show i)
69+ go (i + 1)
70+
71+ ignore e = case fromException e of
72+ Just async -> throwIO (async :: AsyncException)
73+ Nothing -> return ()
5874
5975jsaddleApp :: Application
6076jsaddleApp req = jsaddleAppPieces (W.pathInfo req) req