Implement the described semantics for the disconnect event. #133

Also ensure that `runFunction` and `callFunction`
throw an exception when the connection is broken.

src/Foreign/JavaScript/EventLoop.hs

@@ -10,7 +10,7 @@ import           Control.Applicative
 import           Control.Concurrent
 import           Control.Concurrent.Async
 import           Control.Concurrent.STM   as STM
-import           Control.Exception        as E    (finally)
+import           Control.Exception        as E
 import           Control.Monad
 import qualified Data.Aeson               as JSON
 import           Data.IORef
@@ -61,23 +61,33 @@ eventLoop init comm = do
     handling    <- newTVarIO False
     calling     <- newTVarIO False
 
+    -- We only want to make an FFI call when the connection browser<->server is open
+    -- Otherwise, throw an exception.
+    let atomicallyIfOpen stm = do
+            r <- atomically $ do
+                b <- readTVar (commOpen comm)
+                if b then fmap Right stm else return (Left ())
+            case r of
+                Right a -> return a
+                Left  _ -> error "Foreign.JavaScript: Browser <-> Server communication broken."
+
     -- FFI calls are made by writing to the `calls` queue.
-    w0 <- newPartialWindow
     let run msg = do
-            atomically $ writeTQueue calls (Nothing , msg)
+            atomicallyIfOpen $ writeTQueue calls (Nothing , msg)
         call msg = do
             ref <- newEmptyTMVarIO
-            atomically $ writeTQueue calls (Just ref, msg)
-            atomically $ takeTMVar ref
+            atomicallyIfOpen $ writeTQueue calls (Just ref, msg)
+            atomicallyIfOpen $ takeTMVar ref
         debug    s = do
-            atomically $ writeServer comm $ Debug s
+            atomicallyIfOpen $ writeServer comm $ Debug s
 
     -- We also send a separate event when the client disconnects.
     disconnect <- newTVarIO $ return ()
     let onDisconnect m = atomically $ writeTVar disconnect m
-
-    let w = w0 { runEval        = run  . RunEval
-               , callEval       = call . CallEval
+
+    w0 <- newPartialWindow
+    let w = w0 { runEval      = run  . RunEval
+               , callEval     = call . CallEval
                , debug        = debug
                , timestamp    = run Timestamp
                , onDisconnect = onDisconnect
@@ -87,8 +97,8 @@ eventLoop init comm = do
     --
     -- Read client messages and send them to the
     -- thread that handles events or the thread that handles FFI calls.
-    let multiplexer = do
-            m <- untilJustM $ atomically $ do
+    let multiplexer = void $ untilJustM $ do
+            atomically $ do
                 msg <- readClient comm
                 case msg of
                     Event x y -> do
@@ -99,9 +109,9 @@ eventLoop init comm = do
                     Result x  -> do
                         writeTQueue results x
                         return Nothing
-                    Quit      -> Just <$> readTVar disconnect
-            m
-        
+                    Quit      -> do
+                        return $ Just ()   -- we are done here 
+
     -- Send FFI calls to client and collect results
     let handleCalls = forever $ do
             ref <- atomically $ do
@@ -116,7 +126,7 @@ eventLoop init comm = do
                         result <- readTQueue results
                         putTMVar ref result
                     Nothing  -> return ()
-    
+
     -- Receive events from client and handle them in order.
     let handleEvents = do
             init w
@@ -128,12 +138,15 @@ eventLoop init comm = do
                 rebug
                 atomically $ writeTVar handling False
 
-    -- Foreign.addFinalizer (wRoot w) $ putStrLn "wRoot garbage collected."
-    Foreign.withRemotePtr (wRoot w) $ \_ _ -> do    -- keep root alive
-        E.finally
-            (foldr1 race_ [multiplexer, handleEvents, handleCalls])
-            (commClose comm)
-
+    -- Wrap the main loop into `withRemotePtr` in order to keep the root alive.
+    Foreign.withRemotePtr (wRoot w) $ \_ _ -> do
+            E.finally (foldr1 race_ [multiplexer, handleEvents, handleCalls]) $ do
+                putStrLn "Foreign.JavaScript: Browser window disconnected."
+                -- close communication channel if still necessary
+                commClose comm
+                -- trigger the `disconnect` event
+                m <- atomically $ readTVar disconnect
+                m
     return ()
 
 -- | Repeat an action until it returns 'Just'. Similar to 'forever'.

src/Foreign/JavaScript/Server.hs

@@ -77,7 +77,7 @@ communicationFromWebSocket request = do
             input <- WS.receiveData connection
             case input of
                 "ping" -> WS.sendTextData connection . LBS.pack $ "pong"
-                "quit" -> E.throw WS.ConnectionClosed
+                "quit" -> E.throwIO WS.ConnectionClosed
                 input  -> case JSON.decode input of
                     Just x   -> atomically $ STM.writeTQueue commIn x
                     Nothing  -> error $
@@ -86,15 +86,23 @@ communicationFromWebSocket request = do
 
     -- read/write data until an exception occurs
     thread <- forkFinally (race readData sendData) $ \_ -> do
-        -- close websocket if still necessary/possible
-        WS.sendClose connection $ LBS.pack "close"
+        -- attempt to close websocket if still necessary/possible
+        -- ignore any exceptions that may happen if it's already closed
+        let all :: E.SomeException -> Maybe ()
+            all _ = Just ()
+        E.tryJust all $ WS.sendClose connection $ LBS.pack "close"
+
         -- close the communication channel
         atomically $ do
             STM.writeTVar   commOpen False
             STM.writeTQueue commIn $
                 JSON.object [ "tag" .= ("Quit" :: Text) ] -- write Quit event
+
         -- there is no point in rethrowing the exception, this thread is dead
 
+    -- FIXME: In principle, the thread could be killed *again*
+    -- while the `Comm` is being closed, preventing the `commIn` queue
+    -- from receiving the "Quit" message
     let commClose = killThread thread
 
     return $ Comm {..}
@@ -115,9 +123,9 @@ routeResources customHTML staticDir =
     where
     fixHandlers f routes = [(a,f b) | (a,b) <- routes]
     noCache h = modifyResponse (setHeader "Cache-Control" "no-cache") >> h
-    
+
     static = maybe [] (\dir -> [("/static", serveDirectory dir)]) staticDir
-    
+
     root = case customHTML of
         Just file -> case staticDir of
             Just dir -> serveFile (dir </> file)