module Main (main) where
import Control.Monad
import Control.Monad.Reader
import Data.Char
import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Text.Printf
import Text.Read (readMaybe)
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.Posix.Terminal
import System.Posix.Types
import Config
import JUnit
import Output
import Parser.Core
import Process
import Run.Builtins
import TestMode
import TextFormat
import Version
data CmdlineOptions = CmdlineOptions
{ optTest :: TestOptions
, optExclude :: [ Text ]
, optVerbose :: Bool
, optReport :: Bool
, optJUnitReport :: Maybe FilePath
, optColor :: Maybe Bool
, optShowHelp :: Bool
, optShowVersion :: Bool
, optTestMode :: Bool
, optCmdlineTcpdump :: TcpdumpOption
}
defaultCmdlineOptions :: CmdlineOptions
defaultCmdlineOptions = CmdlineOptions
{ optTest = defaultTestOptions
, optExclude = []
, optVerbose = False
, optReport = False
, optJUnitReport = Nothing
, optColor = Nothing
, optShowHelp = False
, optShowVersion = False
, optTestMode = False
, optCmdlineTcpdump = TcpdumpAuto
}
data TcpdumpOption
= TcpdumpAuto
| TcpdumpManual FilePath
| TcpdumpOff
options :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ]
options =
[ Option ['T'] ["tool"]
(ReqArg (\str -> to $ \opts -> case break (==':') str of
(path, []) -> opts { optDefaultTool = path }
(pname, (_:path)) -> opts { optProcTools = (ProcName (T.pack pname), path) : optProcTools opts }
) "<path>")
"test tool to be used"
, Option ['v'] ["verbose"]
(NoArg (\opts -> opts { optVerbose = True }))
"show output of processes and successful tests"
, Option [] [ "color" ]
(NoArg (\opts -> opts { optColor = Just True }))
"always use colors for output (default when stdout is tty)"
, Option [] [ "no-color" ]
(NoArg (\opts -> opts { optColor = Just False }))
"never use colors for output (default when stdout is not a tty)"
, Option ['t'] ["timeout"]
(ReqArg (\str -> to $ \opts -> case readMaybe str of
Just timeout -> opts { optTimeout = timeout }
Nothing -> error "timeout must be a number") "<seconds>")
"default timeout in seconds with microsecond precision"
, Option ['g'] ["gdb"]
(NoArg $ to $ \opts -> opts { optGDB = True })
"run GDB and attach spawned processes"
, Option ['f'] ["force"]
(NoArg $ to $ \opts -> opts { optForce = True })
"remove test directory if it already exists instead of stopping"
, Option ['k'] ["keep"]
(NoArg $ to $ \opts -> opts { optKeep = True })
"keep test directory even if all tests succeed"
, Option ['r'] ["repeat"]
(ReqArg (\str -> to $ \opts -> opts { optRepeat = read str }) "<count>")
"number of times to repeat the test(s)"
, Option [ 'e' ] [ "exclude" ]
(ReqArg (\str opts -> opts { optExclude = T.pack str : optExclude opts }) "<test|tag>")
"exclude given test or test tag from execution"
, Option [] [ "keep-going" ]
(NoArg $ to $ \opts -> opts { optKeepGoing = True })
"keep going after a failed test"
, Option [] [ "report" ]
(NoArg $ \opts -> opts { optReport = True, optTest = (optTest opts) { optKeepGoing = True } })
"print summary of passing and failing tests (implies --keep-going)"
, Option [] [ "junit-report" ]
(ReqArg (\str opts -> opts { optJUnitReport = Just str, optTest = (optTest opts) { optKeepGoing = True } }) "<path>")
"write test report in JUnit XML format to <path> (implies --keep-going)"
, Option [] ["wait"]
(NoArg $ to $ \opts -> opts { optWait = True })
"wait at the end of each test"
, Option [] [ "no-tcpdump" ]
(NoArg (\opts -> opts { optCmdlineTcpdump = TcpdumpOff }))
"do not run tcpdump to capture network traffic"
, Option [] [ "tcpdump" ]
(OptArg (\str opts -> opts { optCmdlineTcpdump = maybe TcpdumpAuto TcpdumpManual str }) "<path>")
"use tcpdump to capture network traffic, at given <path> or found in PATH"
, Option ['h'] ["help"]
(NoArg $ \opts -> opts { optShowHelp = True })
"show this help and exit"
, Option ['V'] ["version"]
(NoArg $ \opts -> opts { optShowVersion = True })
"show version and exit"
]
where
to f opts = opts { optTest = f (optTest opts) }
hiddenOptions :: [ OptDescr (CmdlineOptions -> CmdlineOptions) ]
hiddenOptions =
[ Option [] [ "test-mode" ]
(NoArg (\opts -> opts { optTestMode = True }))
"test mode"
]
main :: IO ()
main = do
config <- mapM parseConfig =<< findConfig
let baseDir = maybe "." configDir config
envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool ->
return $ fromMaybe (error "No test tool defined") $ mbtool `mplus` (return . (baseDir </>) =<< configTool =<< config)
let initOpts = defaultCmdlineOptions
{ optTest = defaultTestOptions
{ optDefaultTool = envtool
, optTestDir = normalise $ baseDir </> optTestDir defaultTestOptions
, optTimeout = fromMaybe (optTimeout defaultTestOptions) $ configTimeout =<< config
}
}
args <- getArgs
(opts, oselection) <- case getOpt Permute (options ++ hiddenOptions) args of
(o, files, []) -> return (foldl (flip id) initOpts o, files)
(_, _, errs) -> do
hPutStrLn stderr $ concat errs <> "Try `erebos-tester --help' for more information."
exitFailure
let ( ofiles, otests )
| any (any isPathSeparator) oselection = ( oselection, [] )
| otherwise = ( [], map T.pack oselection )
when (optShowHelp opts) $ do
let header = unlines
[ "Usage: erebos-tester [<option>...] [<test-name>...]"
, " or: erebos-tester [<option>...] <script>[:<test>]..."
, " <test-name> name of a test from project configuration"
, " <script> path to test script file"
, " <test> name of the test to run"
, ""
]
<> "Options are:"
putStrLn $ usageInfo header options
exitSuccess
when (optShowVersion opts) $ do
putStrLn versionLine
exitSuccess
when (optTestMode opts) $ do
testMode config
exitSuccess
case words $ optDefaultTool $ optTest opts of
(path : _) -> getPermissions path >>= \perms -> do
when (not $ executable perms) $ do
fail $ "‘" <> path <> "’ is not executable"
_ -> fail $ "invalid tool argument: ‘" <> optDefaultTool (optTest opts) <> "’"
files <- if not (null ofiles)
then return $ flip map ofiles $ \ofile ->
case span (/= ':') ofile of
(path, ':':test) -> (path, Just $ T.pack test)
(path, _) -> (path, Nothing)
else map (, Nothing) <$> maybe (return []) (getConfigTestFiles) config
when (null files) $ fail $ "No test files"
useColor <- case optColor opts of
Just use -> return use
Nothing -> queryTerminal (Fd 1)
let outputStyle
| optVerbose opts = OutputStyleVerbose
| otherwise = OutputStyleQuiet
out <- startOutput outputStyle useColor
lm@LoadedModules {..} <- exitOnError =<< loadModules files
let tfSelect = if null otests then Nothing else Just otests
tfExclude = optExclude opts
tfilter = maybe mempty testFilterFromConfig config <> TestFilter {..}
tests <- exitOnError $ filterTests tfilter lm
tcpdump <- case optCmdlineTcpdump opts of
TcpdumpAuto -> findExecutable "tcpdump"
TcpdumpManual path -> return (Just path)
TcpdumpOff -> return Nothing
let topts = (optTest opts)
{ optTcpdump = tcpdump
}
report@Report {..} <- runTests out topts lmGlobalDefs tests
when (optReport opts) $ flip runReaderT out $ do
outLineF OutputGlobalSummary Nothing $ "Total tests: " <> plainText (T.pack (show reportTotalCount))
let ( mins, secs ) = (floor reportTotalTime :: Integer) `quotRem` 60
csecs = floor (reportTotalTime * 100) `rem` 100 :: Integer
outLineF OutputGlobalSummary Nothing $ "Total time: " <> plainText (T.pack $ printf "%d:%02d.%02d" mins secs csecs)
outLineF OutputGlobalSummary Nothing $ mconcat
[ "Passed tests: "
, withStyle (if (reportPassedCount > 0) then setForegroundColor Green noStyle else noStyle) $
plainText $ T.pack $ show reportPassedCount
]
outLineF OutputGlobalSummary Nothing $ mconcat
[ "Failed tests: "
, withStyle (if (reportFailedCount > 0) then setForegroundColor Red noStyle else noStyle) $
plainText (T.pack (show reportFailedCount))
]
when (reportFailedCount > 0) $ do
outLine OutputGlobalSummary Nothing ""
outLineF OutputGlobalSummary Nothing $ withStyle (setForegroundColor BrightRed noStyle) $ "Failed tests:"
forM_ reportFailedList $ \tname -> do
outLineF OutputGlobalSummary Nothing $
withStyle (setForegroundColor Red noStyle) $
plainText $ textTestName tname
forM_ (optJUnitReport opts) $ \path -> writeJUnitReport path report
when (reportFailedCount > 0) exitFailure
exitOnError :: Either CustomTestError a -> IO a
exitOnError (Left err) = do
hPutStrLn stderr $ capitalize $ showCustomTestError err
exitFailure
where
capitalize (c : cs) = toUpper c : cs
capitalize [] = []
exitOnError (Right x) = do
return x
foreign export ccall testerMain :: IO ()
testerMain :: IO ()
testerMain = main