{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Test.Tasty.Process
( processTest
, TestProcess (..)
, proc
, shell
, defaultProcess
, ExitCodeCheck
, OutputCheck
, equals
, ignored
, setTimeout
)
where
import Control.DeepSeq (deepseq)
import Data.Foldable (for_)
import Data.Maybe (fromMaybe)
import GHC.IO.Handle (Handle, hClose, hFlush, hPutStr)
import System.Exit (ExitCode)
import System.IO (hGetContents)
import System.Process
( CmdSpec (..)
, CreateProcess (..)
, ProcessHandle
, StdStream (..)
, cleanupProcess
, createProcess
, waitForProcess
)
import qualified System.Process as P (proc, shell)
import Test.Tasty (TestName, TestTree, localOption, mkTimeout, withResource)
import Test.Tasty.Providers
( IsTest (..)
, Result
, singleTest
, testFailed
, testPassed
)
processTest
:: TestName
-> TestProcess
-> TestTree
processTest :: String -> TestProcess -> TestTree
processTest
String
testName
tp :: TestProcess
tp@TestProcess {CreateProcess
process :: CreateProcess
process :: TestProcess -> CreateProcess
process} =
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ())
-> (IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> TestTree)
-> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource
(CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
process)
(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess
(\IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io -> String
-> (TestProcess,
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
testName (TestProcess
tp, IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io))
type ExitCodeCheck = ExitCode -> Either String ()
type OutputCheck = String -> Either String ()
data TestProcess = TestProcess
{ TestProcess -> CreateProcess
process :: CreateProcess
, TestProcess -> Maybe String
input :: Maybe String
, TestProcess -> ExitCodeCheck
exitCodeCheck :: ExitCodeCheck
, TestProcess -> OutputCheck
stdoutCheck :: OutputCheck
, TestProcess -> OutputCheck
stderrCheck :: OutputCheck
}
defaultProcess :: TestProcess
defaultProcess :: TestProcess
defaultProcess =
TestProcess
{ process :: CreateProcess
process = CreateProcess
forall a. HasCallStack => a
undefined
, input :: Maybe String
input = Maybe String
forall a. Maybe a
Nothing
, exitCodeCheck :: ExitCodeCheck
exitCodeCheck = ExitCodeCheck
forall a. a -> Either String ()
ignored
, stdoutCheck :: OutputCheck
stdoutCheck = OutputCheck
forall a. a -> Either String ()
ignored
, stderrCheck :: OutputCheck
stderrCheck = OutputCheck
forall a. a -> Either String ()
ignored
}
instance
IsTest
(TestProcess, IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
where
run :: OptionSet
-> (TestProcess,
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
-> (Progress -> IO ())
-> IO Result
run OptionSet
_ (TestProcess
tp, IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io) Progress -> IO ()
_ = TestProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO Result
runTestProcess TestProcess
tp IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io
testOptions :: Tagged
(TestProcess,
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
[OptionDescription]
testOptions = [OptionDescription]
-> Tagged
(TestProcess,
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
[OptionDescription]
forall a.
a
-> Tagged
(TestProcess,
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle))
a
forall (m :: * -> *) a. Monad m => a -> m a
return []
runTestProcess
:: TestProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO Result
runTestProcess :: TestProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO Result
runTestProcess
TestProcess
{ CreateProcess
process :: TestProcess -> CreateProcess
process :: CreateProcess
process
, Maybe String
input :: TestProcess -> Maybe String
input :: Maybe String
input
, ExitCodeCheck
exitCodeCheck :: TestProcess -> ExitCodeCheck
exitCodeCheck :: ExitCodeCheck
exitCodeCheck
, OutputCheck
stdoutCheck :: TestProcess -> OutputCheck
stdoutCheck :: OutputCheck
stdoutCheck
, OutputCheck
stderrCheck :: TestProcess -> OutputCheck
stderrCheck :: OutputCheck
stderrCheck
}
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io = do
(Maybe Handle
mbStdinH, Maybe Handle
mbStdoutH, Maybe Handle
mbStderrH, ProcessHandle
ph) <- IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
io
Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe String
input ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
i -> do
(Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
`hPutStr` String
i) Maybe Handle
mbStdinH
(Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
hFlush Maybe Handle
mbStdinH
(Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Handle -> IO ()
hClose Maybe Handle
mbStdinH
String
stdout :: String <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handle -> IO String) -> Maybe Handle -> IO (Maybe String)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Handle -> IO String
hGetContents Maybe Handle
mbStdoutH
String
stderr :: String <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Handle -> IO String) -> Maybe Handle -> IO (Maybe String)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM Handle -> IO String
hGetContents Maybe Handle
mbStderrH
ExitCode
exitCode :: ExitCode <- String
stderr String -> IO ExitCode -> IO ExitCode
forall a b. NFData a => a -> b -> b
`deepseq` String
stdout String -> IO ExitCode -> IO ExitCode
forall a b. NFData a => a -> b -> b
`deepseq` ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
let exitFailure' :: String -> Result
exitFailure' = CreateProcess -> ExitCode -> String -> String -> String -> Result
exitFailure CreateProcess
process ExitCode
exitCode String
stderr String
stdout
let exitCodeCheckResult :: Either String ()
exitCodeCheckResult = ExitCodeCheck
exitCodeCheck ExitCode
exitCode
let stderrCheckResult :: Either String ()
stderrCheckResult = OutputCheck
stderrCheck String
stderr
let stdoutCheckResult :: Either String ()
stdoutCheckResult = OutputCheck
stdoutCheck String
stdout
let handleNotes :: String
handleNotes =
Maybe Handle -> String -> String
forall a. Maybe a -> String -> String
printHandleNote Maybe Handle
mbStdinH String
"stdin"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Handle -> String -> String
forall a. Maybe a -> String -> String
printHandleNote Maybe Handle
mbStdoutH String
"stdout"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Handle -> String -> String
forall a. Maybe a -> String -> String
printHandleNote Maybe Handle
mbStderrH String
"stderr"
let res :: Result
res
| Left String
reason <- Either String ()
exitCodeCheckResult =
String -> Result
exitFailure' (String
"ExitCode check failed.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
handleNotes)
| Left String
reason <- Either String ()
stdoutCheckResult =
String -> Result
exitFailure' (String
"Stdout check failed.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
handleNotes)
| Left String
reason <- Either String ()
stderrCheckResult =
String -> Result
exitFailure' (String
"Stderr check failed.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
handleNotes)
| Bool
otherwise = String -> Result
testPassed String
""
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
res
printHandleNote :: Maybe a -> String -> String
printHandleNote :: forall a. Maybe a -> String -> String
printHandleNote (Just a
_) String
_ = String
""
printHandleNote Maybe a
Nothing String
hName =
String
hName
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" was not captured because it is not set to `CreatePipe` in `CreateProcess`.\n"
exitFailure
:: CreateProcess -> ExitCode -> String -> String -> String -> Result
exitFailure :: CreateProcess -> ExitCode -> String -> String -> String -> Result
exitFailure CreateProcess {CmdSpec
cmdspec :: CmdSpec
cmdspec :: CreateProcess -> CmdSpec
cmdspec} ExitCode
code String
stderr String
stdout String
reason =
String -> Result
testFailed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$
[String] -> String
unlines
[ CmdSpec -> String
printCmdSpec CmdSpec
cmdspec String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" exited with code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExitCode -> String
forall a. Show a => a -> String
show ExitCode
code
, String
""
, if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stdout
then String
"Nothing was printed to stdout."
else String
"stdout contained:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stdout
, String
""
, if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
stderr
then String
"Nothing was printed to stderr."
else String
"stderr contained:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stderr
, String
""
, String
reason
]
printCmdSpec :: CmdSpec -> String
printCmdSpec :: CmdSpec -> String
printCmdSpec (ShellCommand String
x) = String
x
printCmdSpec (RawCommand String
x [String]
y) = [String] -> String
unwords (String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
y)
setTimeout :: Integer -> TestTree -> TestTree
setTimeout :: Integer -> TestTree -> TestTree
setTimeout = Timeout -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Timeout -> TestTree -> TestTree)
-> (Integer -> Timeout) -> Integer -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Timeout
mkTimeout
equals :: (Show a, Eq a) => a -> a -> Either String ()
equals :: forall a. (Show a, Eq a) => a -> a -> Either String ()
equals a
expected a
actual
| a
expected a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
actual = () -> Either String ()
forall a b. b -> Either a b
Right ()
| Bool
otherwise =
OutputCheck
forall a b. a -> Either a b
Left OutputCheck -> OutputCheck
forall a b. (a -> b) -> a -> b
$ String
"expected : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nactual : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
actual String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
ignored :: a -> Either String ()
ignored :: forall a. a -> Either String ()
ignored a
_ = () -> Either String ()
forall a b. b -> Either a b
Right ()
proc :: FilePath -> [String] -> CreateProcess
proc :: String -> [String] -> CreateProcess
proc String
x [String]
y =
(String -> [String] -> CreateProcess
P.proc String
x [String]
y) {std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe, std_in :: StdStream
std_in = StdStream
CreatePipe}
shell :: String -> CreateProcess
shell :: String -> CreateProcess
shell String
x = (String -> CreateProcess
P.shell String
x) {std_out :: StdStream
std_out = StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe, std_in :: StdStream
std_in = StdStream
CreatePipe}