I am writing a game server in Haskell with websockets. I need to time a player action and update the game with a timeout action is the socket does not receive an action from the client in the specified amount of time.
I am experiencing a sporadic issue whereby sometimes the execution of the timeout results in a ConnectionClosed exception being thrown. If this exception is not caught then the exception kills the socket for the thread and disconnects the client.
However even if I catch the exception as per the code below the client socket is still disconnected. This puzzles me.
I found a similar issue on the tracker of the websockets library I am using:
If a thread is killed while receiveData or similar is blocking, the
TCP connection is closed and a ConnectionClosed exception is thrown.
https://github.com/jaspervdj/websockets/issues/101
handleSocketMsg :: MsgHandlerConfig -> MsgIn -> IO ()
handleSocketMsg msgHandlerConfig#MsgHandlerConfig {..} msg = do
print $ "parsed msg: " ++ show msg
msgOutE <- runExceptT $ runReaderT (gameMsgHandler msg) msgHandlerConfig
either
(\err -> sendMsg clientConn $ ErrMsg err)
(handleNewGameState serverStateTVar)
msgOutE
-- This function processes msgs from authenticated clients
authenticatedMsgLoop :: MsgHandlerConfig -> IO ()
authenticatedMsgLoop msgHandlerConfig#MsgHandlerConfig {..}
= do
(catch
(forever $ do
msg <- WS.receiveData clientConn
print msg
let parsedMsg = parseMsgFromJSON msg
print parsedMsg
for_ parsedMsg $ handleSocketMsg msgHandlerConfig
return ())
(\e -> do
let err = show (e :: WS.ConnectionException)
print
("Warning: Exception occured in authenticatedMsgLoop for " ++
show username ++ ": " ++ err)
return ()))
-- takes a channel and if the player in the thread is the current player to act in the room
-- then if no valid game action is received within 30 secs then we run the Timeout action
-- against the game
tableReceiveMsgLoop :: TableName -> TChan MsgOut -> MsgHandlerConfig -> IO ()
tableReceiveMsgLoop tableName channel msgHandlerConfig#MsgHandlerConfig {..} =
forever $ do
print "tableReceiveMsgLoop"
dupChan <- atomically $ dupTChan channel
chanMsg <- atomically $ readTChan dupChan
sendMsg clientConn chanMsg
if True
then let timeoutMsg = GameMove tableName Timeout
timeoutDuration = 5000000 -- 5 seconds for player to act
in runTimedMsg timeoutDuration msgHandlerConfig tableName timeoutMsg
else return ()
catchE :: TableName -> WS.ConnectionException -> IO MsgIn
catchE tableName e = do
print e
return $ GameMove tableName Timeout
-- Forks a new thread to run the timeout in then updates the game state
-- with either the resulting timeout or player action
runTimedMsg :: Int -> MsgHandlerConfig -> TableName -> MsgIn -> IO ()
runTimedMsg duration msgHandlerConfig tableName timeoutMsg =
withAsync
(catch
(awaitTimedMsg duration msgHandlerConfig tableName timeoutMsg)
(catchE tableName)) $ \timedAction -> do
playerActionE <- waitCatch timedAction
let playerAction = fromRight timeoutMsg playerActionE
handleSocketMsg msgHandlerConfig playerAction
return ()
-- If the timeout occurs then we return the default msg
awaitTimedMsg :: Int -> MsgHandlerConfig -> TableName -> MsgIn -> IO MsgIn
awaitTimedMsg duration msgHandlerConfig#MsgHandlerConfig {..} tableName defaultMsg = do
maybeMsg <- timeout duration (WS.receiveData clientConn)
return $ maybe defaultMsg parseWithDefaultMsg maybeMsg
where
timeoutDuration = 5000000
parseWithDefaultMsg = (fromMaybe defaultMsg) . parseMsgFromJSON
Typically when a networking library throws an exception of some sort to indicate a closed connection, it is about an event outside of your control. The client has disconnected for some reason - perhaps they turned off their computer, for example.
You are being notified of that fact so you can react appropriately, for example by cleaning up the server-side resources allocated to that connection, or by alerting other clients who may care about this. You cannot turn the client's computer back on and force them to continue using your service. The connection is closed and there's nothing you can do to change that.
The behavior you describe matches perfectly the documentation you quote. The TCP connection is closed, and then you receive an exception to let you respond to that however you like. What do you imagine should happen differently?
Related
I'm trying to get yesod-websockets working with my bootstrapped postgresql based yesod app. The websocket should act as a real-time update of a postgres table, thus I need to maintain a state containing a list of connected clients and their userId. How can I run a function as soon as the websocket disconnected? In a bigger picture, this function should be used to remove the websocket connection from the state list.
What I have so far:
type LobbyState = [(UserId, WS.Connection)]
addClient :: (UserId, WS.Connection) -> LobbyState -> LobbyState
addClient (userId, conn) state = (userId, conn) : state
chatApp :: UserId -> WebSocketsT Handler ()
chatApp userId = do
conn <- ask
-- connections is a MVar [(UserId, WS.Connection)]
connections <- lobbyConnections <$> getYesod
modifyMVar_ connections $ \s -> do
let s' = addClient (userId, conn) s
return s'
-- how to wait for disconnect and execute a function?
getGameR :: Handler TypedContent
getGameR = do
-- TODO: correct usage??
userId <- requireAuthId
webSockets $ chatApp userId
-- some more normal HTML handler code
In the example they use the following snippet:
race_
(forever $ atomically (readTChan readChan) >>= sendTextData)
(sourceWS $$ mapM_C (\msg ->
atomically $ writeTChan writeChan $ name <> ": " <> msg))
I understand how I could utilize a TChan to forever send updates, but how can I react to the actual disconnect event to clean up some state?
Thanks to Chris Stryczynski's comment, I was able to solve it via a catch handler.
A sample echo server with a cleanup after a client disconnects could look like this:
chatApp :: WebSocketsT Handler ()
chatApp =
( forever $ do
msg :: Text <- receiveData
sendTextData msg
)
`catch` ( \(e :: ConnectionException) -> do
let eshow = fromString $ show e
putStrLn $ eshow
-- clean up specific state here
case e of
CloseRequest code msg -> -- Handle specific close codes/msg
return ()
)
I'm writing an app using yesod-websockets, and whenever I receive a "Start" message, I need to run a thread that continuously produces data and sends it to the client, until the client tells it to stop. The producer may also stop producing data on its own.
When the producer stops (regardless of whether it stopped producing on its own, or the client told it to stop), it goes back to the main loop and waits for another "Start" message to be received.
The code looks something like this (runnable minimal repro below):
wsApp :: WebSocketsT Handler ()
wsApp =
forever $ do
msg <- receiveMsg
case msg of
StartMsg -> do
race_
(produceData)
(whileM ((/= StopMsg) <$> receiveMsg))
The problem is that if produceData stops on its own, then the thread running receiveMsg will be cancelled, and this causes the websocket connection to be closed.
21/Mar/2018:08:21:06 +0000 [Error#yesod] Exception from Warp: ConnectionClosed #(app-0.0.0-5bzI9Onrk2fFepGGsdocDz:Application src/Application.hs:122:15)
Is there a way to cancel a thread that's listening on the connection, without killing the connection?
Here's a minimal repro:
wsApp :: WebSocketsT Handler ()
wsApp = forever $ do
race_
(receiveData :: WebSocketsT Handler Text)
(pure ())
$logDebug "Trying again"
The second thread will finish, and the first one will be cancelled, causing the connection to be killed.
Since I couldn't find a more graceful solution, I ended up using an IORef Bool to synchronize the websockets thread and the producer thread.
wsApp :: WebSocketsT Handler ()
wsApp = do
producing <- newIORef False
forever $ do
msg <- receiveMsg
case msg of
StartMsg -> do
whenM (not <$> readIORef producing) $ do
atomicWriteIORef producing True
void . async $ produceData producing
StopMsg -> atomicWriteIORef producing False
produceData :: IORef Bool -> WebSocketsT Handler ()
produceData producing =
whenM (readIORef producing) $
case produce of
Nothing -> atomicWriteIORef producing False
Just x -> sendMsg x >> produceData producing
Does anybody know where I can find an example of using wai-websockets with Redis pub-sub to send real-time notifications to the clients?
I have read the hacakge documentation for wai-websockets and hedis, but I am still unclear how I can combine the two to achieve the desired result.
In case anyone comes wondering to this post, I recently implemented a basic hedis and websockets app. A simple implementation would be run a hedis subscriber in a thread and a websocket in another thread and communicate via TChan.
Some sample code
main = do
chan <- atomically $ newTChan
a <- forkIO (subscribeProc chan)
b <- forkIO (webSock chan)
-- wait for a and b
-- Hedis subscriber
subscribeProc :: TChan B.ByteString -> IO ()
subscribeProc chan = do
conn <- connect defaultConnectInfo
pubSubCtrl <- newPubSubController [("redis-channel", chanHandler chan)] []
forever $
pubSubForever conn pubSubCtrl onInitialComplete
`catch` (\(e :: SomeException) -> do
Prelude.putStrLn $ "Got error: " ++ show e
threadDelay $ 60*1000)
chanHandler :: TChan B.ByteString -> B.ByteString -> IO ()
chanHandler chan msg =
atomically $ writeTChan chan (msg)
onInitialComplete :: IO ()
onInitialComplete = putStrLn
"Redis acknowledged that mychannel is now subscribed"
-- websocket
webSock :: TChan B.ByteString -> IO ()
webSock chan = do
WS.runServer appHost appPort $ handleConnection chan
handleConnection :: TChan B.ByteString -> WS.PendingConnection -> IO ()
handleConnection chan pending = do
connection <- WS.acceptRequest pending
loop chan connection
where
loop chan connection = do
msg <- atomically $ readTChan chan
putStrLn $ "got data " ++ show msg
WS.sendTextData connection msg
loop chan connection
Problem
I'm attempting to extend the IRC bot from https://wiki.haskell.org/Roll_your_own_IRC_bot with some state that's updated every time the bot posts a message in the channel it's connected to.
The feature is: every time the command !last said is issued in the IRC channel, the bot should respond with a time stamp. To support this, the privmsg function needs to update the bot's state -- specifically the lastPosted record -- with a new timestamp every time it is called.
Work so far
I took the code from the bottom of the Haskell wiki page (which used a ReaderT to access information about the bot's environment) and tried to change out the ReaderT for a State Transformer (StateT). The results are below and as you can see, I didn't get very far.
import Data.List
import Network
import System.IO
import System.Exit
import System.Time
import Control.Arrow
import Control.Monad.State
import Control.Exception
import Text.Printf
server = "irc.freenode.org"
port = 6667
chan = "#testbot-test"
nick = "testbottest"
-- The 'Net' monad, a wrapper over IO, carrying the bot's immutable state.
type Net = StateT Bot IO
data Bot = Bot { socket :: Handle, lastPosted :: ClockTime }
-- Set up actions to run on start and end, and run the main loop
main :: IO ()
main = bracket connect disconnect loop
where
disconnect = hClose . socket
loop st = runStateT run st
-- Connect to the server and return the initial bot state
connect :: IO Bot
connect = notify $ do
h <- connectTo server (PortNumber (fromIntegral port))
t <- getClockTime
hSetBuffering h NoBuffering
return (Bot h t)
where
notify a = bracket_
(printf "Connecting to %s ... " server >> hFlush stdout)
(putStrLn "done.")
a
-- We're in the Net monad now, so we've connected successfully
-- Join a channel, and start processing commands
run :: Net ()
run = do
write "NICK" nick
write "USER" (nick ++ " 0 * :test bot")
write "JOIN" chan
gets socket >>= listen
-- Process each line from the server
listen :: Handle -> Net ()
listen h = forever $ do
s <- init `fmap` liftIO (hGetLine h)
liftIO (putStrLn s)
if ping s then pong s else eval (clean s)
where
forever a = a >> forever a
clean = drop 1 . dropWhile (/= ':') . drop 1
ping x = "PING :" `isPrefixOf` x
pong x = write "PONG" (':' : drop 6 x)
-- Dispatch a command
eval :: String -> Net ()
eval "!quit" = write "QUIT" ":Exiting" >> liftIO (exitWith ExitSuccess)
-- Posting when something was last posted shouldn't count as last posted.
eval "!last said" = getLastPosted >>= (\t -> write "PRIVMSG" (chan ++ " :" ++ t))
eval x | "!id " `isPrefixOf` x = privmsg (drop 4 x)
eval _ = return () -- ignore everything else
getLastPosted :: Net String
getLastPosted = do
t <- gets lastPosted
return $ show t
-- Send a privmsg to the current chan + server
privmsg :: String -> Net ()
privmsg s = write "PRIVMSG" (chan ++ " :" ++ s)
-- Send a message out to the server we're currently connected to
write :: String -> String -> Net ()
write s t = do
h <- gets socket
liftIO $ hPrintf h "%s %s\r\n" s t
liftIO $ printf "> %s %s\n" s t
Other support avenues explored
spent a couple of days reading up on ReaderT, StateT and their non-transformer friends Reader and State,
checking Stack Overflow for anyone with a similar problem, but the only other IRC bot question threaded the socket as an argument to every function that needed it (instead of using a ReaderT),
Tweeted Don S. the original author of the wiki page
asked in the Haskell IRC channel.
Question
How can the Haskell wiki IRC bot be extended to post a message, containing the date and time stamp of the last message posted? Preferably using an abstraction like ReaderT (only allowing mutable state) rather than passing state around in function arguments.
I got your code to compile by simply adding a >> return () to the definition of loop in your main:
main :: IO ()
main = bracket connect disconnect loop
where
disconnect = hClose . socket
loop st = (runStateT run st) >> return ()
This effectively ignores the return value of runStateT. Here are all of the variants of runState/runStateT:
runStateT - return both the final state and returned value
evalStateT - return only the final value
execStateT - return only the final state
Your original definition of loop was returning a pair (from runStateT), and this didn't type check since main wants a computation which returns just ().
To update the lastPosted field, consider this addition to the eval function which is triggered when the bot is sent the message !update time:
eval "!update time"
= do t <- liftIO getClockTime
bot <- get
put (bot { lastPosted = t })
We need to liftIO getClockTime since we are operating in the Net monad.
Then we get the old state and put the updated state. You can add this logic wherever you want to update the lastPosted time in the Net monad.
Full code is available at: http://lpaste.net/142931
The following yields a deadlock error message (* Exception: thread blocked indefinitely in an MVar operation). I've thought it through step by step, and I don't see the issue.
On the main thread, a MVar is created, and given to producer, running on a new thread
producer starts, and blocks at listenOn, waiting for a connection
The main thread continues into the loop, and blocks, waiting for the MVar to receive something
Once producer gets a connection, it continues into it's loop, and after receiving something from the socket, puts it into the MVar
Meaning (as far as I understand it), it should end up with producer putting something in the MVar, and main waiting to receive something.
If it's getting stuck because listenOn doesn't connect immediately, how can I get around this? The MVar needs to be created in main, and before producer is forked so it can be passed in.
import Control.Concurrent
import Network
import Network.Socket
import System.IO
getSockInfo :: Socket -> IO String
getSockInfo s = do
info <- getPeerName s
return $ case info of
(SockAddrInet port addr) -> "Addr/Port: " ++ (show addr) ++ " / " ++ (show port)
(SockAddrInet6 port flow addr scope) ->
"Addr/Port: " ++ (show addr) ++ " / " ++ (show port) ++ "Flow/Scope: " ++ (show flow) ++ " / " ++ (show scope)
producer :: MVar String -> IO ()
producer m = do
s <- listenOn (PortNumber 5555)
putStrLn "Listening..."
info <- getSockInfo s
putStrLn $ "Connected to " ++ info
h <- socketToHandle s ReadMode
loop h m
where loop h m = do
message <- hGetLine h
putMVar m message
loop h m
main :: IO ()
main = do
withSocketsDo $ do
m <- newEmptyMVar
prod <- forkIO $ producer m
loop m
where loop m = do
n <- takeMVar m
print n
loop m
listenOn returns immediately but doesn't give you a connected socket, so attempts to use it or read from it fail. I'm not sure why you aren't seeing an error message to indicate that, since I do when I run your code. In any case the listening thread is probably dying at that point, which leaves the main thread deadlocked as nothing can write to the MVar.
Using accept after listenOn to wait for a remote connection should fix this.