{-# Language QuasiQuotes #-}
import Control.Monad.IO.Class
import Coquina
import Data.Maybe
import Data.String.Here
import Data.Text (Text)
import System.Directory
import System.Directory.Contents
import System.Directory.Contents.Zipper
import System.Exit
import System.FilePath
import System.Process
main :: IO ()
main = do
_ <- setup test1
return ()
readme_md = [here|
This test directory tree has the following structure:
```
.
├── a -> A/a
├── A
│ ├── a
│ ├── A -> ../A [recursive, not followed]
│ └── B -> ../B
│ ├── A -> ../A [recursive, not followed]
│ └── b
├── B
│ ├── A -> ../A [recursive, not followed]
│ └── b
└── README.md
6 directories, 5 files
```
|]
-- | Annoying that we have to set it up this way, but there doesn't seem
-- to be any good way to include the symlinks we want as test fixtures
-- in cabal.
--
-- This function will manually recreate the contents of test/fixtures
setup :: (FilePath -> IO ()) -> IO (Text, Text, Either Int ())
setup testRunner = runShell $ do
inTempDirectory "directory-contents-test" $ \fp -> do
let fixtures = fp </> "test" </> "fixtures"
test1 = fixtures </> "test-1"
test2 = fixtures </> "test-2"
run $ proc "mkdir" ["-p", fixtures]
run $ proc "mkdir" ["-p", test1]
run $ proc "mkdir" ["-p", test2]
liftIO $ do
writeFile (fixtures </> "test-1" </> "README.md") readme_md
writeFile (fixtures </> "test-2" </> "rocket") "🚀"
run $ proc "mkdir" ["-p", test1 </> "A"]
run $ proc "touch" [test1 </> "A" </> "a"]
run $ proc "mkdir" ["-p", test1 </> "B"]
run $ proc "touch" [test1 </> "B" </> "b"]
run $ proc "mkdir" ["-p", test1 </> "C"]
run $ proc "ln" ["-s", "../A", test1 </> "A" </> "A"]
run $ proc "ln" ["-s", "../B", test1 </> "A" </> "B"]
run $ proc "ln" ["-s", "../A", test1 </> "B" </> "A"]
run $ proc "ln" ["-s", "../README.md", test1 </> "C" </> "info.md"]
run $ proc "ln" ["-s", "../test-2", test1 </> "D"]
run $ proc "ln" ["-s", "D/rocket", test1 </> "d_rocket"]
run $ proc "ln" ["-s", "../test-2/rocket", test1 </> "rocket"]
liftIO $ testRunner test1
test1 :: FilePath -> IO ()
test1 fp = do
p <- test
"Build DirTree in the presence of recursive symlinks"
(buildDirTree fp)
test
"Navigate to a directory that should exist"
(pure $ walkContents "C" p)
filtered <- test "Filter contents based on a predicate" $
pure (filterDirTree ((/="README.md") . takeFileName) p)
test "Check that filtering didn't prune directories" $
pure $ walkContents "C" p
test "Check that pruneDirTree does prune empty directories" $
pure $ expectNothing $ walkContents "C" =<< pruneDirTree filtered
rocket <- test "Check that symlink can be traversed" $
pure (walkContents "D/rocket" filtered)
test "Check that filtering removes internal symlinks to filtered files" $
pure $ expectNothing $
walkContents "C/info.md" filtered
let filterRockets = filterDirTree ((/="rocket") . takeFileName)
test "Check that filtering removes external symlinks to filtered files" $
pure $ expectNothing $
walkContents "d_rocket" =<< filterRockets p
test "Check that dereferenced symlinks to filtered files are not removed" $ do
deref <- dereferenceSymlinks p
pure $ walkContents "d_rocket" =<< filterRockets deref
test "Zipper down then up from root == id" $
pure $ expectTrue $ fmap focused (up =<< down (zipped p)) == Just p
test "Use zipper to remove a node" $ do
let a = up =<< remove =<< downTo "info.md" =<< downTo "C" (zipped p)
pure $ expectNothing $ walkContents "C/info.md" . focused =<< a
readFile (filePath rocket) >>=
putStr >> putStrLn " All systems go!"
test :: String -> IO (Maybe a) -> IO a
test describe run = do
putStr describe
putStr " ... "
result <- run
case result of
Nothing -> putStrLn "FAILED" >> exitWith (ExitFailure 1)
Just r -> putStrLn "passed" >> return r
expectNothing :: Maybe a -> Maybe ()
expectNothing x = case x of
Nothing -> Just ()
Just _ -> Nothing
expectTrue :: Bool -> Maybe ()
expectTrue x = if x then Just () else Nothing