{-# LANGUAGE CPP #-}
module Test.Framework.BlackBoxTest (
BBTArgs(..), defaultBBTArgs,
blackBoxTests,
Diff, defaultDiff
) where
#if !MIN_VERSION_base(4,6,0)
import Prelude hiding ( catch )
#endif
import System.Exit
import System.Directory
import qualified Data.Map as Map
import Test.Framework.Process
import Test.Framework.TestInterface
import Test.Framework.TestManager
import Test.Framework.Utils
type Diff = Maybe FilePath -> String -> IO (Maybe String)
data BlackBoxTestCfg = BlackBoxTestCfg
{ BlackBoxTestCfg -> Bool
bbtCfg_shouldFail :: Bool
, BlackBoxTestCfg -> String
bbtCfg_cmd :: String
, BlackBoxTestCfg -> Maybe String
bbtCfg_stdinFile :: Maybe FilePath
, BlackBoxTestCfg -> Maybe String
bbtCfg_stdoutFile :: Maybe FilePath
, BlackBoxTestCfg -> Maybe String
bbtCfg_stderrFile :: Maybe FilePath
, BlackBoxTestCfg -> Bool
bbtCfg_verbose :: Bool
, BlackBoxTestCfg -> Diff
bbtCfg_stdoutCmp :: Diff
, BlackBoxTestCfg -> Diff
bbtCfg_stderrCmp :: Diff
}
runBlackBoxTest :: BlackBoxTestCfg -> Assertion
runBlackBoxTest :: BlackBoxTestCfg -> Assertion
runBlackBoxTest BlackBoxTestCfg
bbt =
do Maybe String
inp <- case BlackBoxTestCfg -> Maybe String
bbtCfg_stdinFile BlackBoxTestCfg
bbt of
Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Just String
f -> do String
s <- String -> IO String
readFile String
f
Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
s
(String
out,String
err,ExitCode
exit) <- String -> Maybe String -> IO (String, String, ExitCode)
popenShell (BlackBoxTestCfg -> String
bbtCfg_cmd BlackBoxTestCfg
bbt) Maybe String
inp
case ExitCode
exit of
ExitCode
ExitSuccess | BlackBoxTestCfg -> Bool
bbtCfg_shouldFail BlackBoxTestCfg
bbt
-> String -> Assertion
blackBoxTestFail (String
"test is supposed to fail but succeeded")
ExitFailure Int
i | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ BlackBoxTestCfg -> Bool
bbtCfg_shouldFail BlackBoxTestCfg
bbt
-> do let details :: String
details =
if (BlackBoxTestCfg -> Bool
bbtCfg_verbose BlackBoxTestCfg
bbt)
then (String
"stderr for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (BlackBoxTestCfg -> String
bbtCfg_cmd BlackBoxTestCfg
bbt) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
endOfOutput String
"stderr" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"stdout for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (BlackBoxTestCfg -> String
bbtCfg_cmd BlackBoxTestCfg
bbt) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
endOfOutput String
"stdout") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
else String
""
String -> Assertion
blackBoxTestFail (String
details String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"test is supposed to succeed but failed " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"with exit code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
ExitCode
_ -> do Maybe String
cmpOut <- Maybe String -> Diff -> String -> String -> IO (Maybe String)
forall {m :: * -> *} {t} {t} {a}.
Monad m =>
t -> (t -> t -> m (Maybe [a])) -> t -> [a] -> m (Maybe [a])
cmp (BlackBoxTestCfg -> Maybe String
bbtCfg_stdoutFile BlackBoxTestCfg
bbt) (BlackBoxTestCfg -> Diff
bbtCfg_stdoutCmp BlackBoxTestCfg
bbt)
String
out String
"Mismatch on stdout:\n"
Maybe String
cmpErr <- Maybe String -> Diff -> String -> String -> IO (Maybe String)
forall {m :: * -> *} {t} {t} {a}.
Monad m =>
t -> (t -> t -> m (Maybe [a])) -> t -> [a] -> m (Maybe [a])
cmp (BlackBoxTestCfg -> Maybe String
bbtCfg_stderrFile BlackBoxTestCfg
bbt) (BlackBoxTestCfg -> Diff
bbtCfg_stderrCmp BlackBoxTestCfg
bbt)
String
err String
"Mismatch on stderr:\n"
case (Maybe String
cmpOut, Maybe String
cmpErr) of
(Maybe String
Nothing, Maybe String
Nothing) -> () -> Assertion
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Maybe String
x1, Maybe String
x2) ->
do let details :: String
details = String -> String
ensureNewline (Maybe String
x1 Maybe String -> Maybe String -> String
`concatMaybes` Maybe String
x2)
String -> Assertion
blackBoxTestFail String
details
where cmp :: t -> (t -> t -> m (Maybe [a])) -> t -> [a] -> m (Maybe [a])
cmp t
expectFile t -> t -> m (Maybe [a])
cmpAction t
real [a]
label =
do Maybe [a]
res <- t -> t -> m (Maybe [a])
cmpAction t
expectFile t
real
case Maybe [a]
res of
Maybe [a]
Nothing -> Maybe [a] -> m (Maybe [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [a]
forall a. Maybe a
Nothing
Just [a]
s -> Maybe [a] -> m (Maybe [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [a] -> m (Maybe [a])) -> Maybe [a] -> m (Maybe [a])
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a]
label [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
s)
concatMaybes :: Maybe String -> Maybe String -> String
concatMaybes Maybe String
Nothing Maybe String
Nothing = String
""
concatMaybes (Just String
s) Maybe String
Nothing = String
s
concatMaybes (Maybe String
Nothing) (Just String
s) = String
s
concatMaybes (Just String
s1) (Just String
s2) = String
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s2
endOfOutput :: String -> String
endOfOutput :: String -> String
endOfOutput String
s = String
"[end of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
blackBoxTestFail :: String -> Assertion
blackBoxTestFail :: String -> Assertion
blackBoxTestFail String
s = FullTestResult -> Assertion
forall (m :: * -> *) a.
MonadBaseControl IO m =>
FullTestResult -> m a
failHTF (FullTestResult -> Assertion) -> FullTestResult -> Assertion
forall a b. (a -> b) -> a -> b
$ TestResult -> Maybe String -> FullTestResult
mkFullTestResult TestResult
Fail (String -> Maybe String
forall a. a -> Maybe a
Just String
s)
data BBTArgs = BBTArgs { BBTArgs -> String
bbtArgs_stdinSuffix :: String
, BBTArgs -> String
bbtArgs_stdoutSuffix :: String
, BBTArgs -> String
bbtArgs_stderrSuffix :: String
, BBTArgs -> String
bbtArgs_dynArgsName :: String
, BBTArgs -> Bool
bbtArgs_verbose :: Bool
, BBTArgs -> Diff
bbtArgs_stdoutDiff :: Diff
, BBTArgs -> Diff
bbtArgs_stderrDiff :: Diff
}
defaultBBTArgs :: BBTArgs
defaultBBTArgs :: BBTArgs
defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix :: String
bbtArgs_stdinSuffix = String
".in"
, bbtArgs_stdoutSuffix :: String
bbtArgs_stdoutSuffix = String
".out"
, bbtArgs_stderrSuffix :: String
bbtArgs_stderrSuffix = String
".err"
, bbtArgs_dynArgsName :: String
bbtArgs_dynArgsName = String
"BBTArgs"
, bbtArgs_stdoutDiff :: Diff
bbtArgs_stdoutDiff = Diff
defaultDiff
, bbtArgs_stderrDiff :: Diff
bbtArgs_stderrDiff = Diff
defaultDiff
, bbtArgs_verbose :: Bool
bbtArgs_verbose = Bool
False }
defaultDiff :: Diff
defaultDiff :: Diff
defaultDiff Maybe String
expectFile String
real =
case Maybe String
expectFile of
Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Just String
expect ->
do Maybe String
mexe <- String -> IO (Maybe String)
findExecutable String
"diff"
let exe :: String
exe = case Maybe String
mexe of
Just String
p -> String
p
Maybe String
Nothing -> String -> String
forall a. HasCallStack => String -> a
error (String
"diff command not in path")
(String
out, String
err, ExitCode
exitCode) <- String -> [String] -> Maybe String -> IO (String, String, ExitCode)
popen String
exe [String
"-u", String
expect, String
"-"]
(String -> Maybe String
forall a. a -> Maybe a
Just String
real)
case ExitCode
exitCode of
ExitCode
ExitSuccess -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
ExitFailure Int
1 ->
Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String
out String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
endOfOutput String
"diff output"))
ExitFailure Int
i -> String -> IO (Maybe String)
forall a. HasCallStack => String -> a
error (String
"diff command failed with exit " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
blackBoxTests :: FilePath
-> String
-> String
-> BBTArgs
-> IO [Test]
blackBoxTests :: String -> String -> String -> BBTArgs -> IO [Test]
blackBoxTests String
root String
exe String
suf BBTArgs
cfg =
do let prune :: String -> p -> IO Bool
prune String
root p
_ = do DynamicConfig
dynCfg <- DynamicConfigMap -> String -> IO DynamicConfig
readDynCfg DynamicConfigMap
forall k a. Map k a
Map.empty
(String
root String -> String -> String
</>
BBTArgs -> String
bbtArgs_dynArgsName BBTArgs
cfg)
Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ DynamicConfig -> Bool
dyn_skip DynamicConfig
dynCfg
[String]
inputFiles <- String -> String -> (String -> [String] -> IO Bool) -> IO [String]
collectFiles String
root String
suf String -> [String] -> IO Bool
forall {p}. String -> p -> IO Bool
prune
(DynamicConfigMap
_, [Test]
tests) <- (DynamicConfigMap -> String -> IO (DynamicConfigMap, Test))
-> DynamicConfigMap -> [String] -> IO (DynamicConfigMap, [Test])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM DynamicConfigMap -> String -> IO (DynamicConfigMap, Test)
genTest DynamicConfigMap
forall k a. Map k a
Map.empty [String]
inputFiles
[Test] -> IO [Test]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Test]
tests
where genTest :: DynamicConfigMap -> FilePath -> IO (DynamicConfigMap,
Test)
genTest :: DynamicConfigMap -> String -> IO (DynamicConfigMap, Test)
genTest DynamicConfigMap
map String
fname =
do Maybe String
stdinf <- String -> IO (Maybe String)
maybeFile (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> String -> String
replaceSuffix String
fname
(BBTArgs -> String
bbtArgs_stdinSuffix BBTArgs
cfg)
Maybe String
stdoutf <- String -> IO (Maybe String)
maybeFile (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> String -> String
replaceSuffix String
fname
(BBTArgs -> String
bbtArgs_stdoutSuffix BBTArgs
cfg)
Maybe String
stderrf <- String -> IO (Maybe String)
maybeFile (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> String -> String
replaceSuffix String
fname
(BBTArgs -> String
bbtArgs_stderrSuffix BBTArgs
cfg)
let configFile :: String
configFile = String -> String
dirname String
fname String -> String -> String
</> BBTArgs -> String
bbtArgs_dynArgsName BBTArgs
cfg
DynamicConfig
dynCfg <- DynamicConfigMap -> String -> IO DynamicConfig
readDynCfg DynamicConfigMap
map String
configFile
let cmd :: String
cmd = String
exe String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
dropSpace (DynamicConfig -> String
dyn_flags DynamicConfig
dynCfg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
fname
shouldFail :: Bool
shouldFail = DynamicConfig -> Bool
dyn_shouldFail DynamicConfig
dynCfg
verbose :: Bool
verbose = BBTArgs -> Bool
bbtArgs_verbose BBTArgs
cfg Bool -> Bool -> Bool
|| DynamicConfig -> Bool
dyn_verbose DynamicConfig
dynCfg
let bbt :: BlackBoxTestCfg
bbt = BlackBoxTestCfg
{ bbtCfg_shouldFail :: Bool
bbtCfg_shouldFail = Bool
shouldFail
, bbtCfg_cmd :: String
bbtCfg_cmd = String
cmd
, bbtCfg_stdinFile :: Maybe String
bbtCfg_stdinFile = Maybe String
stdinf
, bbtCfg_stdoutFile :: Maybe String
bbtCfg_stdoutFile = Maybe String
stdoutf
, bbtCfg_stderrFile :: Maybe String
bbtCfg_stderrFile = Maybe String
stderrf
, bbtCfg_verbose :: Bool
bbtCfg_verbose = Bool
verbose
, bbtCfg_stdoutCmp :: Diff
bbtCfg_stdoutCmp = BBTArgs -> Diff
bbtArgs_stdoutDiff BBTArgs
cfg
, bbtCfg_stderrCmp :: Diff
bbtCfg_stderrCmp = BBTArgs -> Diff
bbtArgs_stderrDiff BBTArgs
cfg
}
(DynamicConfigMap, Test) -> IO (DynamicConfigMap, Test)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> DynamicConfig -> DynamicConfigMap -> DynamicConfigMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
configFile DynamicConfig
dynCfg DynamicConfigMap
map,
String -> Assertion -> Test
makeBlackBoxTest String
fname (BlackBoxTestCfg -> Assertion
runBlackBoxTest BlackBoxTestCfg
bbt))
data DynamicConfig = DynamicConfig { DynamicConfig -> Bool
dyn_skip :: Bool
, DynamicConfig -> String
dyn_flags :: String
, DynamicConfig -> Bool
dyn_shouldFail :: Bool
, DynamicConfig -> Bool
dyn_verbose :: Bool }
type DynamicConfigMap = Map.Map FilePath DynamicConfig
defaultDynCfg :: DynamicConfig
defaultDynCfg = DynamicConfig { dyn_skip :: Bool
dyn_skip = Bool
False
, dyn_flags :: String
dyn_flags = String
""
, dyn_shouldFail :: Bool
dyn_shouldFail = Bool
False
, dyn_verbose :: Bool
dyn_verbose = Bool
False }
readDynCfg :: DynamicConfigMap -> FilePath -> IO DynamicConfig
readDynCfg :: DynamicConfigMap -> String -> IO DynamicConfig
readDynCfg DynamicConfigMap
m String
f =
do case String -> DynamicConfigMap -> Maybe DynamicConfig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
f DynamicConfigMap
m of
Just DynamicConfig
dynCfg -> DynamicConfig -> IO DynamicConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DynamicConfig
dynCfg
Maybe DynamicConfig
Nothing ->
do Bool
b <- String -> IO Bool
doesFileExist String
f
if Bool -> Bool
not Bool
b then DynamicConfig -> IO DynamicConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicConfig -> IO DynamicConfig)
-> DynamicConfig -> IO DynamicConfig
forall a b. (a -> b) -> a -> b
$ DynamicConfig
defaultDynCfg
else do String
s <- String -> IO String
readFile String
f
DynamicConfig -> IO DynamicConfig
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicConfig -> IO DynamicConfig)
-> DynamicConfig -> IO DynamicConfig
forall a b. (a -> b) -> a -> b
$ (DynamicConfig -> String -> DynamicConfig)
-> DynamicConfig -> [String] -> DynamicConfig
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (String -> DynamicConfig -> String -> DynamicConfig
parse String
f) DynamicConfig
defaultDynCfg ([String] -> DynamicConfig) -> [String] -> DynamicConfig
forall a b. (a -> b) -> a -> b
$
(String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isUseless) ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
dropSpace
(String -> [String]
lines String
s))
where isUseless :: String -> Bool
isUseless :: String -> Bool
isUseless [] = Bool
True
isUseless (Char
'#':String
_) = Bool
True
isUseless String
_ = Bool
False
parse :: FilePath -> DynamicConfig -> String -> DynamicConfig
parse :: String -> DynamicConfig -> String -> DynamicConfig
parse String
_ DynamicConfig
cfg String
"Skip" = DynamicConfig
cfg { dyn_skip = True }
parse String
_ DynamicConfig
cfg String
"Fail" = DynamicConfig
cfg { dyn_shouldFail = True }
parse String
_ DynamicConfig
cfg String
"Verbose" = DynamicConfig
cfg { dyn_verbose = True }
parse String
_ DynamicConfig
cfg (Char
'F':Char
'l':Char
'a':Char
'g':Char
's':Char
':':String
flags) = DynamicConfig
cfg { dyn_flags = flags }
parse String
f DynamicConfig
_ String
l = String -> DynamicConfig
forall a. HasCallStack => String -> a
error (String
"invalid line in dynamic configuration file `" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
l)