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