I am trying to build a chat feature for a website in Yesod, and I want it to have a list of all the connected users that are there. I imagine the best way to do that is to add the person to the user list on a connection, and remove them when they leave. It seems that the response should block if it keeps the connection open, so I naively wrote
getReceiveR :: Handler ()
getReceiveR = do
App chan <- getYesod
req <- waiRequest
res <- lift $ eventSourceAppChan chan req
sendWaiResponse res
liftIO $ putStrLn "client disconnected" <-- Note this
But it didn't work of course, because sendWaiResponse short circuits.
Is there any way to detect when the client disconnects?
Edit: I am using a very slighly modified version of this tutorial to test out the concept.
I can't really run the code to be sure, but would this work?
import Control.Monad.Trans.Resource
getReceiveR :: Handler ()
getReceiveR = do
App chan <- getYesod
req <- waiRequest
res <- lift $ eventSourceAppChan chan req
register . liftIO $ putStrLn "client disconnected"
sendWaiResponse res
Related
I'm currently learning Haskell. Now I'm currently not that good in functional programming.
I want to make a piece of code, that get's data from subscribing on a topic in Redis, do some calculation on it and publishing it on a other topic. I'm having trouble with I guess some language specific features.
My current code:
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Database.Redis
import System.IO
main = do
conn <- connect defaultConnectInfo
runRedis conn $ do
pubSub (subscribe ["commands"]) $ \msg -> do
putStrLn $ "Message from " ++ show (msgChannel msg)
publish "results" "Result of a very interesting calculation"
return mempty
Now I receive the error: • No instance for (RedisCtx IO f0) arising from a use of ‘publish’
Putting the publish outside the pubsub will make it work. But I want to publish a result! I can't get any wiser from the documentation. What is it that I'm missing?
Your use of putStrLn is making the typechecker (correctly!) infer that your do block is intended to be in an IO context, then the call to publish requires the context to be an instance of RedisCtx, which IO is not.
Normally in a Redis context, the solution would be to lift the IO action into the Redis context using liftIO :: IO a -> m a from the MonadIO class, as in the example in the documentation:
runRedis conn $ do
set "hello" "hello"
set "world" "world"
helloworld <- multiExec $ do
hello <- get "hello"
world <- get "world"
return $ (,) <$> hello <*> world
liftIO (print helloworld)
MonadIO is the set of types in whose context you can execute IO actions.
However, in this case, it’s the other way around: the functional parameter to pubSub returns an IO action, but publish expects a RedisCtx monad.
It’s not clear to me whether pubSub allows you to make a runRedis call inside the callback, like this, although I think it should typecheck:
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Database.Redis
import System.IO
main = do
conn <- connect defaultConnectInfo
runRedis conn $ do
pubSub (subscribe ["commands"]) $ \msg -> do
putStrLn $ "Message from " ++ show (msgChannel msg)
runRedis conn $ publish "results" "Result of a very interesting calculation"
return mempty
Based on skimming the docs, each runRedis call takes a connection from the connection pool, whose default size is 50; however, if there is no available connection, it blocks, so my concern is that because the docs for pubSub say it’s “single-threaded”, this could deadlock waiting for a connection that won’t be released since you’re in a “nested” runRedis call.
I think the thing I would try next is to use the more flexible pubSubForever API; in the hedis test suite there’s an example of using pubSubForever with separate threads for publishing and handling subscription events.
main = do
ctrl <- newPubSubController [("foo", msgHandler)] []
conn <- connect defaultConnectInfo
withAsync (publishThread conn) $ \_pubT -> do
withAsync (handlerThread conn ctrl) $ \_handlerT -> do
void $ hPutStrLn stderr "Press enter to subscribe to bar" >> getLine
void $ addChannels ctrl [("bar", msgHandler)] []
-- …
-- (Add/remove various subscriptions.)
-- …
publishThread uses runRedis and calls publish:
publishThread :: Connection -> IO ()
publishThread c = runRedis c $ loop (0 :: Int)
where
loop i = do
let msg = encodeUtf8 $ pack $ "Publish iteration " ++ show i
void $ publish "foo" ("foo" <> msg)
-- …
liftIO $ threadDelay $ 2*1000*1000
loop (i+1)
handlerThread uses pubSubForever:
handlerThread :: Connection -> PubSubController -> IO ()
handlerThread conn ctrl = forever $
pubSubForever conn ctrl onInitialComplete
`catch` (\(e :: SomeException) -> do
hPutStrLn stderr $ "Got error: " ++ show e
threadDelay $ 50*1000)
This is wrapped in a call to forever to resubscribe if the connection is lost, per the docs for pubSubForever:
[…] if the network connection to Redis dies, pubSubForever will throw a ConnectionLost. When such an exception is thrown, you can recall pubSubForever with the same PubSubController which will open a new connection and resubscribe to all the channels which are tracked in the PubSubController.
This test uses Control.Concurrent.Async from the async package for managing tasks, which is a good idea imo. If you want to avoid that dependency, you could use forkIO instead (with e.g. a Chan or STM TChan to send events from the handler), the only issue is that this won’t automatically notify the other threads if the forked thread terminates due to an exception, whereas Async makes some nice exception safety guarantees.
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've been using reflex and reflex-dom to recreate a web version of a boardgame, and I quite like it so far, but I require a websocket to alert a player when the other player has made a move.
Everything works great but if the server goes down, I can't find a way to detect that it happened and reconnect. Additionally, if you send an event to a server while it is down, it is just is eaten up without any error.
I'm using a stripped down version of the websockets example from https://github.com/reflex-frp/reflex-examples/blob/master/websocket-echo/src/Main.hs
{-# LANGUAGE RecursiveDo #-}
module Lib where
import Data.Monoid
import Reflex.Dom
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
wsurl = "ws://127.0.0.1:5714"
-- wsurl = "ws://echo.websocket.org"
someFunc = mainWidget $ do
rec t <- textInput $ def & setValue .~ fmap (const "") newMessage
b <- button "Send"
text $ "Sending to " <> wsurl
let newMessage = fmap ((:[]) . encodeUtf8 . T.pack) $ tag (current $ value t) $ leftmost [b, textInputGetEnter t]
ws <- webSocket wsurl $ def & webSocketConfig_send .~ newMessage
receivedMessages <- foldDyn (\m ms -> ms ++ [m]) [] $ _webSocket_recv ws
el "p" $ text "Responses from :"
_ <- el "ul" $ simpleList receivedMessages $ \m -> el "li" $ dynText =<< mapDyn (T.unpack . decodeUtf8) m
return ()
I feel like there should be a way to do this with tickLossy to send pings with timeout, like some dynamic which returns websockets and then reconnects if a ping goes a certain amount of time without a response? But I'm having trouble envisioning what the code to reconnect would look like.
Edit: It was an issue with reflex-dom sending an event while a websocket was still in the pending state. I made a pull request, although I feel there is a better solution somewhere.
Edit: It was an issue with reflex-dom sending an event while a
websocket was still in the pending state. I made a pull request,
although I feel there is a better solution somewhere.
Just FYI, since the question was posted there have been some quite relevant extensions to the WebSocket API merged into reflex-dom:
you can close websockets via Events, see _webSocketConfig_close
you can specifiy if you want auto-reconnect, see _webSocketConfig_reconnect
there is an Event exposed for when the connection is closed, see _webSocket_close
there is an Event exposed for when an error occurs, see _webSocket_error
I believe the close event is exactly what you were looking for. It was just not available at the time.
It looks like on when websocket is closed, the library tries to reconnect:
start = do
ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do
void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
liftIO $ writeIORef currentSocketRef Nothing
liftIO $ threadDelay 1000000
start
liftIO $ writeIORef currentSocketRef $ Just ws
return ()
(newWebSocket takes onClose event handler at the last argument)
And all the messages you are sending while reconnecting are ignored:
performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload -> do
mws <- liftIO $ readIORef currentSocketRef
case mws of
Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things?
Just ws -> do
liftIO $ webSocketSend ws payload
You probably should open an issue on their issue tracker. Or just find better library.
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'm writing some code with reactive-banana and gtk2hs that needs to read from a file handle. I need to have at least two threads (one to read keyboard events with reactive banana and one to read from the file handle), so at the moment I have code that looks something like this:
type EventSource a = (AddHandler a, a -> IO ())
fire :: EventSource a -> a -> IO ()
fire = snd
watch :: EventSource ByteString -> Handle -> IO ()
watch textIn pty = forever $
hGetLine pty >>= fire textIn >> threadWaitRead pty
With the following main function:
mainAxn :: IO ()
mainAxn = do
h <- openFile "foo" ReadMode
initGUI
win <- windowNew
txt <- textViewNew
containerAdd win txt
widgetShowAll win
(keyPress, textIn) <-
(,) <$> newAddHandler <*> newAddHandler
network <- setupNetwork keyPress textIn
actuate network
_ <- forkIO $ watch textIn h
_ <- win `on` keyPressEvent $
eventKeyVal >>= liftIO . fire keyPress >> return True
mainGUI
and my event network set up as follows:
setupNetwork :: EventSource KeyVal -> EventSource ByteString -> IO EventNetwork
setupNetwork keyPress textIn = compile $ do
ePressed <- fromAddHandler $ addHandler keyPress
eText <- fromAddHandler $ addHandler textIn
reactimate $ print <$> (filterJust $ keyToChar <$> ePressed)
reactimate $ print <$> eText
(except in my actual code, those reactimate calls write to the TextView built in mainAxn). I found that I needed to build with -threaded to make the event network correctly capture both text from textIn and keypresses from keyPress, which caused issues because it's not safe to modify objects from the gtk package concurrently.
At the moment, I have postGUIAsync calls scattered throughout my code, and I've found that using postGUISync causes the whole thing to deadlock --- I'm not sure why. I think it's because I end up calling postGUISync inside of the same thread that ran mainGUI.
It seems like it would be better to run all of the GUI stuff in its own thread and use the postGUI* functions for every access to it. However, when I change the last line of mainAxn to be
forkIO mainGUI
return ()
the program returns immediately when it hits the end of mainAxn. I tried to fix that by using:
forkIO mainGUI
forever $ return ()
but then the gtk GUI never opens at all, and I don't understand why.
What's the right way to do this? What am I missing?
The basic problem here is that, in Haskell, as soon as main exits, the entire program is torn down. The solution is simply to keep the main thread open; e.g.
done <- newEmptyMVar
forkOS (mainGUI >> putMVar done ())
takeMVar done
I've also replaced forkIO with forkOS. GTK uses (OS-)thread-local state on Windows, so as a matter of defensive programming it is best to ensure that mainGUI runs on a bound thread just in case one day you want to support Windows.
Daniel Wagner answered my question as asked, but I got a more informative perspective from the #haskell IRC channel, which I'll post here for future reference.
Rather than jumping through awkward hoops of forking off the GUI thread and putting the main thread to sleep, a better solution is to let the main thread be the GUI thread and deal with the reactive-banana event network in a new thread. I ended up modifying my main function to contain the following:
keyChan <- newChan
_ <- forkIO $ watchKeys keyPress keyChan
_ <- win `on` keyPressEvent $
eventKeyVal >>= liftIO . writeChan keyChan >> return True
where watchKeys is defined as:
watchKeys :: EventSource KeyVal -> Chan KeyVal -> IO ()
watchKeys keyPress chan = forever $
readChan chan >>= fire keyPress
Now I can deal with the postGUI(A)Sync issues in exactly one place, by defining:
reactimateSafe :: Frameworks t => Event t (IO ()) -> Moment t ()
reactimateSafe = reactimate . fmap postGUIAsync
and using reactimateSafe for any IO action that modifies a GTK object