I am using WxHaskell to graphically show the state of a program that advertises state updates using TCP (which I decode using Data.Binary). When an update is received, I want to update the display. So I want the GUI to update its display asynchronously. I know that processExecAsync runs a command line process asynchronously, but I don't think this is what I want.
This is rough code using transactional variables (i.e. software transactional memory). You could use an IORef, MVar, or numerous other constructs.
main = do
recvFunc <- initNetwork
cntTV <- newTVarIO 0
forkIO $ threadA recvFunc cntTV
runGUI cntTV 0
Above you start the program, initialize the network and a shared variable cntTV
threadA recvCntFromNetwork cntTVar = forever $ do
cnt <- recvCntFromNetwork
atomically (writeTVar cntTVar cnt)
threadA receives data from the network and writes the new value of the counter to the shared variable.
runGUI cntTVar currentCnt = do
counter <- initGUI
cnt <- atomically $ do
cnt <- readTVar cntTVar
if (cnt == currentCnt)
then retry
else return cnt
updateGUICounter counter cnt
runGUI cntTVar cnt
runGUI reads the shared variable and if there is a change will update the GUI counter. FYI, the runGUI thread won't wake up on retry until cntTVar is modified, so this isn't a CPU hogging polling loop.
In this code I've assumed you have functions named updateGUICounter, initGUI, and initNetwork. I advise you use Hoogle to find the location of any other functions you don't already know and learn a little about each module.
I have come up with a kind of hack that seems to work. Namely, use an event timer to check an update queue:
startClient :: IO (TVar [Update])
startClient = /*Connect to server,
listen for updates and add to queue*/
gui :: TVar [Update] -> IO ()
gui trdl = do
f <- frame [text := "counter", visible := False]
p <- panel f []
st <- staticText p []
t <- timer f [interval := 10, on command := updateGui st]
set f [layout := container p $ fill $ widget st, clientSize := (sz 200 100), visible := True]
where
updateGui st = do
rdl <- atomically $ readTVar trdl
atomically $ writeTVar trdl []
case rdl of
[] -> return ()
dat : dl -> set st [text := (show dat)]
main :: IO ()
main = startClient >>= start gui
So a client listens for the updates on the TCP connection, adds them to a queue. Every 10ms, an event is raised whose action is to check this queue and show the latest update in a static text widget.
If you have a better solution, please let me know!
I found a solution without a busy wait at:
http://snipplr.com/view/17538/
However you might choose a higher eventId in order to avoid conflicts with existing ids.
Here is some code from my module http://code.haskell.org/alsa/gui/src/Common.hs:
myEventId :: Int
myEventId = WXCore.wxID_HIGHEST+100
-- the custom event ID, avoid clash with Graphics.UI.WXCore.Types.varTopId
-- | the custom event is registered as a menu event
createMyEvent :: IO (WXCore.CommandEvent ())
createMyEvent =
WXCore.commandEventCreate WXCore.wxEVT_COMMAND_MENU_SELECTED myEventId
registerMyEvent :: WXCore.EvtHandler a -> IO () -> IO ()
registerMyEvent win io =
WXCore.evtHandlerOnMenuCommand win myEventId io
reactOnEvent, reactOnEventTimer ::
SndSeq.AllowInput mode =>
Int -> WX.Window a -> Sequencer mode ->
(Event.T -> IO ()) ->
IO ()
reactOnEvent _interval frame (Sequencer h _) action = do
mvar <- MVar.newEmptyMVar
void $ forkIO $ forever $ do
MVar.putMVar mvar =<< Event.input h
WXCore.evtHandlerAddPendingEvent frame =<< createMyEvent
registerMyEvent frame $
MVar.takeMVar mvar >>= action
-- naive implementation using a timer, requires Non-Blocking sequencer mode
reactOnEventTimer interval frame sequ action =
void $
WX.timer frame [
WX.interval := interval,
on command := getWaitingEvents sequ >>= mapM_ action]
The code shows two ways to handle the problem:
reactOnEventTimer does a busy wait using the WX timer.
reactOnEvent only gets active when an event actually arrives. This is the prefered solution.
In my example I wait for ALSA MIDI sequencer messages. The Event.input call waits for the next ALSA message to come. The action gets the results of Event.input, that is, the incoming ALSA messages, but it is run in the WX thread.
Related
I'm using the async library in conjunction with stm in my program.
The main thread forks two threads which run until one of them (it could be either one) encounters a solution. The solution is returned via a TMVar. Neither of them ever waits on any TMVar except to call putTMVar when the solution is found and one of them is guaranteed to run forever unless killed. So how could I possibly be getting "thread blocked indefinitely in an STM transaction" (which seems to happen approximately one in every twenty times) given that at least one of the child threads doesn't execute any blocking STM transactions (or die) until storing a result.
Note the two child threads communicate somewhat with each other using TVars, but not with TMVars.
Simplified code:
main :: IO ()
main = do
output <- newEmptyTMVar
result <- withAsync (child1 output) $ \_ -> withAsync (child2 output) $ \_ ->
let go = do
result <- atomically $ takeTMVar output
if someCondition result
then return result
else go
in go
print result
child1 :: TMVar Result -> IO ()
child1 output = go 0
where
go i = do
case computation1 i of
Nothing -> return ()
Just x -> atomically $ putTMVar x
go (i + 1)
child2 :: TMVar Result -> IO ()
-- Does some other stuff, but also only interacts with its argument to
-- give back a result, same as child1.
I have a Haskell-based web service that performs a calculation that for some input can take a really long time to finish. ("really long" here means over a minute)
Because performing that calculation takes all the CPU available on the server, I place incoming requests in a queue (well, actually a stack for reasons that have to do with the typical client, but that's besides the point) when they arrive and service them when the currently running calculation finishes.
My problem is that the clients don't always wait long enough, and sometimes time out on their end, disconnect, and try a different server (well, they try again and hit the elb, and usually get a different instance). Also, occasionally the calculation the web client was asking for will become obsolete because of external factors and the web client will be killed.
In those cases I'd really like to be able to detect that the web client has gone away before I pull the next request off the stack and start the (expensive) calculation. Unfortunately, my experience with snap leads me to believe that there's no way in that framework to ask "is the client's TCP connection still connected?" and I haven't found any documentation for other web frameworks that cover the "client disconnected" case.
So is there a Haskell web framework that makes it easy to detect whether a web client has disconnected? Or failing that, is there one that at least makes it possible?
(I understand that it may not be possible to be absolutely certain in all cases whether a TCP client is still there without sending data to the other end; however, when the client actually sends RST packets to the server and the server's framework doesn't let the application code determine that the connection is gone, that's a problem)
Incidentally, though one might suspect that warp's onClose handler would let you do this, this fires only when a response is ready and written to the client so is useless as a way of aborting a calculation in progress. There also seems to be no way to get access to the accepted socket so as to set SO_KEEPALIVE or similar. (There are ways to access the initial listening socket, but not the accepted one)
So I found an answer that works for me and it might work for someone else.
It turns out that you can in fact mess around enough with the internals of Warp to do this, but then what you're left with is a basic version of Warp and if you need things like logging, etc., will need to add other packages on to that.
Also, note that so-called "half-closed" connections (when the client closes their sending end, but is still waiting for data) will be detected as closed, interrupting your calculation. I don't know of any HTTP clients that deal in half-closed connections, but just something to be aware of.
Anyway, what I did was first copy the functions runSettings and runSettingsSocket exposed by Network.Wai.Handler.Warp and Network.Wai.Handler.Warp.Internal and made versions that called a function I supplied instead of WarpI.socketConnection, so that I have the signature:
runSettings' :: Warp.Settings -> (Socket -> IO (IO WarpI.Connection))
-> Wai.Application -> IO ()
This required copying out a few helper methods, like setSocketCloseOnExec and windowsThreadBlockHack. The double-IO signature there might look weird, but it's what you want - the outer IO is run in the main thread (that calls accept) and the inner IO is run in the per-connection thread that is forked after accept returns. The original Warp function runSettings is equivalent to:
\set -> runSettings' set (WarpI.socketConnection >=> return . return)
Then I did:
data ClientDisappeared = ClientDisappeared deriving (Show, Eq, Enum, Ord)
instance Exception ClientDisappeared
runSettingsSignalDisconnect :: Warp.Settings -> Wai.Application -> IO ()
runSettingsSignalDisconnect set =
runSettings' set (WarpI.socketConnection >=> return . wrapConn)
where
-- Fork a 'monitor' thread that does nothing but attempt to
-- perform a read from conn in a loop 1/sec, and wrap the receive
-- methods on conn so that they first consume from the stuff read
-- by the monitoring thread. If the monitoring thread sees
-- end-of-file (signaled by an empty string read), raise
-- ClientDisappered on the per-connection thread.
wrapConn conn = do
tid <- myThreadId
nxtBstr <- newEmptyMVar :: IO (MVar ByteString)
semaphore <- newMVar ()
readerCount <- newIORef (0 :: Int)
monitorThread <- forkIO (monitor tid nxtBstr semaphore readerCount)
return $ conn {
WarpI.connClose = throwTo monitorThread ClientDisappeared
>> WarpI.connClose conn
, WarpI.connRecv = newRecv nxtBstr semaphore readerCount
, WarpI.connRecvBuf = newRecvBuf nxtBstr semaphore readerCount
}
where
newRecv :: MVar ByteString -> MVar () -> IORef Int
-> IO ByteString
newRecv nxtBstr sem readerCount =
bracket_
(atomicModifyIORef' readerCount $ \x -> (succ x, ()))
(atomicModifyIORef' readerCount $ \x -> (pred x, ()))
(withMVar sem $ \_ -> do w <- tryTakeMVar nxtBstr
case w of
Just w' -> return w'
Nothing -> WarpI.connRecv conn
)
newRecvBuf :: MVar ByteString -> MVar () -> IORef Int
-> WarpI.Buffer -> WarpI.BufSize -> IO Bool
newRecvBuf nxtBstr sem readerCount buf bufSize =
bracket_
(atomicModifyIORef' readerCount $ \x -> (succ x, ()))
(atomicModifyIORef' readerCount $ \x -> (pred x, ()))
(withMVar sem $ \_ -> do
(fulfilled, buf', bufSize') <-
if bufSize == 0 then return (False, buf, bufSize)
else
do w <- tryTakeMVar nxtBstr
case w of
Nothing -> return (False, buf, bufSize)
Just w' -> do
let wlen = B.length w'
if wlen > bufSize
then do BU.unsafeUseAsCString w' $ \cw' ->
copyBytes buf (castPtr cw') bufSize
putMVar nxtBstr (B.drop bufSize w')
return (True, buf, 0)
else do BU.unsafeUseAsCString w' $ \cw' ->
copyBytes buf (castPtr cw') wlen
return (wlen == bufSize, plusPtr buf wlen,
bufSize - wlen)
if fulfilled then return True
else WarpI.connRecvBuf conn buf' bufSize'
)
dropClientDisappeared :: ClientDisappeared -> IO ()
dropClientDisappeared _ = return ()
monitor tid nxtBstr sem st =
catch (monitor' tid nxtBstr sem st) dropClientDisappeared
monitor' tid nxtBstr sem st = do
(hitEOF, readerCount) <- withMVar sem $ \_ -> do
w <- tryTakeMVar nxtBstr
case w of
-- No one picked up our bytestring from last time
Just w' -> putMVar nxtBstr w' >> return (False, 0)
Nothing -> do
w <- WarpI.connRecv conn
putMVar nxtBstr w
readerCount <- readIORef st
return (B.null w, readerCount)
if hitEOF && (readerCount == 0)
-- Don't signal if main thread is also trying to read -
-- in that case, main thread will see EOF directly
then throwTo tid ClientDisappeared
else do threadDelay oneSecondInMicros
monitor' tid nxtBstr sem st
oneSecondInMicros = 1000000
Assuming that 'web service' means HTTP(S)-based clients, one option is to use a RESTful approach. Instead of assuming that clients are going to stay connected, the service could accept the request and return 202 Accepted. As the HTTP status code specification outlines:
The request has been accepted for processing, but the processing has not been completed [...]
The 202 response is intentionally non-committal. Its purpose is to allow a server to accept a request for some other process (perhaps a batch-oriented process that is only run once per day) without requiring that the user agent's connection to the server persist until the process is completed. The entity returned with this response SHOULD include an indication of the request's current status and either a pointer to a status monitor or some estimate of when the user can expect the request to be fulfilled.
The server immediately responds with a 202 Accepted response, and also includes a URL that the client can use to poll for status. One option is to put this URL in the response's Location header, but you can also put the URL in a link in the response's body.
The client can poll the status URL for status. Once the calculation finishes, the status resource can provide a link to the finished result.
You can add cache headers to the status resource and final result if you're concerned that the clients will be polling too hard.
REST in Practice outlines the general concepts, while the RESTful Web Services Cookbook has lots of good details.
I'm not saying that you can't do something with either HTTP or TCP/IP (I don't know), but if you can't, then the above is a tried-and-true solution to similar problems.
Obviously, this is completely independent on programming language, but it's been my experience that REST and algebraic data types go well together.
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
I'm writing something like a music player and get stuck with the playback progress bar.
In my program when the play button is clicked, I use forkIO to fork a thread which controls the progressbar. However, the forked thread now executes a loop. How can I inform that thread to terminate when I stop current song or change songs.
I've been trying to use IORef Var, for example
flag <- newIORef False
forkIO $ progressBarFunc flag
and in the function progreeBarFunc it checks whether flag is true and decides to exit loop or not.
But this does not work.
More generally, how can I tell the forked thread to stop when I use forkIO to fork threads?
In addition, if I have an IORef Var and pass it to the function in forkIO, do the main thread and the forked thread share the same IORef Var or the forked thread actually has a copy of it?
You can communicate between threads using IORefs. The IORef refers to the same thing in the forked thread as it did in the main thread.
There are a few things you should check:
Does the forked thread actually get a chance to test the IORef?
Can the UI interactions you are expecting actually happen from the forked thread? Many UI libraries, including both gtk and OpenGL, have restrictions on which threads can interact with the UI.
Is the flag set for long enough that the forked thread had a chance to see it? If the flag is set to True and then back to False before the forked thread calls readIORef, it won't detect the stop.
One way to address the final problem is to use an Integer instead of a Bool for a flag.
newFlag :: IO (IORef Integer)
newFlag = newIORef 0
An observer of the flag remembers the value of the flag when the observer was created, and stops when it becomes greater. This returns True when the thread can continue (the flag has not been raised).
testFlag :: IORef Integer -> IO (IO Bool)
testFlag flag = do
n <- readIORef flag
return (fmap (<=n) (readIORef flag))
To raise the flag, the signaler increments the value.
raiseFlag :: IORef Integer -> IO ()
raiseFlag ref = atomicModifyIORef ref (\x -> (x+1,()))
This little example program demonstrates an IORef sharing a flag with other threads. It forks new threads when given the input "f", signals the threads to stop when given the input "s", and quits when given the input "q".
main = do
flag <- newFlag
let go = do
command <- getLine
case command of
"f" -> do
continue <- testFlag flag
forkIO $ thread continue
go
"s" -> do
raiseFlag flag
go
"q" -> do
raiseFlag flag
return ()
go
The threads periodically do some "work", which takes half a second, and test for the continue condition before continuing.
thread :: IO Bool -> IO ()
thread continue = go
where
go = do
me <- myThreadId
putStrLn (show me ++ " Outputting")
threadDelay 500000
c <- continue
if c then go else putStrLn (show me ++ " Stopping") >> return ()
I have a TChan as input for a thread which should behave like this:
If sombody writes to the TChan within a specific time, the content should be retrieved. If there is nothing written within the specified time, it should unblock and continue with Nothing.
My attempt on this was to use the timeout function from System.Timeout like this:
timeout 1000000 $ atomically $ readTChan pktChannel
This seemed to work but now I discovered, that I am sometimes loosing packets (they are written to the channel, but not read on the other side. In the log I get this:
2014.063.11.53.43.588365 Pushing Recorded Packet: 2 1439
2014.063.11.53.43.592319 Run into timeout
2014.063.11.53.44.593396 Run into timeout
2014.063.11.53.44.593553 Pushing Recorded Packet: 3 1439
2014.063.11.53.44.597177 Sending Recorded Packet: 3 1439
Where "Pushing Recorded Packet" is the writing from the one thread and "Sending Recorded Packet" is the reading from the TChan in the sender thread. The line with Sending Recorded Packet 2 1439 is missing, which would indicate a successful read from the TChan.
It seems that if the timeout is received at the wrong point in time, the channel looses the packet. I suspect that the threadKill function used inside timeout and STM don't play well together.
Is this correct? Does somebody have another solution that does not loose the packet?
Use registerDelay, an STM function, to signal a TVar when the timeout is reached. You can then use the orElse function or the Alternative operator <|> to select between the next TChan value or the timeout.
import Control.Applicative
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import System.Random
-- write random values after a random delay
packetWriter :: Int -> TChan Int -> IO ()
packetWriter maxDelay chan = do
let xs = randomRs (10000 :: Int, maxDelay + 50000) (mkStdGen 24036583)
forM_ xs $ \ x -> do
threadDelay x
atomically $ writeTChan chan x
-- block (retry) until the delay TVar is set to True
fini :: TVar Bool -> STM ()
fini = check <=< readTVar
-- Read the next value from a TChan or timeout
readTChanTimeout :: Int -> TChan a -> IO (Maybe a)
readTChanTimeout timeoutAfter pktChannel = do
delay <- registerDelay timeoutAfter
atomically $
Just <$> readTChan pktChannel
<|> Nothing <$ fini delay
-- | Print packets until a timeout is reached
readLoop :: Show a => Int -> TChan a -> IO ()
readLoop timeoutAfter pktChannel = do
res <- readTChanTimeout timeoutAfter pktChannel
case res of
Nothing -> putStrLn "timeout"
Just val -> do
putStrLn $ "packet: " ++ show val
readLoop timeoutAfter pktChannel
main :: IO ()
main = do
let timeoutAfter = 1000000
-- spin up a packet writer simulation
pktChannel <- newTChanIO
tid <- forkIO $ packetWriter timeoutAfter pktChannel
readLoop timeoutAfter pktChannel
killThread tid
The thumb rule of concurrency is: if adding a sleep in some point inside an IO action matters, your program is not safe.
To understand why the code timeout 1000000 $ atomically $ readTChan pktChannel does not work, consider the following alternative implementation of atomically:
atomically' :: STM a -> IO a
atomically' action = do
result <- atomically action
threadDelay someTimeAmount
return result
The above is equal to atomically, but for an extra innocent delay. Now it is easy to see that if timeout kills the thread during the threadDelay, the atomic action has completed (consuming a message from the channel), yet timeout will return Nothing.
A simple fix to timeout n $ atomically ... could be the following
smartTimeout :: Int -> STM a -> IO (Maybe a)
smartTimeout n action = do
v <- atomically $ newEmptyTMvar
_ <- timeout n $ atomically $ do
result <- action
putTMvar v result
atomically $ tryTakeTMvar v
The above uses an extra transactional variable v to do the trick. The result value of the action is stored into v inside the same atomic block in which the action is run. The return value of timeout is not trusted, since it does not tell us if action was run or not. After that, we check the TMVar v, which will be full if and only if action was run.
Instead of TChan a, use TChan (Maybe a) . Your normal producer (of x) now writes Just x. Fork an extra "ticking" process that writes Nothing to the channel (every x seconds). Then have a reader for the channel, and abort if you get two successive Nothing. This way, you avoid exceptions, which may cause data to get lost in your case (but I am not sure).