The function below wants to either receive and ack or wait until its duetime has come and return.
Now, it works when it receives and ack. It works correctly when no ack is received and waits until duetime.
When the duetime is reached it freezes. It seems that it is not exiting my self constructed loop correctly. I have also tried with if-then-else, but same result. I do not want to use whileM.
How do I correctly exit the loop?
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
waitAck s duetime' = do
print ("in")
(a, _) <- recvFrom s 4711
now' <- getPOSIXTime
unless (B.unpack a == "ack") (when (now' < duetime') (waitAck s duetime'))
print (B.unpack a)
return ()
The correct solution is to race two threads, one that waits for the ack, and one that waits for the time. Kill the one that loses the race. Perhaps this (untested) code will give you a hint about how:
import Control.Concurrency.MVar
withTimeout :: Int -> IO a -> IO (Maybe a)
withTimeout n io = do
mvar <- newEmptyMVar
timeout <- forkIO (threadDelay n >> putMVar mvar Nothing)
action <- forkIO (io >>= putMVar mvar . Just)
result <- takeMVar mvar
killThread timeout
killThread action
return result
waitAck s timeout = withTimeout timeout go where
go = do
(a, _) <- recvFrom s 4711
if B.unpack a == "ack" then print (B.unpack a) else go
edit: It seems that base provides System.Timeout.timeout for exactly this purpose. Its implementation is more likely to be correct than this one, too.
That's not an iterative loop. You don't place any conditions on the stuff after the recursive call, so when the conditions finally fail, the whole thing will unwind, printing once for every recursive call. I suspect that might be enough to make it appear frozen.
Try something like this:
waitAck s duetime' = do
print ("in")
(a, _) <- recvFrom s 4711
now' <- getPOSIXTime
if B.unpack a == "ack" || now' >= duetime'
then print (B.unpack a)
else waitAck s duetime'
Related
I was trying to compile a haskell game code, this code generates three thread, one for infinite loop, one for collecting user's interaction, one for triggering the events. However, the code cannot be compiled and I don't know why.
Here's the code:
module Main where
import Control.Concurrent
import Control.Monad
import System.IO
import System.Random
import Text.Printf
data Msg = C Char | Time
data Event = C Char | Time Char
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
hSetBuffering stdin NoBuffering
hSetEcho stdin False
-- shared resources
chan <- newEmptyMVar
removedDigits <- newEmptyMVar
unmatchedDigits <- newEmptyMVar
numberOfGuesses <- newEmptyMVar
--starting the generating thread and the user thread
forkIO $ generatingThread chan
forkIO $ userThread chan
--the main loop
if mainloop chan == True then "Congratulations! You won!" else "Better luck next time!"
return()
mainloop :: Chan c -> Bool
let mainloop = do
if length unmatchedDigits >= 10
then return False
Event <- readChan c
if Event == "timer"
then unmatchedDigits ++ param
else if testGuessedNumber param unmatchedDigits == True
then
removeMatchedDigit
if length unmatchedDigits == 0
then return True
mainloop c
-- Generating Thread aka event thread generating the random numbers
generatingThread :: Chan msgChan -> IO ()
generatingThread msgChan = forever $ do
publishTimerEvent msgChan 1000000
publishTimerEvent :: Chan msgChan -> Int delay ()
publishTimerEvent msgChan = do
c <- getRandomChar
putMVar msgChan ("timer" c)
threadDelay newDelay
velocity <- 0.9
if delay * velocity < 100
then newDelay <- 100
else newDelay <- delay * velocity
publishTimerEvent msgChan newDelay
getRandomChar :: Char c ()
getRandomChar = do
i <- randomRIO (0,9)
let c = "0123456789" !! i
return c
-- User Thread
userThread :: MVar Msg -> IO ()
userThread chan = forever $ do
c <- getChar
putMVar chan (C c)
showStr(show c)
testGuessedNumber :: Int -> Int -> Bool
testGuessedNumber a b
| a == b = True
| otherwise = False
-- Shows the given string at the left edge of the current terminal line after
-- having blanked out the first 20 characters on that line.
showStr :: String -> IO ()
showStr s = putStr ("\r" ++ replicate 20 ' ' ++ "\r" ++ s)
The error is "test.hs:36:3: error: parse error on input ‘Event’"
Variable names can not begin with uppercase letters, such as Event. Try renaming the variable to something like event.
In Haskell, all if ... then ... else blocks must have all their components; what would the result be otherwise?
The problem is that the compiler was expecting an else, but it actually got Event. That said, you have more problems than a simple parse error. return does not do what you think it does. For example, this code will print hi.
main = do
return ()
putStrLn "hi"
The return function simply lifts a value into a monad, it doesn't stop the computation or anything like that. Here is what your probably want to have:
...
if length unmatchedDigits >= 10
then return False
else do
Event <- readChan c
if Event == "timer"
then ...
else ...
This way, nothing happens after the if block, so the function just ends there, with the last value as False (if length unmatchedDigits >= 10) or continues on properly (if length unmatchedDigits < 10).
You also almost certainly don't want to use Event (uppercase E), because that would mean it is a data constructor. You probably meant event (lowercase e), which is just an ordinary variable name.
Additionally: This is very, very non-idiomatic Haskell. You definitely don't need MVars in this situation, and certainly not four of them. Chans are not the same thing as MVars, and you don't need either one unless you are doing heavy-duty multi-threading. I highly recommend you completely rewrite this and try to minimize the amount of code that uses IO (it should be maybe 10-15 lines of IO code in this example, probably less).
This is not Java; you don't need to name your variables in your type signature (Chan msgChan -> Int delay ()), nor do you need to write wrapper functions for standard library functions to monomorphize their type. testGuessedNumber is literally the same function as (==).
You will have much more success if you revisit basic, pure function syntax and understand how problems are solved in Haskell than with trying to emulate another language. Read some LYAH or Real World Haskell.
http://pastebin.com/2CS1k1Zq
In this game i need to get step the game forward every half a second or so while occasionally getting input to change direction. These too things seem impossible to do with haskell is there a way to do it? Currently I am having an mv tread stall exception.
Update: Found the hWaitForInput function in System.IO which is essentially the same as waitFor.
Here is some code largely based on this answer.
The main difference I made is that the thread waiting for a key press does not perform the getChar directly. The result communicated in the MVar is an indication of timeout or that a key press has occurred. It is the responsibility of the main thread to actually get the character. This prevents a possible race condition in case the char reading thread is killed between getting the character and putting it into the MVar.
import Control.Concurrent
import Control.Monad
import Data.Maybe
import System.IO
import Control.Exception
data Event = CharReady | TimedOut
withRawStdin :: IO a -> IO a
withRawStdin = bracket uncook restore . const
where
uncook = do
oldBuffering <- hGetBuffering stdin
oldEcho <- hGetEcho stdin
hSetBuffering stdin NoBuffering
hSetEcho stdin False
return (oldBuffering, oldEcho)
restore (oldBuffering, oldEcho) = do
hSetBuffering stdin oldBuffering
hSetEcho stdin oldEcho
waitFor :: Int -> IO Event
waitFor delay = do
done <- newEmptyMVar
withRawStdin . bracket (start done) cleanUp $ \_ -> takeMVar done
where
start done = do
t1 <- forkIO $ hLookAhead stdin >> putMVar done CharReady
t2 <- forkIO $ threadDelay delay >> putMVar done TimedOut
return (t1, t2)
cleanUp (t1, t2) = do
killThread t1
killThread t2
loop state = do
if state <= 0
then putStrLn "Game over."
else do putStrLn $ "Rounds to go: " ++ show state
e <- waitFor 3000000
case e of
TimedOut -> do putStrLn "Too late!"; loop state
CharReady -> do c <- getChar -- should not block
if c == 'x'
then do putStrLn "Good job!"; loop (state-1)
else do putStrLn "Wrong key"; loop state
main = loop 3
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).
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.
I'm toying with Haskell threads, and I'm running into the problem of communicating lazily-evaluated values across a channel. For example, with N worker threads and 1 output thread, the workers communicate unevaluated work and the output thread ends up doing the work for them.
I've read about this problem in various documentation and seen various solutions, but I only found one solution that works and the rest do not. Below is some code in which worker threads start some computation that can take a long time. I start the threads in descending order, so that the first thread should take the longest, and the later threads should finish earlier.
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan -- .Strict
import Control.Concurrent.MVar
import Control.Exception (finally, evaluate)
import Control.Monad (forM_)
import Control.Parallel.Strategies (using, rdeepseq)
main = (>>=) newChan $ (>>=) (newMVar []) . run
run :: Chan (Maybe String) -> MVar [MVar ()] -> IO ()
run logCh statVars = do
logV <- spawn1 readWriteLoop
say "START"
forM_ [18,17..10] $ spawn . busyWork
await
writeChan logCh Nothing -- poison the logger
takeMVar logV
putStrLn "DONE"
where
say mesg = force mesg >>= writeChan logCh . Just
force s = mapM evaluate s -- works
-- force s = return $ s `using` rdeepseq -- no difference
-- force s = return s -- no-op; try this with strict channel
busyWork = say . show . sum . filter odd . enumFromTo 2 . embiggen
embiggen i = i*i*i*i*i
readWriteLoop = readChan logCh >>= writeReadLoop
writeReadLoop Nothing = return ()
writeReadLoop (Just mesg) = putStrLn mesg >> readWriteLoop
spawn1 action = do
v <- newEmptyMVar
forkIO $ action `finally` putMVar v ()
return v
spawn action = do
v <- spawn1 action
modifyMVar statVars $ \vs -> return (v:vs, ())
await = do
vs <- modifyMVar statVars $ \vs -> return ([], vs)
mapM_ takeMVar vs
Using most techniques, the results are reported in the order spawned; that is, the longest-running computation first. I interpret this to mean that the output thread is doing all the work:
-- results in order spawned (longest-running first = broken)
START
892616806655
503999185040
274877906943
144162977343
72313663743
34464808608
15479341055
6484436675
2499999999
DONE
I thought the answer to this would be strict channels, but they didn't work. I understand that WHNF for strings is insufficient because that would just force the outermost constructor (nil or cons for the first character of the string). The rdeepseq is supposed to fully evaluate, but it makes no difference. The only thing I've found that works is to map Control.Exception.evaluate :: a -> IO a over all the characters in the string. (See the force function comments in the code for several different alternatives.) Here's the result with Control.Exception.evaluate:
-- results in order finished (shortest-running first = correct)
START
2499999999
6484436675
15479341055
34464808608
72313663743
144162977343
274877906943
503999185040
892616806655
DONE
So why don't strict channels or rdeepseq produce this result? Are there other techniques? Am I misinterpreting why the first result is broken?
There are two issues going on here.
The reason the first attempt (using an explicit rnf) doesn't work is that, by using return, you've created a thunk that fully evaluates itself when it is evaluated, but the thunk itself has not being evaluated. Notice that the type of evaluate is a -> IO a: the fact that it returns a value in IO means that evaluate can impose ordering:
return (error "foo") >> return 1 == return 1
evaluate (error "foo") >> return 1 == error "foo"
The upshot is that this code:
force s = evaluate $ s `using` rdeepseq
will work (as in, have the same behavior as mapM_ evaluate s).
The case of using strict channels is a little trickier, but I believe this is due to a bug in strict-concurrency. The expensive computation is actually being run on the worker threads, but it's not doing you much good (you can check for this explicitly by hiding some asynchronous exceptions in your strings and seeing which thread the exception surfaces on).
What's the bug? Let's take a look at the code for strict writeChan:
writeChan :: NFData a => Chan a -> a -> IO ()
writeChan (Chan _read write) val = do
new_hole <- newEmptyMVar
modifyMVar_ write $ \old_hole -> do
putMVar old_hole $! ChItem val new_hole
return new_hole
We see that modifyMVar_ is called on write before we evaluate the thunk. The sequence of operations then is:
writeChan is entered
We takeMVar write (blocking anyone else who wants to write to the channel)
We evaluate the expensive thunk
We put the expensive thunk onto the channel
We putMVar write, unblocking all of the other threads
You don't see this behavior with the evaluate variants, because they perform the evaluation before the lock is acquired.
I’ll send Don mail about this and see if he agrees that this behavior is kind of suboptimal.
Don agrees that this behavior is suboptimal. We're working on a patch.