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
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 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?
I am implementing a Conduit Source for some client that subscribes to a queue and puts all the arriving messages into an MVar.
The problem is that I cannot read from that MVar to yield those messages through the Conduit Source, as it reports an exception on runtime: thread blocked indefinitely in an MVar operation
mqttSource :: (Monad m, MonadIO m, MonadResource m) => MqttOptions -> Source m String
mqttSource MqttOptions {..} = do
bracketP mkConsumer cleanConsumer runHandler
where
mkConsumer = do
chan <- liftIO $ newEmptyMVar
client <- liftIO.hookToChan $ chan
return (chan, client)
cleanConsumer (_, client) =
liftIO.disconnectClient $ client
runHandler (chan, client) = do
newMsg <- liftIO $ readMVar chan
yield newMsg
runHandler (chan, client)
(hookToChan just tells the client to subscribe to the queue using this function: \topic msg -> putMVar chan (show msg))
Thanks to the comments that Cirdec made, I've managed to fix the issue.
The problem was that I was spawning the client in the same thread.
hookToChan was the responsible of doing so, and I was subscribing to the queue on the same thread. I've just added a forkIO to the hookToChan function, and the issue went away.
Suppose in my program I need to connect to the server (using only Network, not Network.Socket!) and post, get some data (think about it as telnet analog). I need to receive messages from server in separate thread (because I can send something on server and get something seperatly). So the question is how to receive messages and and send it in two separate threads? I dont know how to use forkIO and how to use Handle
For now I wrote something like this:
sender :: Handle -> IO ()
sender h = do
toSend <- getContents
hPutStr h toSend
sender h
receiver :: Handle -> IO ()
receiver h = do
response <- hGetContents h
putStrLn $ "the response is: " ++ response
receiver h
main :: IO ()
main = do
let host = "haskell.org"
let port = 40
h <- connectTo host (PortNumber $ fromIntegral i)
forkIO $ receiver h
sender h
return ()
As I understood, this code works quite well. The main problem was with port I used. haskell.org's port 40 is not open (found out using nmap). So the connection just freezed. Only few changes I did in sender and receiver:
sender :: Handle -> IO ()
sender h = getContents >>= hPutStrLn h
receiver :: Handle -> IO ()
receiver h = hGetContents h >>= putStrLn
So the final code is
import Network
import Control.Concurrent(forkIO)
import System.IO
import System.Environment
import Control.Monad
sender :: Handle -> IO ()
sender h = getContents >>= hPutStrLn h
receiver :: Handle -> IO ()
receiver h = forever $ hGetLine h >>= putStrLn
main :: IO ()
main = do
[host, port] <- getArgs
h <- connectTo host (Service port)
forkIO $ receiver h
sender h
return ()
I am implementing an IRC bot and since I am connecting over SSL by using OpenSSL.Session I use lazyRead function to read data from the socket. During the initial phase of the connection I need to perform several things in order: nick negotiation, nickserv identification, joining channels etc) so there is some state involved. Right now I came up with the following:
data ConnectionState = Initial | NickIdentification | Connected
listen :: SSL.SSL -> IO ()
listen ssl = do
lines <- BL.lines `fmap` SSL.lazyRead ssl
evalStateT (mapM_ (processLine ssl) lines) Initial
processLine :: SSL.SSL -> BL.ByteString -> StateT ConnectionState IO ()
processLine ssl line = do case message of
Just a -> processMessage ssl a
Nothing -> return ()
where message = IRC.decode $ BL.toStrict line
processMessage :: SSL.SSL -> IRC.Message -> StateT ConnectionState IO ()
processMessage ssl m = do
state <- S.get
case state of
Initial -> when (IRC.msg_command m == "376") $ do
liftIO $ putStrLn "connected!"
liftIO $ privmsg ssl "NickServ" ("identify " ++ nick_password)
S.put NickIdentification
NickIdentification -> do
when (identified m) $ do
liftIO $ putStrLn "identified!"
liftIO $ joinChannel ssl chan
S.put Connected
Connected -> return ()
liftIO $ print m
when (IRC.msg_command m == "PING") $ (liftIO . pong . mconcat . map show) (IRC.msg_params m)
So when I get to the "Connected" state I still end up going through the case statement even though it's only really needed to initialize the connection. The other problem is that adding nested StateT's would be very painful.
Other way would be to replace mapM with something custom to only process lines until we are connected and then start another loop over the rest. This would require either keeping track of what's left in the list or invoking SSL.lazyRead once again (which is not too bad).
Another solution is to keep the remaining lines list in the state and draw lines when needed similar to getLine.
What's the better thing to do in this case? Would Haskell's laziness make it so that we go directly to Connected case after state stops updating or is case always strict?
You can use the Pipe type from pipes. The trick is that instead of creating a state machine and a transition function you can encode the the state implicitly in the control flow of the Pipe.
Here is what the Pipe would look like:
stateful :: Pipe ByteString ByteString IO r
stateful = do
msg <- await
if (IRC.msg_command msg == "376")
then do
liftIO $ putStrLn "connected!"
liftIO $ privmsg ssl "NickServ" ("identify " ++ nick_password)
yield msg
nick
else stateful
nick :: Pipe ByteString ByteString IO r
nick = do
msg <- await
if identified msg
then do
liftIO $ putStrLn "identified!"
liftIO $ joinChannel ssl chan
yield msg
cat -- Forward the remaining input to output indefinitely
else nick
The stateful pipe corresponds to the stateful part of your processMessage function. It handles initialization and authentication, but defers further message processing to downstream stages by re-yielding the msg.
You can then loop over every message this Pipe yields by using for:
processMessage :: Consumer ByteString IO r
processMessage = for stateful $ \msg -> do
liftIO $ print m
when (IRC.msg_command m == "PING") $ (liftIO . pong . mconcat . map show) (IRC.msg_params m)
Now all you need is a source of ByteString lines to feed to processMessage. You can use the following Producer:
lines :: Producer ByteString IO ()
lines = do
bs <- liftIO (ByteString.getLine)
if ByteString.null bs
then return ()
else do
yield bs
lines
Then you can connect lines to processMessage and run them:
runEffect (lines >-> processMessage) :: IO ()
Note that the lines Producer does not use lazy IO. It will work even if you use the strict ByteString module, but the behavior of the entire program will still be lazy.
If you want to learn more about how pipes works, you can read the pipes tutorial.