I'm following this tutorial and looking at the test case in source code.
My code use SimplePool.hs in the source code and created the following file: (snippet)
sampleTask :: (TimeInterval, String) -> Process String
sampleTask (t, s) = sleep t >> return s
$(remotable ['sampleTask])
jobTest :: MVar (AsyncResult (Either String String)) -> Process ()
jobTest result = do
pid <- startTestPool 1 -- start the pool of workers here only one worker
job <- return $ ($(mkClosure 'sampleTask) (seconds 2, "foobar"))
-- callAsync put job into pool
p <- callAsync pid job
a <- wait p
setResult result a
where
setResult :: MVar a -> a -> Process ()
setResult mvar x = liftIO $ putMVar mvar x
startTestPool :: Int -> Process ProcessId
startTestPool s = spawnLocal $ do
_ <- runPool s
return ()
runPool :: Int -> Process (Either (InitResult (Pool String)) TerminateReason)
runPool s =
-- setting a to String
let s' = poolServer :: ProcessDefinition (Pool String)
in simplePool s s'
myRemoteTable :: RemoteTable
myRemoteTable = Control.Distributed.Process.Platform.__remoteTable initRemoteTable
main :: IO ()
main = do
Right (transport, _) <- createTransportExposeInternals
"127.0.0.1" "9901" defaultTCPParameters
localNode <- newLocalNode transport myRemoteTable
result <- newEmptyMVar
pid <- forkProcess localNode $ jobTest result
ans <- takeMVar result
putStrLn $ show pid
putStrLn $ show ans
I'm getting this error once I run it:
AsyncFailed (DiedException "exit-from=pid://127.0.0.1:9901:0:6")
Correct me if I'm wrong, I assume the job did not run correctly, must be some problem with the slave process.p <- callAsync pid job this line of code I think is where the task is passed on to slave process for execution. I looked into the library to find the definition of callAsync. The key line in callAsyncUsing is sendTo sid (CallMessage msg (Pid wpid)) where the function passes the task to the poolServer.
SimplePool.hs in the acceptTask the line asyncHandle <- async proc is where I think they spawn a new process to execute the task. So I think maybe the async process didn't finish running cause the the caller terminated prematurely? Or could it be that the process didn't spawn correctly? Any idea on what the best way to debug this? Also, can someone point me in the right direction to finding out how to make the poolSever span different nodes/different computers (using Control.Distributed.Process.Platform.Async.AsyncChan?)?
I have modified your code slightly, and this snippet includes the imports, so it compiles. Make sure that you are using the latest SimplePool module, as your code is using simplePool which I cannot find, and your use of runPool is ambiguous.
{-# LANGUAGE TemplateHaskell #-}
import Control.Concurrent.MVar
import Control.Exception (SomeException)
import Control.Distributed.Process hiding (call)
import Control.Distributed.Process.Closure
import Control.Distributed.Process.Node
import Control.Distributed.Process.Platform hiding (__remoteTable)
import Control.Distributed.Process.Platform.Async
import Control.Distributed.Process.Platform.ManagedProcess
import Control.Distributed.Process.Platform.Test
import Control.Distributed.Process.Platform.Time
import Control.Distributed.Process.Platform.Timer
import Control.Distributed.Process.Serializable()
import Network.Transport
import Network.Transport.TCP
import Data.Binary
import Data.Typeable (Typeable)
import SimplePool hiding (runPool)
import qualified SimplePool (runPool)
sampleTask :: (TimeInterval, String) -> Process String
sampleTask (t, s) = sleep t >> return s
$(remotable ['sampleTask])
jobTest :: MVar (AsyncResult (Either String String)) -> Process ()
jobTest result = do
pid <- startTestPool 1 -- start the pool of workers here only one worker
let job = $(mkClosure 'sampleTask) (seconds 2, "foobar")
-- callAsync put job into pool
p <- callAsync pid job
a <- wait p
setResult result a
where
setResult :: MVar a -> a -> Process ()
setResult mvar x = liftIO $ putMVar mvar x
startTestPool :: Int -> Process ProcessId
startTestPool s = spawnLocal $ do
_ <- runPool s
return ()
runPool :: Int -> Process (Either (InitResult (Pool String)) TerminateReason)
runPool = SimplePool.runPool
myRemoteTable :: RemoteTable
myRemoteTable = Main.__remoteTable initRemoteTable
main :: IO ()
main = do
Right (transport, _) <- createTransportExposeInternals
"127.0.0.1" "9901" defaultTCPParameters
localNode <- newLocalNode transport myRemoteTable
result <- newEmptyMVar
pid <- forkProcess localNode $ jobTest result
ans <- takeMVar result
print pid >> print ans
Running this compilable code:
$ ./Example
pid://127.0.0.1:9901:0:3
AsyncDone (Right "foobar")
Please note that the SimplePool sample module from the distributed-process-platform test suite has been promoted to a fully fledged component of the library. Its new location on the latest (development) branch is https://github.com/haskell-distributed/distributed-process-platform/blob/development/src/Control/Distributed/Process/Platform/Task/Queue/BlockingQueue.hs.
Some names/types have changed, so you may need to update your code in order to continue using it.
Related
I have a long running process which I need to start.
It takes a few seconds to start, and outputs logs to stdout, with one that indicates it is ready.
I would like to:
start the process silently, so that the stdout from the process is not displayed in my session.
capture the output as it streams so that I can determine that it is ready.
have some handle on the process so that I can stop the process at a later point.
I have come close using Shelly, Turtle and System.Process, but fail to capture the stdout.
Using System.Process I had:
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race)
import System.IO
import System.Process
startService :: IO ProcessHandle
startService = do
let cmd = "./my-service"
args = [ "-p 1234" ]
(_, Just hout, _, p) <- createProcess $ (proc cmd args) { std_out = CreatePipe }
started <- either id id <$> race (checkStarted hout) timeOut
unless started $ fail "Service not started"
pure p
where
checkStarted :: Handle -> IO Bool
checkStarted h = do
str <- hGetLine h
-- check str for started log, else loop
timeOut :: IO Bool
timeOut = do
threadDelay 10000000
pure False
But The handler hout was never in a ready state.
Using Shelly I had:
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race)
import Control.Concurrent.MVar
import Shelly
import System.IO
startService :: IO (Async ())
startService = do
let cmd = "./my-service"
args = [ "-p 1234" ]
startedMVar <- newEmptyMVar
async <- shelly $ asyncSh $ runHandle cmd args $ recordWhenStarted startedMVar
started <- either id id <$> race (readMVar startedMVar) timeOut
unless started $ fail "Service not started"
pure async
where
recordWhenStarted :: MVar Bool -> Text -> IO ()
recordWhenStarted mvar txt =
when (isStartedLog txt) $
modifyMVar_ mvar (const $ pure True)
timeOut :: IO Bool
timeOut = do
threadDelay 10000000
pure False
But the recordWhenStarted is never called.
The following is example of starting process and reading stdout in a program of mine:
runMystem :: [T.Text] -> IO T.Text
runMystem stemWords = do
(i, o, _, ph) <- createProcess (proc mystemExecutabe mystemParams) { std_in = CreatePipe, std_out = CreatePipe }
res <- flip (maybe (return T.empty)) i $ \hIn ->
flip (maybe (return T.empty)) o $ \hOut -> do
hSetEncoding hIn utf8
hSetEncoding hOut utf8
forM_ stemWords $ TIO.hPutStrLn hIn
TIO.hGetContents hOut
void $ waitForProcess ph
return res
This answer uses the process-streaming library (written by the author of this answer) which is a set of helpers over process.
{-# language OverloadedStrings #-}
{-# language NumDecimals #-}
import System.Process.Streaming (execute,piped,shell,foldOut,transduce1)
import qualified System.Process.Streaming.Text as PT
import Data.Text.Lazy (isInfixOf)
import Control.Applicative
import Control.Monad
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.MVar
main :: IO ()
main = do
started <- newEmptyMVar
let execution =
execute (piped (shell "{ sleep 3 ; echo fooo ; sleep 3 ; }")) $
foldOut . transduce1 PT.utf8x . PT.eachLine $ lookline
lookline line = do
when (isInfixOf "foo" line) (putMVar started ())
return (Right ())
stopOrNot =
do abort <- race (threadDelay 4e6) (readMVar started)
case abort of
Left () -> return () -- stop immediately
Right () -> runConcurrently empty -- sleep forever
result <- race stopOrNot execution
print result
execute installs exception handlers that terminate the external process when an asynchronous exceptions arrives, to it is safe to use race with it.
execute also takes care to drain any standard stream that is not read explicitly (like stderr in this case) to avoid a common source of deadlocks.
I asked a question how does hgearman-client work? three weeks ago. With some help I wrote a simple client application and I'm working on the worker side now. The worker implementation below compiles well and runs without any exception. The only trouble is that W.runWorker gc (return g) will not be executed. If I understand it correctly, it's the result of Haskell laziness and return t Monad wrapping. But I haven't faintest idea how to get rid of the issue. Could some one help?
import qualified Control.Monad.State as S
import qualified Data.ByteString.Char8 as B
import qualified Network.Gearman.Client as C
import qualified Network.Gearman.Worker as W
import Network.Gearman.Internal (Function, Port)
import Network.Socket (HostName)
main :: IO ()
main = do
c <- connect
case c of
Left e -> error $ B.unpack e
Right gc -> do
(res, _) <- flip S.runStateT gc $ do
g <- (W.registerWorker name func)
let t = W.runWorker gc (return g)
return t >> return ()
return res
where
connect = C.connectGearman (B.pack "i") host port
host = "localhost"::HostName
port = 4730::Port
name = (B.pack "foo")::Function
func _ = B.pack "bar"
Unfortunately an attempt to bind t <- W.runWorker ends in compiler exception. If I change the code in this way:
Right gc -> do
(res, _) <- flip S.runStateT gc $ do
g <- (W.registerWorker name func)
t <- W.runWorker gc (return ())
return t >> return ()
return res
The compilation fails with exception:
Couldn't match expected type `S.StateT
Network.Gearman.Internal.GearmanClient IO a0'
with actual type `IO GHC.Conc.Sync.ThreadId'
In a stmt of a 'do' block: t <- W.runWorker gc (return ())
In the second argument of `($)', namely
`do { g <- (W.registerWorker name func);
t <- W.runWorker gc (return ());
return t >> return () }'
IO GHC.Conc.Sync.ThreadId is the result of runWorker.
A value of type Gearman a for some a is an action, a recipe to do something. You can bind together such recipes to make bigger recipes, until you have constructed the main recipe which is the one that gets run.
Practically speaking, it means if you are running a do-block that looks like this:
do ...
foo
...
then foo will be run. If you have a do-block that looks like this:
do ...
ret <- foo
...
then foo will be run and the result of running foo will be stored in ret. Those two syntaxes are binds. However if you are running a do-block that looks like this:
do ...
let ret = foo
...
then foo will not be run -- instead you are just asking for the variable ret to be shorthand for foo, so foo and ret are afterwards interchangeable.
So now you can see, in:
do g <- W.registerWorker name func
let t = W.runWorker gc (return g)
return t >> return ()
the second line does not actually run a worker, it just lets t be a shorthand for running a worker. Returning an action does not bind it either. You need to bind:
t <- W.runWorker gc (return g)
By the way, I've been looking at the documentation and it looks like registerWorker returns a Gearman (), which means that the result of running the action is (), or "nothing interesting". So g is nothing interesting, you could get rid of it and say
do W.registerWorker name func
t <- W.runWorker gc (return ())
return t >> return ()
Presumably in place of that return () in the second line you would put an action that you wanted to run in the worker. Like:
t <- W.runWorker gc $ do
... the things you want the worker to do ...
return t >> return ()
And finally that last line: return t >> return (), also written
do return t
return ()
is exactly the same thing as return (). return x constructs an action with no side-effects, which is only used for the result. Then when you use >> (or don't bind the result in a do block) you run an action only for its side-effects and discard its result. So the first return does nothing whatsoever.
Finally I implemented a gearman worker in Haskell.
{-# LANGUAGE DeriveDataTypeable #-}
import Control.Exception (Exception, IOException, catch, throwIO)
import qualified Data.ByteString.Char8 as B
import Control.Monad.State
import Data.Typeable (Typeable)
import qualified Network.Gearman.Client as C
import qualified Network.Gearman.Worker as W
import Network.Gearman.Internal (Function, GearmanClient, Port)
import Network.Socket (HostName)
import Control.Concurrent
import qualified Control.Monad.State as S
data ConnectException = ConnectException HostName Port IOException
deriving (Show, Typeable)
instance Exception ConnectException
main :: IO ()
main = do
c <- connect
gc <- either (error . B.unpack) return c
work gc
return ()
where
connect = C.connectGearman (B.pack "worker-id") host port `catch` \e -> throwIO (ConnectException host port e)
host = "localhost"::HostName
port = 4730::Port
work :: GearmanClient -> IO ()
work gc = do
(res, _) <- flip S.runStateT gc $ do
W.registerWorker (B.pack "reverse"::Function) B.reverse
S.get >>= (\env -> forever $ S.liftIO (W.runWorker env (return ()) >> threadDelay (1000*1000)))
return ()
return res
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'm processing some audio using portaudio. The haskell FFI bindings call a user defined callback whenever there's audio data to be processed. This callback should be handled very quickly and ideally with no I/O. I wanted to save the audio input and return quickly since my application doesn't need to react to the audio in realtime (right now I'm just saving the audio data to a file; later I'll construct a simple speech recognition system).
I like the idea of pipes and thought I could use that library. The problem is that I don't know how to create a Producer that returns data that came in through a callback.
How do I handle my use case?
Here's what I'm working with right now, in case that helps (the datum mvar isn't working right now but I don't like storing all the data in a seq... I'd rather process it as it came instead of just at the end):
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Main where
import Codec.Wav
import Sound.PortAudio
import Sound.PortAudio.Base
import Sound.PortAudio.Buffer
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.C.Types
import Foreign.Storable
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB
import Control.Exception.Base (evaluate)
import Data.Int
import Data.Sequence as Seq
import Control.Concurrent
instance Buffer SV.Vector a where
fromForeignPtr fp = return . SVB.fromForeignPtr fp
toForeignPtr = return . (\(a, b, c) -> (a, c)) . SVB.toForeignPtr
-- | Wrap a buffer callback into the generic stream callback type.
buffCBtoRawCB' :: (StreamFormat input, StreamFormat output, Buffer a input, Buffer b output) =>
BuffStreamCallback input output a b -> StreamCallback input output
buffCBtoRawCB' func = \a b c d e -> do
fpA <- newForeignPtr_ d -- We will not free, as callback system will do that for us
fpB <- newForeignPtr_ e -- We will not free, as callback system will do that for us
storeInp <- fromForeignPtr fpA (fromIntegral $ 1 * c)
storeOut <- fromForeignPtr fpB (fromIntegral $ 0 * c)
func a b c storeInp storeOut
callback :: MVar (Seq.Seq [Int32]) -> PaStreamCallbackTimeInfo -> [StreamCallbackFlag] -> CULong
-> SV.Vector Int32 -> SV.Vector Int32 -> IO StreamResult
callback seqmvar = \timeinfo flags numsamples input output -> do
putStrLn $ "timeinfo: " ++ show timeinfo ++ "; flags are " ++ show flags ++ " in callback with " ++ show numsamples ++ " samples."
print input
-- write data to output
--mapM_ (uncurry $ pokeElemOff output) $ zip (map fromIntegral [0..(numsamples-1)]) datum
--print "wrote data"
input' <- evaluate $ SV.unpack input
modifyMVar_ seqmvar (\s -> return $ s Seq.|> input')
case flags of
[] -> return $ if unPaTime (outputBufferDacTime timeinfo) > 0.2 then Complete else Continue
_ -> return Complete
done doneMVar = do
putStrLn "total done dood!"
putMVar doneMVar True
return ()
main = do
let samplerate = 16000
Nothing <- initialize
print "initialized"
m <- newEmptyMVar
datum <- newMVar Seq.empty
Right s <- openDefaultStream 1 0 samplerate Nothing (Just $ buffCBtoRawCB' (callback datum)) (Just $ done m)
startStream s
_ <- takeMVar m -- wait until our callbacks decide they are done!
Nothing <- terminate
print "let's see what we've recorded..."
stuff <- takeMVar datum
print stuff
-- write out wav file
-- let datum =
-- audio = Audio { sampleRate = samplerate
-- , channelNumber = 1
-- , sampleData = datum
-- }
-- exportFile "foo.wav" audio
print "main done"
The simplest solution is to use MVars to communicate between the callback and Producer. Here's how:
import Control.Proxy
import Control.Concurrent.MVar
fromMVar :: (Proxy p) => MVar (Maybe a) -> () -> Producer p a IO ()
fromMVar mvar () = runIdentityP loop where
loop = do
ma <- lift $ takeMVar mvar
case ma of
Nothing -> return ()
Just a -> do
respond a
loop
Your stream callback will write Just input to the MVar and your finalization callback will write Nothing to terminate the Producer.
Here's a ghci example demonstrating how it works:
>>> mvar <- newEmptyMVar :: IO (MVar (Maybe Int))
>>> forkIO $ runProxy $ fromMVar mvar >-> printD
>>> putMVar mvar (Just 1)
1
>>> putMVar mvar (Just 2)
2
>>> putMVar mvar Nothing
>>> putMVar mvar (Just 3)
>>>
Edit: The pipes-concurrency library now provides this feature, and it even has a section in the tutorial explaining specifically how to use it to get data out of callbacks.
how could one implement a function in concurrent haskell that either returns 'a' successfully or due to timeout 'b'?
timed :: Int → IO a → b → IO (Either a b)
timed max act def = do
Best Regards,
Cetin SertNote: the signature of timed can be completely or slightly different.
Implementing your desired timed on top of System.Timeout.timeout is easy:
import System.Timeout (timeout)
timed :: Int -> IO a -> b -> IO (Either b a)
timed us act def = liftM (maybe (Left def) Right) (timeout us act)
By the way, the common implementation of timeout is closer to this: ($! = seq to try to force evaluation of the returned value in the thread rather than only returning a thunk):
import Control.Concurrent (forkIO, threadDelay, killThread)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import System.IO (hPrint, stderr)
timeout :: Int -> IO a -> IO (Maybe a)
timeout us act = do
mvar <- newEmptyMVar
tid1 <- forkIO $ (putMVar mvar . Just $!) =<< act
tid2 <- forkIO $ threadDelay us >> putMVar mvar Nothing
res <- takeMVar mvar
killThread (maybe tid1 (const tid2) res) `catch` hPrint stderr
return res
The implementation of System.Timeout.timeout in the libraries is a little more complex, handling more exceptional cases.
import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
import Control.Exception (Exception, handleJust, throwTo, bracket)
import Data.Typeable
import Data.Unique (Unique, newUnique)
data Timeout = Timeout Unique deriving Eq
timeoutTc :: TyCon
timeoutTc = mkTyCon "Timeout"
instance Typeable Timeout where { typeOf _ = mkTyConApp timeoutTc [] }
instance Show Timeout where
show _ = "<<timeout>>"
instance Exception Timeout
timeout n f
| n < 0 = fmap Just f
| n == 0 = return Nothing
| otherwise = do
pid <- myThreadId
ex <- fmap Timeout newUnique
handleJust (\e -> if e == ex then Just () else Nothing)
(\_ -> return Nothing)
(bracket (forkIO (threadDelay n >> throwTo pid ex))
(killThread)
(\_ -> fmap Just f))
Here's the first answer I could come up with. I needed this for a port scanner. o_O Forgot the admin password of my router and wanted to check which ports I had opened on our home server before that I could now repurpose and reuse ^ _ ^" ... This implementation should do the job for the time being.
module Control.Concurrent.Timed (timed) where
import Prelude hiding (take)
import System.IO
import Control.Monad
import System.Process
import System.Timeout
import Control.Concurrent
import System.Environment
timed :: Int → IO a → b → IO (Either b a)
timed max act def = do
w ← new
r ← new
t ← forkIO $ do
a ← act
r ≔ Right a
e ← em w
case e of
False → kill =<< take w
True → return ()
s ← forkIO $ do
(w ≔) =<< mine
wait max
e ← em r
case e of
True → do
kill t
r ≔ Left def
False → return ()
take r
timed_ :: Int → IO a → a → IO a
timed_ max act def = do
r ← timed max act def
return $ case r of
Right a → a
Left a → a
(≔) = putMVar
new = newEmptyMVar
wait = threadDelay
em = isEmptyMVar
kill = killThread
mine = myThreadId
take = takeMVar
or just use System.Timeout.timeout -__-"