From 033a27e64f341004c77140a8f5aea61f5aee1b1d 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 --- .../Distribution/PackageDescription/Check.hs | 2 ++ Cabal/src/Distribution/Simple/Glob.hs | 31 +++++++++++++++---- 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 ++++++++++++ 12 files changed, 59 insertions(+), 30 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/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..5d6187aa005 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,20 @@ 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 + warn verbosity $ unlines warns + return matches else rip verbosity $ MatchDirFileGlobErrors errors -- | Match files against a pre-parsed glob, starting in a directory. @@ -523,11 +536,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 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