Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs

   1 {-# LANGUAGE LambdaCase #-}
   2 module UnitTests.Distribution.Simple.Glob
   3     ( tests
   4     ) where
   5
   6 import Control.Monad
   7 import Data.Foldable (for_)
   8 import Data.Function (on)
   9 import Data.List (sort)
  10 import Data.Maybe (mapMaybe)
  11 import Distribution.Simple.Glob
  12 import qualified Distribution.Verbosity as Verbosity
  13 import Distribution.CabalSpecVersion
  14 import System.Directory (createDirectoryIfMissing)
  15 import System.FilePath ((</>), splitFileName, normalise)
  16 import System.IO.Temp (withSystemTempDirectory)
  17 import Test.Tasty
  18 import Test.Tasty.HUnit
  19
  20 sampleFileNames :: [FilePath]
  21 sampleFileNames =
  22   [ "a"
  23   , "a.html"
  24   , "b.html"
  25   , "b.html.gz"
  26   , "foo/.blah.html"
  27   , "foo/.html"
  28   , "foo/a"
  29   , "foo/a.html"
  30   , "foo/a.html.gz"
  31   , "foo/a.tex"
  32   , "foo/a.tex.gz"
  33   , "foo/b.html"
  34   , "foo/b.html.gz"
  35   , "foo/x.gz"
  36   , "foo/bar/.html"
  37   , "foo/bar/a.html"
  38   , "foo/bar/a.html.gz"
  39   , "foo/bar/a.tex"
  40   , "foo/bar/a.tex.gz"
  41   , "foo/bar/b.html"
  42   , "foo/bar/b.html.gz"
  43   , "foo/c.html/blah"
  44   , "xyz/foo/a.html"
  45   ]
  46
  47 makeSampleFiles :: FilePath -> IO ()
  48 makeSampleFiles dir = for_ sampleFileNames $ \filename -> do
  49   let (dir', name) = splitFileName filename
  50   createDirectoryIfMissing True (dir </> dir')
  51   writeFile (dir </> dir' </> name) $ "This is " ++ filename
  52
  53 compatibilityTests :: CabalSpecVersion -> [TestTree]
  54 compatibilityTests version =
  55   [ testCase "literal match" $
  56       testMatches "foo/a" [GlobMatch "foo/a"]
  57   , testCase "literal no match on prefix" $
  58       testMatches "foo/c.html" [GlobMatchesDirectory "foo/c.html"]
  59   , testCase "literal no match on suffix" $
  60       testMatches "foo/a.html" [GlobMatch "foo/a.html"]
  61   , testCase "literal no prefix" $
  62       testMatches "a" [GlobMatch "a"]
  63   , testCase "literal multiple prefix" $
  64       testMatches "foo/bar/a.html" [GlobMatch "foo/bar/a.html"]
  65   , testCase "glob" $
  66       testMatches "*.html" [GlobMatch "a.html", GlobMatch "b.html"]
  67   , testCase "glob in subdir" $
  68       testMatches "foo/*.html" [GlobMatchesDirectory "foo/c.html", GlobMatch "foo/b.html", GlobMatch "foo/a.html"]
  69   , testCase "glob multiple extensions" $
  70       testMatches "foo/*.html.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/b.html.gz"]
  71   , testCase "glob in deep subdir" $
  72       testMatches "foo/bar/*.tex" [GlobMatch "foo/bar/a.tex"]
  73   , testCase "star in directory" $
  74       testFailParse "blah/*/foo" StarInDirectory
  75   , testCase "star plus text in segment" $
  76       testFailParse "xyz*/foo" StarInDirectory
  77   , testCase "star in filename plus text" $
  78       testFailParse "foo*.bar" StarInFileName
  79   , testCase "no extension on star" $
  80       testFailParse "foo/*" NoExtensionOnStar
  81   , testCase "star in extension" $
  82       testFailParse "foo.*.gz" StarInExtension
  83   ]
  84   where
  85     testMatches = testMatchesVersion version
  86     testFailParse = testFailParseVersion version
  87
  88 -- For efficiency reasons, matchDirFileGlob isn't a simple call to
  89 -- getDirectoryContentsRecursive and then a filter with
  90 -- fileGlobMatches. So test both that naive approach and the actual
  91 -- approach to make sure they are both correct.
  92 --
  93 -- TODO: Work out how to construct the sample tree once for all tests,
  94 -- rather than once for each test.
  95 testMatchesVersion :: CabalSpecVersion -> FilePath -> [GlobResult FilePath] -> Assertion
  96 testMatchesVersion version pat expected = do
  97   globPat <- case parseFileGlob version pat of
  98     Left _ -> assertFailure "Couldn't compile the pattern."
  99     Right globPat -> return globPat
 100   checkPure globPat
 101   checkIO globPat
 102   where
 103     isEqual = (==) `on` (sort . fmap (fmap normalise))
 104     checkPure globPat = do
 105       let actual = mapMaybe (\p -> (p <$) <$> fileGlobMatches version globPat p) sampleFileNames
 106           -- We drop directory matches from the expected results since the pure
 107           -- check can't identify that kind of match.
 108           expected' = filter (\case GlobMatchesDirectory _ -> False; _ -> True) expected
 109       unless (sort expected' == sort actual) $
 110         assertFailure $ "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
 111     checkIO globPat =
 112       withSystemTempDirectory "globstar-sample" $ \tmpdir -> do
 113         makeSampleFiles tmpdir
 114         actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat
 115         unless (isEqual actual expected) $
 116           assertFailure $ "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected
 117
 118 testFailParseVersion :: CabalSpecVersion -> FilePath -> GlobSyntaxError -> Assertion
 119 testFailParseVersion version pat expected =
 120   case parseFileGlob version pat of
 121     Left err -> unless (expected == err) $
 122       assertFailure $ "Unexpected error: " ++ show err
 123     Right _ -> assertFailure "Unexpected success in parsing."
 124
 125 globstarTests :: [TestTree]
 126 globstarTests =
 127   [ testCase "fails to parse on early spec version" $
 128       testFailParseVersion CabalSpecV2_2 "**/*.html" VersionDoesNotSupportGlobStar
 129   , testCase "out-of-place double star" $
 130       testFailParse "blah/**/blah/*.foo" StarInDirectory
 131   , testCase "multiple double star" $
 132       testFailParse "blah/**/**/*.foo" StarInDirectory
 133   , testCase "fails with literal filename" $
 134       testFailParse "**/a.html" LiteralFileNameGlobStar
 135   , testCase "with glob filename" $
 136       testMatches "**/*.html" [GlobMatch "a.html", GlobMatch "b.html", GlobMatch "foo/a.html", GlobMatch "foo/b.html", GlobMatch "foo/bar/a.html", GlobMatch "foo/bar/b.html", GlobMatch "xyz/foo/a.html"]
 137   , testCase "glob with prefix" $
 138       testMatches "foo/**/*.html" [GlobMatch "foo/a.html", GlobMatch "foo/b.html", GlobMatch "foo/bar/a.html", GlobMatch "foo/bar/b.html"]
 139   ]
 140   where
 141     testFailParse = testFailParseVersion CabalSpecV2_4
 142     testMatches = testMatchesVersion CabalSpecV2_4
 143
 144 multiDotTests :: [TestTree]
 145 multiDotTests =
 146   [ testCase "pre-2.4 single extension not matching multiple" $
 147       testMatchesVersion CabalSpecV2_2 "foo/*.gz" [GlobWarnMultiDot "foo/a.html.gz", GlobWarnMultiDot "foo/a.tex.gz", GlobWarnMultiDot "foo/b.html.gz", GlobMatch "foo/x.gz"]
 148   , testCase "doesn't match literal" $
 149       testMatches "foo/a.tex" [GlobMatch "foo/a.tex"]
 150   , testCase "works" $
 151       testMatches "foo/*.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/a.tex.gz", GlobMatch "foo/b.html.gz", GlobMatch "foo/x.gz"]
 152   , testCase "works with globstar" $
 153       testMatches "foo/**/*.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/a.tex.gz", GlobMatch "foo/b.html.gz", GlobMatch "foo/x.gz", GlobMatch "foo/bar/a.html.gz", GlobMatch "foo/bar/a.tex.gz", GlobMatch "foo/bar/b.html.gz"]
 154   ]
 155   where
 156     testMatches = testMatchesVersion CabalSpecV2_4
 157
 158 tests :: [TestTree]
 159 tests =
 160   [ testGroup "pre-2.4 compatibility" $
 161       compatibilityTests CabalSpecV2_2
 162   , testGroup "post-2.4 compatibility" $
 163       compatibilityTests CabalSpecV2_4
 164   , testGroup "globstar" globstarTests
 165   , testCase "pre-1.6 rejects globbing" $
 166       testFailParseVersion CabalSpecV1_4 "foo/*.bar" VersionDoesNotSupportGlob
 167   , testGroup "multi-dot globbing" multiDotTests
 168   ]