From a749fea5167c0eb6b346d1f9e4ade6a134f140b6 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Tue, 30 Jan 2024 18:57:41 +0000 Subject: [PATCH] Make sure sdist is robust to accidentally-listed directories The refactor of the globbing modules re-uncovered this issue, and required a prompt fix for the refactor not to break some things. Fixes #5349 --- .../UnitTests/Distribution/Simple/Glob.hs | 4 +- Cabal/src/Distribution/Simple/Glob.hs | 74 ++++++++++++------- Cabal/src/Distribution/Simple/SrcDist.hs | 29 ++++++-- .../PackageTests/SDist/T5195/cabal.out | 3 - .../PackageTests/SDist/T5195/cabal.test.hs | 5 -- .../PackageTests/SDist/T5195/t5195.cabal | 10 --- .../SDist/{T5195 => T5195and5349}/Main.hs | 0 .../actually-a-directory/some-file | 0 .../SDist/T5195and5349/actually-a-file | 1 + .../{T5195 => T5195and5349}/cabal.project | 0 .../SDist/T5195and5349/cabal.test.hs | 5 ++ .../SDist/T5195and5349/t5195and5349.cabal | 19 +++++ 12 files changed, 96 insertions(+), 54 deletions(-) delete mode 100644 cabal-testsuite/PackageTests/SDist/T5195/cabal.out delete mode 100644 cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs delete mode 100644 cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal rename cabal-testsuite/PackageTests/SDist/{T5195 => T5195and5349}/Main.hs (100%) rename cabal-testsuite/PackageTests/SDist/{T5195 => T5195and5349}/actually-a-directory/some-file (100%) create mode 100644 cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file rename cabal-testsuite/PackageTests/SDist/{T5195 => T5195and5349}/cabal.project (100%) create mode 100644 cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs index d6a18de37d4..4efe4b79437 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs @@ -101,13 +101,13 @@ testMatchesVersion version pat expected = do where isEqual = (==) `on` (sort . fmap (fmap normalise)) checkPure globPat = do - let actual = mapMaybe (matchGlob globPat) ({- splitDirectories -} sampleFileNames) + let actual = mapMaybe (\p -> (p <$) <$> fileGlobMatches version globPat p) sampleFileNames unless (sort expected == sort actual) $ assertFailure $ "Unexpected result (pure matcher): " ++ show actual checkIO globPat = withSystemTempDirectory "globstar-sample" $ \tmpdir -> do makeSampleFiles tmpdir - actual <- runDirFileGlob Verbosity.normal tmpdir globPat + actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat unless (isEqual actual expected) $ assertFailure $ "Unexpected result (impure matcher): " ++ show actual diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 67b3ca71d7f..3d56dab2c33 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -509,7 +509,7 @@ runDirFileGlob verbosity mspec rawRoot pat = do -- The glob matching function depends on whether we care about the cabal version or not doesGlobMatch :: Glob -> String -> Maybe (GlobResult ()) doesGlobMatch glob str = case mspec of - Just spec -> checkName spec glob str + Just spec -> checkNameMatches spec glob str Nothing -> if matchGlob glob str then Just (GlobMatch ()) else Nothing go (GlobFile glob) dir = do @@ -532,38 +532,11 @@ runDirFileGlob verbosity mspec rawRoot pat = do concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs go GlobDirTrailing dir = return [GlobMatch dir] - checkName spec glob candidate - -- Check if glob matches in its general form - | matchGlob glob candidate = - -- if multidot is supported, then this is a clean match - if enableMultidot spec - then pure (GlobMatch ()) - else -- if not, issue a warning if multidot is needed for the match - - let (_, candidateExts) = splitExtensions $ takeFileName candidate - in case extractExts glob of - Just exts - | exts == candidateExts -> - return (GlobMatch ()) - | exts `isSuffixOf` candidateExts -> - return (GlobWarnMultiDot ()) - _ -> return (GlobMatch ()) - | otherwise = empty - directoryExists <- doesDirectoryExist (root joinedPrefix) if directoryExists then go variablePattern joinedPrefix else return [GlobMissingDirectory joinedPrefix] where - extractExts :: Glob -> Maybe String - extractExts [] = Nothing - extractExts [Literal lit] - -- Any literal terminating a glob, and which does have an extension, - -- returns that extension. Otherwise, recurse until Nothing is returned. - | let ext = takeExtension lit - , ext /= "" = - Just (takeExtension ext) - extractExts (_ : x) = extractExts x -- \| Extract the (possibly null) constant prefix from the pattern. -- This has the property that, if @(pref, final) = splitConstantPrefix pat@, @@ -584,3 +557,48 @@ runDirFileGlob verbosity mspec rawRoot pat = do isRecursiveInRoot :: FilePathGlobRel -> Bool isRecursiveInRoot (GlobDirRecursive _) = True isRecursiveInRoot _ = False + + +-- | Check how the string matches the glob under this cabal version +checkNameMatches :: CabalSpecVersion -> Glob -> String -> Maybe (GlobResult ()) +checkNameMatches spec glob candidate + -- Check if glob matches in its general form + | matchGlob glob candidate = + -- if multidot is supported, then this is a clean match + if enableMultidot spec + then pure (GlobMatch ()) + else -- if not, issue a warning if multidot is needed for the match + let (_, candidateExts) = splitExtensions $ takeFileName candidate + extractExts :: Glob -> Maybe String + extractExts [] = Nothing + extractExts [Literal lit] + -- Any literal terminating a glob, and which does have an extension, + -- returns that extension. Otherwise, recurse until Nothing is returned. + | let ext = takeExtension lit + , ext /= "" = + Just (takeExtension ext) + extractExts (_ : x) = extractExts x + in case extractExts glob of + Just exts + | exts == candidateExts -> + return (GlobMatch ()) + | exts `isSuffixOf` candidateExts -> + return (GlobWarnMultiDot ()) + _ -> return (GlobMatch ()) + | otherwise = empty + + +-- | Does the glob match the given filepath? +fileGlobMatches :: CabalSpecVersion -> FilePathGlobRel -> FilePath -> Maybe (GlobResult ()) +fileGlobMatches version g path = go g (splitDirectories path) where + go GlobDirTrailing [] = Just (GlobMatch ()) + go (GlobFile glob) [file] = checkNameMatches version glob file + go (GlobDirRecursive glob) dirs + | [] <- reverse dirs + = Nothing -- @dir/**/x.txt@ should not match @dir/hello@ + | file:_ <- reverse dirs + = checkNameMatches version glob file + go (GlobDir glob globPath) (dir:dirs) = do + _ <- checkNameMatches version glob dir -- we only care if dir segment matches + go globPath dirs + go _ _ = Nothing diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs index cbb4dc44c11..0a0d880ac94 100644 --- a/Cabal/src/Distribution/Simple/SrcDist.hs +++ b/Cabal/src/Distribution/Simple/SrcDist.hs @@ -245,20 +245,24 @@ listPackageSources' verbosity rip cwd pkg_descr pps = , -- Data files. fmap concat . for (dataFiles pkg_descr) - $ \filename -> do - let srcDataDirRaw = dataDir pkg_descr - srcDataDir - | null srcDataDirRaw = "." - | otherwise = srcDataDirRaw - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir filename) + $ \filename -> + do + let srcDataDirRaw = dataDir pkg_descr + srcDataDir + | null srcDataDirRaw = "." + | otherwise = srcDataDirRaw + matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir filename) + >>= filterOutDirectories "data-files" , -- Extra source files. fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath + >>= filterOutDirectories "extra-source-files" , -- Extra doc files. fmap concat . for (extraDocFiles pkg_descr) $ \filename -> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename + >>= filterOutDirectories "extra-doc-files" , -- License file(s). return (map getSymbolicPath $ licenseFiles pkg_descr) , -- Install-include files, without autogen-include files @@ -283,6 +287,19 @@ listPackageSources' verbosity rip cwd pkg_descr pps = withAllTest action = traverse action (testSuites pkg_descr) withAllBenchmark action = traverse action (benchmarks pkg_descr) + -- For data-files, extra-source-files, and extra-doc-files, we filter out + -- directories since the function must only return paths to files. This + -- filtering is necessary because globs may match directories. + filterOutDirectories loc matches = flip filterM matches $ \path -> do + isFile <- doesFileExist path + -- Must be a directory, since it is a path that matched the glob and + -- isn't a file. + if isFile + then return True + else do + warn verbosity $ "Ignoring directory '" ++ path ++ "'" ++ " listed in field '" ++ loc ++ "' in the Cabal package. This field can only include files (not directories)." + return False + -- | Prepare a directory tree of source files. prepareTree :: Verbosity diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.out b/cabal-testsuite/PackageTests/SDist/T5195/cabal.out deleted file mode 100644 index 5b329c9c75b..00000000000 --- a/cabal-testsuite/PackageTests/SDist/T5195/cabal.out +++ /dev/null @@ -1,3 +0,0 @@ -# cabal v2-sdist -Error: [Cabal-6661] -filepath wildcard './actually-a-directory' does not match any files. \ No newline at end of file diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs b/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs deleted file mode 100644 index c0ff953560b..00000000000 --- a/cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Test.Cabal.Prelude -main = cabalTest $ do - tmpdir <- fmap testTmpDir getTestEnv - res <- fails $ cabal' "v2-sdist" ["--list-only", "--output-directory", tmpdir] - assertOutputContains "filepath wildcard './actually-a-directory' does not match any files" res diff --git a/cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal b/cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal deleted file mode 100644 index 5d9a759dd71..00000000000 --- a/cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal +++ /dev/null @@ -1,10 +0,0 @@ -cabal-version: 2.2 -name: t5195 -version: 0 - -extra-source-files: - ./actually-a-directory - -executable foo - default-language: Haskell2010 - main-is: Main.hs diff --git a/cabal-testsuite/PackageTests/SDist/T5195/Main.hs b/cabal-testsuite/PackageTests/SDist/T5195and5349/Main.hs similarity index 100% rename from cabal-testsuite/PackageTests/SDist/T5195/Main.hs rename to cabal-testsuite/PackageTests/SDist/T5195and5349/Main.hs diff --git a/cabal-testsuite/PackageTests/SDist/T5195/actually-a-directory/some-file b/cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-directory/some-file similarity index 100% rename from cabal-testsuite/PackageTests/SDist/T5195/actually-a-directory/some-file rename to cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-directory/some-file diff --git a/cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file b/cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file new file mode 100644 index 00000000000..b14df6442ea --- /dev/null +++ b/cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file @@ -0,0 +1 @@ +Hi diff --git a/cabal-testsuite/PackageTests/SDist/T5195/cabal.project b/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.project similarity index 100% rename from cabal-testsuite/PackageTests/SDist/T5195/cabal.project rename to cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.project diff --git a/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs b/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs new file mode 100644 index 00000000000..da391fad328 --- /dev/null +++ b/cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude +main = cabalTest $ do + tmpdir <- fmap testTmpDir getTestEnv + cabal' "v2-sdist" ["--list-only", "--output-directory", tmpdir] + return () diff --git a/cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal b/cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal new file mode 100644 index 00000000000..5df90b3562d --- /dev/null +++ b/cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal @@ -0,0 +1,19 @@ +cabal-version: 2.2 +name: t5195and5349 +version: 0 + +extra-source-files: + ./actually-a-directory + ./actually-a-file + +extra-doc-files: + ./actually-a-directory + ./actually-a-file + +data-files: + ./actually-a-directory + ./actually-a-file + +executable foo + default-language: Haskell2010 + main-is: Main.hs