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.
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.
Since sodium has been deprecated by the author I'm trying to port my code to reactive-banana. However, there seem to be some incongruencies between the two that I'm having a hard time overcomming.
For example, in sodium it was easy to retrieve the current value of a behaviour:
retrieve :: Behaviour a -> IO a
retrieve b = sync $ sample b
I don't see how to do this in reactive-banana
(The reason I want this is because I'm trying to export the behaviour as a dbus property. Properties can be queried from other dbus clients)
Edit: Replaced the word "poll" as it was misleading
If you have a Behaviour modelling the value of your property, and you have an Event modelling the incoming requests for the property's value, then you can just use (<#) :: Behavior b -> Event a -> Event b1 to get a new event occurring at the times of your incoming requests with the value the property has at that time). Then you can transform that into the actual IO actions you need to take to reply to the request and use reactimate as usual.
1 https://hackage.haskell.org/package/reactive-banana-1.1.0.0/docs/Reactive-Banana-Combinators.html#v:-60--64-
For conceptual/architectural reasons, Reactive Banana has functions from Event to Behavior, but not vice versa, and it makes sense too, given th nature and meaning of FRP. I'm quite sure you can write a polling function, but instead you should consider changing the underlying code to expose events instead.
Is there a reason you can't change your Behavior into an Event? If not, that would be a good way to go about resolving your issue. (It might in theory even reveal a design shortcoming you have been overlooking so far.)
The answer seems to be "it's sort of possible".
sample corresponds to valueB, but there is no direct equivalent to sync.
However, it can be re-implemented with the help of execute:
module Sync where
import Control.Monad.Trans
import Data.IORef
import Reactive.Banana
import Reactive.Banana.Frameworks
data Network = Network { eventNetwork :: EventNetwork
, run :: MomentIO () -> IO ()
}
newNet :: IO Network
newNet = do
-- Create a new Event to handle MomentIO actions to be executed
(ah, call) <- newAddHandler
network <- compile $ do
globalExecuteEV <- fromAddHandler ah
-- Set it up so it executes MomentIO actions passed to it
_ <- execute globalExecuteEV
return ()
actuate network
return $ Network { eventNetwork = network
, run = call -- IO Action to fire the event
}
-- To run a MomentIO action within the context of the network, pass it to the
-- event.
sync :: Network -> MomentIO a -> IO a
sync Network{run = call} f = do
-- To retrieve the result of the action we set up an IORef
ref <- newIORef (error "Network hasn't written result to ref")
-- (`call' passes the do-block to the event)
call $ do
res <- f
-- Put the result into the IORef
liftIO $ writeIORef ref res
-- and read it back once the event has finished firing
readIORef ref
-- Example
main :: IO ()
main = do
net <- newNet -- Create an empty network
(bhv1, set1) <- sync net $ newBehavior (0 :: Integer)
(bhv2, set2) <- sync net $ newBehavior (0 :: Integer)
set1 3
set2 7
let sumB = (liftA2 (+) bhv1 bhv2)
print =<< sync net (valueB sumB)
set1 5
print =<< sync net (valueB sumB)
return ()
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've written a small server which accepts registrations as POST requests and persists them by appending them to a file. As soon as I put this server under load (I use Apache JMeter with 50 concurrent threads and a repeat count of 10, and the post consists of one field with ~7k of text data), I get lots of "resource busy, file is locked" errors:
02/Nov/2013:18:07:11 +0100 [Error#yesod-core] registrations.txt: openFile: resource busy (file is locked) #(yesod-core-1.2.4.2:Yesod.Core.Class.Yesod ./Yesod/Core/Class/Yesod.hs:485:5)
Here is a stripped-down version of the code:
{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings, TypeFamilies #-}
import Yesod
import Text.Hamlet
import Control.Applicative ((<$>), (<*>))
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text, pack, unpack)
import Data.String
import System.IO (withFile, IOMode(..), hPutStrLn)
data Server = Server
data Registration = Registration
{ text :: Text
}
deriving (Show, Read)
mkYesod "Server" [parseRoutes|
/reg RegR POST
|]
instance Yesod Server
instance RenderMessage Server FormMessage where
renderMessage _ _ = defaultFormMessage
postRegR :: Handler Html
postRegR = do
result <- runInputPost $ Registration
<$> ireq textField "text"
liftIO $ saveRegistration result
defaultLayout [whamlet|<p>#{show result}|]
saveRegistration :: Registration -> IO ()
saveRegistration r = withFile "registrations.txt" AppendMode (\h -> hPutStrLn h $ "+" ++ show r)
main :: IO ()
main = warp 8080 Server
I compiled the code on purpose without -threaded, and the OS shows only a single thread running. Nonetheless it looks to me like the requests are not completely serialised, and a new request is already handled before the old one has been written to disk.
Could you tell me how I can avoid the error message and ensure that all requests are handled successfully? Performance is not an issue yet.
It's perfectly OK to write to a Handle from several threads. In fact, Handles have MVars inside them to prevent weird concurrent behaviour. What you probably want is not to handle [sic] MVars by hand (which can lead to deadlock if, for instance, a handler throws an exception) but lift the withFile call outside the individual handler threads. The file stays open all the time - opening it on each request would be slow anyway.
I don't know much about Yesod, but I'd recommend something like this (probably doesn't compile):
data Server = Server { handle :: Handle }
postRegR :: Handler Html
postRegR = do
h <- handle `fmap` getYesod
result <- runInputPost $ Registration
<$> ireq textField "text"
liftIO $ saveRegistration h result
defaultLayout [whamlet|<p>#{show result}|]
saveRegistration :: Handle -> Registration -> IO ()
saveRegistration h r = hPutStrLn h $ "+" ++ show r
main :: IO ()
main = withFile "registrations.txt" AppendMode $ \h -> warp 8080 (Server h)
-- maybe there's a better way?
Aside: if you wanted to file to be written asynchronously you could write to a queue (if it were a log file or something), but in your use case you probably want to let the user know if their registration failed, so I'd recommend staying with this form.
Even without -threaded the Haskell runtime will have several "green threads" running cooperatively. You need to use Control.Concurrent to limit access to the file because you cannot have several threads writing to it at once.
The easiest way is to have an MVar () in your Server and have each request "take" the unit from the MVar before opening the file and then put it back after the file operation has been completed. You can use bracket to ensure that the lock is released even if writing the file fails. E.g. something like
import Control.Concurrent
import Control.Exception (bracket_)
type Lock = MVar ()
data Server = Server { fileLock :: Lock }
saveRegistration :: Registration -> Lock -> IO ()
saveRegistration r lock = bracket_ acquire release updateFile where
acquire = takeMVar lock
release = putMVar lock ()
updateFile =
withFile "registrations.txt" AppendMode (\h -> hPutStrLn h $ "+" ++ show r)
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