Skip to content

Commit

Permalink
Fix Lazy IO opening too many files in integration tests (#1917)
Browse files Browse the repository at this point in the history
When running on macOS, the integration tests open too many file handles,
even when you do not need to run any swarm file tests.
```sh
> cabal run -O0 swarm-integration -- -p editors
swarm-integration: data/scenarios/Challenges/_bucket-brigade/hauler.sw: openFile: resource exhausted (Too many open files)
```
The solution is to get the file paths only and safely open them as needed.
Surprisingly, this even makes the integration test code simpler.

* discovered while fixing failing tests in #1895
  • Loading branch information
xsebek authored Jun 9, 2024
1 parent a51f059 commit cbaf54d
Show file tree
Hide file tree
Showing 2 changed files with 29 additions and 22 deletions.
20 changes: 14 additions & 6 deletions src/swarm-util/Swarm/Util.hs
Original file line number Diff line number Diff line change
Expand Up @@ -36,6 +36,7 @@ module Swarm.Util (
-- * Directory utilities
readFileMay,
readFileMayT,
findAllWithExt,
acquireAllWithExt,

-- * Text utilities
Expand Down Expand Up @@ -310,19 +311,26 @@ readFileMayT :: FilePath -> IO (Maybe Text)
readFileMayT = catchIO . T.readFile

-- | Recursively acquire all files in the given directory with the
-- given extension, and their contents.
acquireAllWithExt :: FilePath -> String -> IO [(FilePath, String)]
acquireAllWithExt dir ext = do
-- given extension, but does not read or open the file like 'acquireAllWithExt'.
findAllWithExt :: FilePath -> String -> IO [FilePath]
findAllWithExt dir ext = do
paths <- listDirectory dir <&> map (dir </>)
filePaths <- filterM (\path -> doesFileExist path <&> (&&) (hasExt path)) paths
children <- mapM (\path -> (,) path <$> readFile path) filePaths
-- recurse
sub <- filterM doesDirectoryExist paths
transChildren <- concat <$> mapM (`acquireAllWithExt` ext) sub
return $ children <> transChildren
transChildren <- concat <$> mapM (`findAllWithExt` ext) sub
return $ filePaths <> transChildren
where
hasExt path = takeExtension path == ("." ++ ext)

-- | Recursively acquire all files in the given directory with the
-- given extension, and their contents.
acquireAllWithExt :: FilePath -> String -> IO [(FilePath, String)]
acquireAllWithExt dir ext = findAllWithExt dir ext >>= mapM addContent
where
addContent :: FilePath -> IO (FilePath, String)
addContent path = (,) path <$> readFile path

-- | Turns any IO error into Nothing.
catchIO :: IO a -> IO (Maybe a)
catchIO act = (Just <$> act) `catchIOError` (\_ -> return Nothing)
Expand Down
31 changes: 15 additions & 16 deletions test/integration/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -78,7 +78,7 @@ import Swarm.TUI.Model (
)
import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState)
import Swarm.TUI.Model.UI (UIState)
import Swarm.Util (acquireAllWithExt)
import Swarm.Util (findAllWithExt)
import Swarm.Util.RingBuffer qualified as RB
import Swarm.Util.Yaml (decodeFileEitherE)
import System.FilePath.Posix (splitDirectories)
Expand All @@ -87,15 +87,15 @@ import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase)
import Witch (into)

isUnparseableTest :: (FilePath, String) -> Bool
isUnparseableTest (fp, _) = "_Validation" `elem` splitDirectories fp
isUnparseableTest :: FilePath -> Bool
isUnparseableTest fp = "_Validation" `elem` splitDirectories fp

main :: IO ()
main = do
examplePaths <- acquireAllWithExt "example" "sw"
scenarioPaths <- acquireAllWithExt "data/scenarios" "yaml"
examplePaths <- findAllWithExt "example" "sw"
scenarioPaths <- findAllWithExt "data/scenarios" "yaml"
let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths
scenarioPrograms <- acquireAllWithExt "data/scenarios" "sw"
scenarioPrograms <- findAllWithExt "data/scenarios" "sw"
(rs, ui) <- do
out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts
either (assertFailure . prettyString) return out
Expand Down Expand Up @@ -127,32 +127,31 @@ checkNoRuntimeErrors r =
isError :: LogEntry -> Bool
isError = (>= Warning) . view leSeverity

exampleTests :: [(FilePath, String)] -> TestTree
exampleTests :: [FilePath] -> TestTree
exampleTests inputs = testGroup "Test example" (map exampleTest inputs)

exampleTest :: (FilePath, String) -> TestTree
exampleTest (path, fileContent) =
exampleTest :: FilePath -> TestTree
exampleTest path =
testCase ("processTerm for contents of " ++ show path) $ do
either (assertFailure . into @String) (const . return $ ()) value
where
value = processTerm $ into @Text fileContent
value <- processTerm <$> T.readFile path
either (assertFailure . into @String) (\_ -> return ()) value

scenarioParseTests :: ScenarioInputs -> [(FilePath, String)] -> TestTree
scenarioParseTests :: ScenarioInputs -> [FilePath] -> TestTree
scenarioParseTests scenarioInputs inputs =
testGroup
"Test scenarios parse"
(map (scenarioTest Parsed scenarioInputs) inputs)

scenarioParseInvalidTests :: ScenarioInputs -> [(FilePath, String)] -> TestTree
scenarioParseInvalidTests :: ScenarioInputs -> [FilePath] -> TestTree
scenarioParseInvalidTests scenarioInputs inputs =
testGroup
"Test invalid scenarios fail to parse"
(map (scenarioTest Failed scenarioInputs) inputs)

data ParseResult = Parsed | Failed

scenarioTest :: ParseResult -> ScenarioInputs -> (FilePath, String) -> TestTree
scenarioTest expRes scenarioInputs (path, _) =
scenarioTest :: ParseResult -> ScenarioInputs -> FilePath -> TestTree
scenarioTest expRes scenarioInputs path =
testCase ("parse scenario " ++ show path) (getScenario expRes scenarioInputs path)

getScenario :: ParseResult -> ScenarioInputs -> FilePath -> IO ()
Expand Down

0 comments on commit cbaf54d

Please sign in to comment.