From 5f892bc3cd212f362b0a8f29528b783b142da8e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 17 Oct 2026 11:10:40 +0200 Subject: Config option to find tool path using cabal Changelog: Added config file option to find test tool executable via cabal. --- src/Config.hs | 20 ++++++++++++++++++-- src/Main.hs | 28 ++++++++++++++++++---------- src/Run.hs | 22 ++++++++++++++++++++-- src/Run/Monad.hs | 10 +++++++--- src/TestMode.hs | 2 +- 5 files changed, 64 insertions(+), 18 deletions(-) (limited to 'src') diff --git a/src/Config.hs b/src/Config.hs index af2161a..8555540 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -1,5 +1,6 @@ module Config ( Config(..), + ConfigTool(..), findConfig, parseConfig, getConfigTestFiles, @@ -20,7 +21,7 @@ import System.FilePath.Glob data Config = Config { configDir :: FilePath - , configTool :: Maybe FilePath + , configTool :: Maybe ConfigTool , configTests :: [ Pattern ] , configSelect :: Maybe [ Text ] , configExclude :: [ Text ] @@ -28,9 +29,18 @@ data Config = Config } deriving (Show) +data ConfigTool + = ToolPath FilePath + | ToolCabal Text + deriving (Show) + instance FromYAML (FilePath -> Config) where parseYAML = withMap "Config" $ \m -> do - configTool <- (fmap T.unpack <$> m .:? "tool") + configTool <- foldr1 (<|>) + [ Just . ToolPath . T.unpack <$> m .: "tool" -- tool path as string + , Just <$> m .: "tool" + , return Nothing + ] configTests <- (map (compile . T.unpack) <$> foldr1 (<|>) [ fmap (:[]) (m .: "tests") -- single pattern , m .:? "tests" .!= [] -- list of patterns @@ -55,6 +65,12 @@ instance FromYAML Number where Scalar _ (SInt x) -> return $ Number $ fromIntegral x node -> typeMismatch "int or float" node +instance FromYAML ConfigTool where + parseYAML = withMap "tool specification" $ \m -> foldr1 (<|>) + [ ToolPath . T.unpack <$> m .: "path" + , ToolCabal <$> m .: "cabal" + ] + findConfig :: IO (Maybe FilePath) findConfig = go "." where diff --git a/src/Main.hs b/src/Main.hs index 3bc9e22..fc91b56 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -66,9 +66,9 @@ data TcpdumpOption 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 } + (ReqArg (\str -> to $ \opts -> case break (== ':') str of + ( path, [] ) -> opts { optDefaultTool = ToolPath path } + ( pname, _ : path ) -> opts { optProcTools = ( ProcName (T.pack pname), ToolPath path ) : optProcTools opts } ) "") "test tool to be used" , Option ['v'] ["verbose"] @@ -140,8 +140,14 @@ 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) + envtool <- lookupEnv "EREBOS_TEST_TOOL" >>= \mbtool -> if + | Just envpath <- mbtool + -> return $ ToolPath envpath + | Just conftool <- configTool =<< config + -> case conftool of + ToolPath cpath -> return $ ToolPath $ baseDir cpath + ToolCabal ccabal -> return $ ToolCabal ccabal + | otherwise -> return $ error "No test tool defined" let initOpts = defaultCmdlineOptions { optTest = defaultTestOptions @@ -183,11 +189,13 @@ main = 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) <> "’" + case optDefaultTool $ optTest opts of + ToolPath tpath -> case words tpath of + (path : _) -> getPermissions path >>= \perms -> do + when (not $ executable perms) $ do + fail $ "‘" <> path <> "’ is not executable" + _ -> fail $ "invalid tool argument: ‘" <> tpath <> "’" + ToolCabal _ -> return () files <- if not (null ofiles) then return $ flip map ofiles $ \ofile -> diff --git a/src/Run.hs b/src/Run.hs index 1d637d3..a1184c4 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -126,6 +126,22 @@ runTest out opts gdefs test = do procVar <- newMVar [] timeoutVar <- newMVar ( optTimeout opts, 0 ) + let evalTool = \case + ToolPath path -> return path + ToolCabal arg + | (name : args) <- T.words arg + -> do + readCreateProcessWithExitCode (proc "cabal" $ [ "list-bin", T.unpack name ]) "" >>= \case + ( ExitSuccess, cabalOut, _ ) -> do + let path = takeWhile (/= '\n') cabalOut + return $ T.unpack $ T.unwords (T.pack path : args) + _ -> do + ioError $ userError $ "failed to find ‘" <> T.unpack name <> "’ executable path using cabal" + | otherwise + -> return $ T.unpack arg + defaultTool <- evalTool $ optDefaultTool opts + procTools <- mapM (sequence . fmap evalTool) $ optProcTools opts + mgdb <- if optGDB opts then flip runReaderT out $ do gdb <- gdbStart $ atomically . writeTVar failedVar . Just . ProcessCrashed @@ -136,6 +152,8 @@ runTest out opts gdefs test = do { teOutput = out , teFailed = failedVar , teOptions = opts + , teDefaultTool = defaultTool + , teProcTools = procTools , teTestDir = testDir , teNextObjId = objIdVar , teNextProcId = procIdVar @@ -344,9 +362,9 @@ runStep = \case Right node -> go node where go node = do - opts <- asks $ teOptions . fst + env <- asks fst let pname = ProcName tname - tool = fromMaybe (optDefaultTool opts) (lookup pname $ optProcTools opts) + tool = fromMaybe (teDefaultTool env) (lookup pname $ teProcTools env) cmd = T.unwords $ T.pack tool : map escape args escape = ("'" <>) . (<> "'") . T.replace "'" "'\\''" outProcName OutputChildExec pname cmd diff --git a/src/Run/Monad.hs b/src/Run/Monad.hs index 8c772d5..d204f09 100644 --- a/src/Run/Monad.hs +++ b/src/Run/Monad.hs @@ -3,6 +3,7 @@ module Run.Monad ( TestEnv(..), TestState(..), TestOptions(..), defaultTestOptions, + ConfigTool(..), Failed(..), finally, @@ -24,6 +25,7 @@ import Data.Scientific import Data.Set (Set) import Data.Text qualified as T +import Config import {-# SOURCE #-} GDB import Network.Ip import Output @@ -43,6 +45,8 @@ data TestEnv = TestEnv { teOutput :: Output , teFailed :: TVar (Maybe Failed) , teOptions :: TestOptions + , teDefaultTool :: FilePath + , teProcTools :: [ ( ProcName, FilePath ) ] , teTestDir :: FilePath , teNextObjId :: MVar Int , teNextProcId :: MVar Int @@ -60,8 +64,8 @@ data TestState = TestState } data TestOptions = TestOptions - { optDefaultTool :: String - , optProcTools :: [(ProcName, String)] + { optDefaultTool :: ConfigTool + , optProcTools :: [ ( ProcName, ConfigTool ) ] , optTestDir :: FilePath , optTimeout :: Scientific , optTcpdump :: Maybe FilePath @@ -76,7 +80,7 @@ data TestOptions = TestOptions defaultTestOptions :: TestOptions defaultTestOptions = TestOptions - { optDefaultTool = "" + { optDefaultTool = ToolPath "" , optProcTools = [] , optTestDir = ".test" , optTimeout = 1 diff --git a/src/TestMode.hs b/src/TestMode.hs index 2ccf5a4..22481f4 100644 --- a/src/TestMode.hs +++ b/src/TestMode.hs @@ -84,7 +84,7 @@ runTestsC tests = do Just LoadedModules {..} <- gets tmsModules mbconfig <- asks tmiConfig let opts = defaultTestOptions - { optDefaultTool = fromMaybe "/bin/true" $ configTool =<< mbconfig + { optDefaultTool = fromMaybe (ToolPath "/bin/true") $ configTool =<< mbconfig , optTestDir = ".test" <> show num , optKeep = True , optKeepGoing = True -- cgit v1.2.3