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.
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 ()
)
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
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.
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.
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.