From 97a9280ba89ac75746d6f7ba533b534ba9579562 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Wed, 31 Jan 2024 07:57:38 +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 | 10 ++++-- .../Distribution/PackageDescription/Check.hs | 2 ++ Cabal/src/Distribution/Simple/Glob.hs | 34 +++++++++++++++---- Cabal/src/Distribution/Simple/SrcDist.hs | 13 +++---- .../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 +++++++++++ 13 files changed, 69 insertions(+), 33 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 4efe4b79437..dd53ecc0368 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module UnitTests.Distribution.Simple.Glob ( tests ) where @@ -54,7 +55,7 @@ compatibilityTests version = [ testCase "literal match" $ testMatches "foo/a" [GlobMatch "foo/a"] , testCase "literal no match on prefix" $ - testMatches "foo/c.html" [] + testMatches "foo/c.html" [GlobMatchesDirectory "foo/c.html"] , testCase "literal no match on suffix" $ testMatches "foo/a.html" [GlobMatch "foo/a.html"] , testCase "literal no prefix" $ @@ -64,7 +65,7 @@ compatibilityTests version = , testCase "glob" $ testMatches "*.html" [GlobMatch "a.html", GlobMatch "b.html"] , testCase "glob in subdir" $ - testMatches "foo/*.html" [GlobMatch "foo/a.html", GlobMatch "foo/b.html"] + testMatches "foo/*.html" [GlobMatch "foo/b.html",GlobMatchesDirectory "foo/c.html",GlobMatch "foo/a.html"] , testCase "glob multiple extensions" $ testMatches "foo/*.html.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/b.html.gz"] , testCase "glob in deep subdir" $ @@ -102,7 +103,10 @@ testMatchesVersion version pat expected = do isEqual = (==) `on` (sort . fmap (fmap normalise)) checkPure globPat = do let actual = mapMaybe (\p -> (p <$) <$> fileGlobMatches version globPat p) sampleFileNames - unless (sort expected == sort actual) $ + -- We drop directory matches from the expected results since the pure + -- check can't identify that kind of match. + expected' = filter (\case GlobMatchesDirectory _ -> False; _ -> True) expected + unless (sort expected' == sort actual) $ assertFailure $ "Unexpected result (pure matcher): " ++ show actual checkIO globPat = withSystemTempDirectory "globstar-sample" $ \tmpdir -> do diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index fc7a25895e7..2de6f22beec 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -861,6 +861,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) withoutNoMatchesWarning (GlobMatch _) = True withoutNoMatchesWarning (GlobWarnMultiDot _) = False withoutNoMatchesWarning (GlobMissingDirectory _) = True + withoutNoMatchesWarning (GlobMatchesDirectory _) = True getWarning :: GlobResult FilePath -> Maybe PackageCheck getWarning (GlobMatch _) = Nothing @@ -872,6 +873,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs) Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file) getWarning (GlobMissingDirectory dir) = Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir) + getWarning (GlobMatchesDirectory _) = Nothing -- is handled elsewhere if relevant, it is not necessarily a problem -- ------------------------------------------------------------ -- Other exports diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 1a6c0594575..03bfaa9bd13 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -148,6 +148,7 @@ matchFileGlobRel root glob = ( \case GlobMatch a -> Just a GlobWarnMultiDot a -> Just a + GlobMatchesDirectory a -> Just a GlobMissingDirectory{} -> Nothing ) <$> runDirFileGlob silent Nothing root glob @@ -414,6 +415,8 @@ data GlobResult a -- relative to the directory passed to 'matchDirFileGlob', and, -- for 'data-files', relative to 'data-dir'). GlobMissingDirectory FilePath + | -- | The glob matched a directory when we were looking for files only. It didn't match a file! + GlobMatchesDirectory FilePath deriving (Show, Eq, Ord, Functor) -- | Extract the matches from a list of 'GlobResult's. @@ -450,6 +453,7 @@ matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob let missingDirectories = [missingDir | GlobMissingDirectory missingDir <- results] matches = globMatches results + directoryMatches = [a | GlobMatchesDirectory a <- results] let errors :: [String] errors = @@ -462,11 +466,21 @@ matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob | missingDir <- missingDirectories ] ++ [ "filepath wildcard '" ++ filepath ++ "' does not match any files." - | null matches + | null matches && null directoryMatches + -- we don't error out on directory matches, simply warn about them and ignore. ] + warns :: [String] + warns = + [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)." + | path <- directoryMatches + ] + if null errors - then return matches + then do + unless (null warns) $ + warn verbosity $ unlines warns + return matches else rip verbosity $ MatchDirFileGlobErrors errors -- | Match files against a pre-parsed glob, starting in a directory. @@ -523,11 +537,17 @@ runDirFileGlob verbosity mspec rawRoot pat = do -- when a cabal spec version is passed as an argument), we -- disallow matching a @GlobFile@ against a directory, preferring -- @GlobDir dir GlobDirTrailing@ to specify a directory match. - shouldMatch <- maybe (return True) (const $ doesFileExist (root dir s)) mspec + isFile <- maybe (return True) (const $ doesFileExist (root dir s)) mspec + let match = (dir s <$) <$> doesGlobMatch glob s return $ - if shouldMatch - then (dir s <$) <$> doesGlobMatch glob s - else Nothing + if isFile + then match + else case match of + Just (GlobMatch x) -> Just $ GlobMatchesDirectory x + Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x + Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x + Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess + Nothing -> Nothing ) entries go (GlobDirRecursive glob) dir = do @@ -601,6 +621,8 @@ checkNameMatches spec glob candidate | otherwise = empty -- | How/does the glob match the given filepath, according to the cabal version? +-- Since this is pure, we don't make a distinction between matching on +-- directories or files (i.e. this function won't return 'GlobMatchesDirectory') fileGlobMatches :: CabalSpecVersion -> FilePathGlobRel -> FilePath -> Maybe (GlobResult ()) fileGlobMatches version g path = go g (splitDirectories path) where diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs index cbb4dc44c11..b186508e20f 100644 --- a/Cabal/src/Distribution/Simple/SrcDist.hs +++ b/Cabal/src/Distribution/Simple/SrcDist.hs @@ -245,12 +245,13 @@ 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) , -- Extra source files. fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath 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