fuzz tester: avoid deleting entire repository (had to happen eventually, right?)

This commit is contained in:
Joey Hess 2013-05-25 18:15:34 -04:00
parent 377bc7bbb7
commit 33fe3dac9e

View file

@ -211,31 +211,37 @@ genFuzzAction = do
existingFile :: Int -> FilePath -> IO (Maybe FuzzFile) existingFile :: Int -> FilePath -> IO (Maybe FuzzFile)
existingFile 0 _ = return Nothing existingFile 0 _ = return Nothing
existingFile n top = maybe (return Nothing) (go . toFilePath) =<< existingDir existingFile n top = do
where dir <- existingDirIncludingTop
go dir = do contents <- catchDefaultIO [] (getDirectoryContents dir)
contents <- catchDefaultIO [] (getDirectoryContents dir) let files = filter isFuzzFile contents
let files = filter isFuzzFile contents if null files
if null files then do
then do let dirs = filter isFuzzDir contents
let dirs = filter isFuzzDir contents if null dirs
if null dirs then return Nothing
then return Nothing else do
else do i <- getStdRandom $ randomR (0, length dirs - 1)
i <- getStdRandom $ randomR (0, length dirs - 1) existingFile (n - 1) (top </> dirs !! i)
existingFile (n - 1) (top </> dirs !! i) else do
else do i <- getStdRandom $ randomR (0, length files - 1)
i <- getStdRandom $ randomR (0, length files - 1) return $ Just $ FuzzFile $ top </> dir </> files !! i
return $ Just $ FuzzFile $ top </> dir </> files !! i
existingDirIncludingTop :: IO FilePath
existingDir :: IO (Maybe FuzzDir) existingDirIncludingTop = do
existingDir = do
dirs <- filter isFuzzDir <$> getDirectoryContents "." dirs <- filter isFuzzDir <$> getDirectoryContents "."
if null dirs if null dirs
then return Nothing then return "."
else do else do
n <- getStdRandom $ randomR (0, length dirs) n <- getStdRandom $ randomR (0, length dirs)
return $ Just $ FuzzDir $ ("." : dirs) !! n return $ ("." : dirs) !! n
existingDir :: IO (Maybe FuzzDir)
existingDir = do
d <- existingDirIncludingTop
return $ if isFuzzDir d
then Just $ FuzzDir d
else Nothing
newFile :: IO (Maybe FuzzFile) newFile :: IO (Maybe FuzzFile)
newFile = go (100 :: Int) newFile = go (100 :: Int)