Skip to content

Commit

Permalink
Make sure sdist is robust to accidentally-listed directories
Browse files Browse the repository at this point in the history
The refactor of the globbing modules re-uncovered this issue, and
required a prompt fix for the refactor not to break some things.

Fixes haskell#5349
  • Loading branch information
alt-romes committed Feb 2, 2024
1 parent f1316af commit 25e36bb
Show file tree
Hide file tree
Showing 13 changed files with 60 additions and 31 deletions.
2 changes: 1 addition & 1 deletion Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs
Original file line number Diff line number Diff line change
Expand Up @@ -64,7 +64,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/a.html",GlobMatch "foo/b.html"]
, testCase "glob multiple extensions" $
testMatches "foo/*.html.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/b.html.gz"]
, testCase "glob in deep subdir" $
Expand Down
2 changes: 2 additions & 0 deletions Cabal/src/Distribution/PackageDescription/Check.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
31 changes: 25 additions & 6 deletions Cabal/src/Distribution/Simple/Glob.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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.
Expand Down Expand Up @@ -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 =
Expand All @@ -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.
Expand Down Expand Up @@ -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
Expand Down
13 changes: 7 additions & 6 deletions Cabal/src/Distribution/Simple/SrcDist.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
3 changes: 0 additions & 3 deletions cabal-testsuite/PackageTests/SDist/T5195/cabal.out

This file was deleted.

5 changes: 0 additions & 5 deletions cabal-testsuite/PackageTests/SDist/T5195/cabal.test.hs

This file was deleted.

10 changes: 0 additions & 10 deletions cabal-testsuite/PackageTests/SDist/T5195/t5195.cabal

This file was deleted.

Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
Hi
5 changes: 5 additions & 0 deletions cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
import Test.Cabal.Prelude
main = cabalTest $ do
tmpdir <- fmap testTmpDir getTestEnv
cabal' "v2-sdist" ["--list-only", "--output-directory", tmpdir]
return ()
19 changes: 19 additions & 0 deletions cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal
Original file line number Diff line number Diff line change
@@ -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

0 comments on commit 25e36bb

Please sign in to comment.