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 ()
)
Related
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?
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
I am writing a Happstack server and I have a MongoDB database to connect to. For that, I made a function to create a connection pool
type MongoPool = Pool IOError Pipe
withMongo :: (MongoPool -> IO a) -> IO ()
withMongo f = do
pool <- dbPool
f pool
killAll pool
And then a function to run an Action with a created pool:
runDB :: (MonadIO m) => MongoPool -> Action IO a -> m (Either Failure a)
runDB pool f = liftIO $ do
pipe <- runIOE $ aResource pool
access pipe master dbName f
It's obvious this requires to carry the pool in all the routes as a parameter. I would like to wrap it into a ReaderT, so that runDB can have a type like Action IO a -> ServerPart (Either Failure a) or even better, Action IO a -> ServerPart a in which a failure will result in an HTTP Error 500 automatically.
I have a trouble wrapping my head around how that can be achieved and I'd love for some hints from people who've more experience with Haskell monads and happstack.
Thanks.
Through this question I found another with a very good hint, and I have built this. It seems to work fine and I thought I'd share it:
type MongoPool = Pool IOError Pipe
type DBServerPart a = ReaderT MongoPool (ServerPartT IO) a
hostName = "127.0.0.1"
dbName = "test"
defaultPoolSize = 10
runDB :: Action IO a -> DBServerPart (Either Failure a)
runDB f = do
pool <- ask
liftIO $ do
pipe <- runIOE $ aResource pool
access pipe master dbName f
withMongo :: DBServerPart a -> ServerPart a
withMongo f = do
pool <- liftIO $ dbPool
a <- runReaderT f pool
liftIO $ killAll pool
return a
dbPool = newPool fac defaultPoolSize
where fac = Factory {
newResource = connect $ host hostName,
killResource = close,
isExpired = isClosed
}
I would like to call a UDP send function within an STM transaction so that I can avoid code like below where m' is read (and could be updated by an other thread) before the values are eventually sent & where two consecutive where clauses make me look quite "helpless".
sendRecv s newmsgs q m = do
m' <- atomically $ readTVar m
time <- getPOSIXTime
result <- appendMsg newmsgs key m
when (result > 0) (atomically $ do
mT <- readTVar m
qT <- readTVar q
--let Just messages = Map.lookup key mT in sendq s (B.pack $ unwords messages) "192.168.1.1" 4711
let mT' = Map.delete key mT
qT' = PSQ.delete key qT
writeTVar q (PSQ.insert key time qT')
writeTVar m (Map.insert key [newmsgs] mT'))
when (result > 0) (let Just messages = Map.lookup key m' in sendq s (B.pack $ unwords messages) "192.168.1.1" 4711)
sendq :: Socket -> B.ByteString -> String -> PortNumber -> IO ()
sendq s datastring host port = do
hostAddr <- inet_addr host
sendAllTo s datastring (SockAddrInet port hostAddr)
return ()
I thought that by invoking TVars with newTVarIO and using import System.IO.Unsafe I could eventually use unsafePerformIO somewhere and call my sendq function (that returns IO() ) from within the transaction.
However, I do not find where this "somewhere" is? Is it at the creation of the TVar? Is it instead of atomically $ do? Do I understand the sense an applicability of unsafePerformIO wrong?
IO cannot be done from inside an STM block, because general IO cannot be undone. If you want to do some IO, you must schedule it in the STM block, but do it outside. For example:
foo tvar = do
scheduledAction <- atomically $ do
v <- readTVar tvar
when v retry
return (sendSomethingOnASocket "okay, we're done here")
scheduledAction
If you really need to do IO within a transaction, there's unsafeIOToSTM :: IO a -> STM a, however you should make sure to read the documentation first, as there are several gotchas to be aware of. In particular, the IO action may be run several times if the transaction has to be retried.
That said, I don't think that is appropriate in this case, and you should probably refactor your code so that the message is sent outside the transaction.