{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module System.IO.Streams.Tests.Process (tests) where
import Control.Concurrent
import Control.Exception
import Control.Monad (liftM, void)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified System.IO.Streams as Streams
import System.Timeout
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.HUnit hiding (Test)
tests :: [Test]
#ifndef ENABLE_PROCESS_TESTS
tests = []
#else
tests = [ testInteractiveCommand
, testInteractiveProcess
]
testInteractiveCommand :: Test
testInteractiveCommand = testCase "process/interactiveCommand" $ do
(out, err) <- Streams.runInteractiveCommand "cat" >>= run [expected]
assertEqual "interactiveCommand" expected out
assertEqual "interactiveCommand" "" err
where
expected = "testing 1-2-3"
testInteractiveProcess :: Test
testInteractiveProcess = testCase "process/interactiveProcess" $ do
(out, err) <- Streams.runInteractiveProcess "/usr/bin/tr" ["a-z", "A-Z"]
Nothing Nothing
>>= run [inputdata]
assertEqual "interactiveProcess" expected out
assertEqual "interactiveProcess" "" err
where
inputdata = "testing 1-2-3"
expected = "TESTING 1-2-3"
run :: [ByteString]
-> (Streams.OutputStream ByteString,
Streams.InputStream S.ByteString,
Streams.InputStream S.ByteString,
Streams.ProcessHandle)
-> IO (S.ByteString, S.ByteString)
run input (stdin, stdout, stderr, processHandle) = tout 5000000 $ do
me <- myThreadId
outM <- newEmptyMVar
errM <- newEmptyMVar
bracket (mkThreads me outM errM) killThreads $ go outM errM
where
tout t m = timeout t m >>= maybe (error "timeout") return
barfTo me (e :: SomeException) = throwTo me e
killMe restore me m =
void (try (restore m) >>= either (barfTo me) return)
mkThreads me outM errM = mask $ \restore -> do
tid1 <- forkIO $ killMe restore me $ snarf stdout outM
tid2 <- forkIO $ killMe restore me $ snarf stderr errM
return (tid1, tid2)
killThreads (t1, t2) = do
mapM_ killThread [t1, t2]
Streams.waitForProcess processHandle
go outM errM _ = do
Streams.fromList input >>= Streams.connectTo stdin
out <- takeMVar outM
err <- takeMVar errM
return (out, err)
snarf is mv = liftM S.concat (Streams.toList is) >>= putMVar mv
#endif