Commit dcc157c6 authored by quasicomputational's avatar quasicomputational Committed by Alexis Williams

Ensure cabal check doesn't error out early on invalid globs

This has been a problem since #5372 began expanding globs in `cabal
check`. Now the logic of running a glob is separated from the parsing,
giving the caller the opportunity to handle parsing failures flexibly.
parent 7d39aa01
......@@ -2168,16 +2168,20 @@ checkGlobFiles :: Verbosity
-> FilePath
-> NoCallStackIO [PackageCheck]
checkGlobFiles verbosity pkg root =
fmap concat $ for allGlobs $ \(field, dir, glob) -> do
results <- matchDirFileGlob' verbosity (specVersion pkg) (root </> dir) glob
let individualWarnings = results >>= getWarning field glob
noMatchesWarning =
[ PackageDistSuspiciousWarn $
"In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"
++ " match any files."
| all (not . suppressesNoMatchesWarning) results
]
return (noMatchesWarning ++ individualWarnings)
fmap concat $ for allGlobs $ \(field, dir, glob) ->
-- Note: we just skip over parse errors here; they're reported elsewhere.
case parseFileGlob (specVersion pkg) glob of
Left _ -> return []
Right parsedGlob -> do
results <- runDirFileGlob verbosity (root </> dir) parsedGlob
let individualWarnings = results >>= getWarning field glob
noMatchesWarning =
[ PackageDistSuspiciousWarn $
"In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"
++ " match any files."
| all (not . suppressesNoMatchesWarning) results
]
return (noMatchesWarning ++ individualWarnings)
where
adjustedDataDir = if null (dataDir pkg) then "." else dataDir pkg
allGlobs = concat
......
......@@ -18,7 +18,7 @@ module Distribution.Simple.Glob (
GlobSyntaxError(..),
GlobResult(..),
matchDirFileGlob,
matchDirFileGlob',
runDirFileGlob,
fileGlobMatches,
parseFileGlob,
explainGlobSyntaxError,
......@@ -35,7 +35,7 @@ import Distribution.Verbosity
import Distribution.Version
import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)
import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>))
import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>), (<.>))
-- Note throughout that we use splitDirectories, not splitPath. On
-- Posix, this makes no difference, but, because Windows accepts both
......@@ -127,6 +127,14 @@ data GlobFinal
| FinalLit FilePath
-- ^ Literal file name.
reconstructGlob :: Glob -> FilePath
reconstructGlob (GlobStem dir glob) =
dir </> reconstructGlob glob
reconstructGlob (GlobFinal final) = case final of
FinalMatch Recursive _ exts -> "**" </> "*" <.> exts
FinalMatch NonRecursive _ exts -> "*" <.> exts
FinalLit path -> path
-- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the
-- result if the glob matched (or would have matched with a higher
-- cabal-version).
......@@ -199,71 +207,77 @@ parseFileGlob version filepath = case reverse (splitDirectories filepath) of
| version >= mkVersion [2,4] = MultiDotEnabled
| otherwise = MultiDotDisabled
-- | Like 'matchDirFileGlob'', but will 'die'' when the glob matches
-- no files, or if the glob refers to a missing directory.
-- | This will 'die'' when the glob matches no files, or if the glob
-- refers to a missing directory, or if the glob fails to parse.
--
-- The returned values do not include the supplied @dir@ prefix, which
-- must itself be a valid directory (hence, it can't be the empty
-- string).
matchDirFileGlob :: Verbosity -> Version -> FilePath -> FilePath -> IO [FilePath]
matchDirFileGlob verbosity version dir filepath = do
results <- matchDirFileGlob' verbosity version dir filepath
let missingDirectories =
[ missingDir | GlobMissingDirectory missingDir <- results ]
matches = globMatches results
-- Check for missing directories first, since we'll obviously have
-- no matches in that case.
for_ missingDirectories $ \ missingDir ->
die' verbosity $
"filepath wildcard '" ++ filepath ++ "' refers to the directory"
++ " '" ++ missingDir ++ "', which does not exist or is not a directory."
when (null matches) $ die' verbosity $
"filepath wildcard '" ++ filepath
++ "' does not match any files."
return matches
matchDirFileGlob verbosity version dir filepath = case parseFileGlob version filepath of
Left err -> die' verbosity $ explainGlobSyntaxError filepath err
Right glob -> do
results <- runDirFileGlob verbosity dir glob
let missingDirectories =
[ missingDir | GlobMissingDirectory missingDir <- results ]
matches = globMatches results
-- Check for missing directories first, since we'll obviously have
-- no matches in that case.
for_ missingDirectories $ \ missingDir ->
die' verbosity $
"filepath wildcard '" ++ filepath ++ "' refers to the directory"
++ " '" ++ missingDir ++ "', which does not exist or is not a directory."
when (null matches) $ die' verbosity $
"filepath wildcard '" ++ filepath
++ "' does not match any files."
return matches
-- | Match files against a glob, starting in a directory.
-- | Match files against a pre-parsed glob, starting in a directory.
--
-- The returned values do not include the supplied @dir@ prefix.
matchDirFileGlob' :: Verbosity -> Version -> FilePath -> FilePath -> IO [GlobResult FilePath]
matchDirFileGlob' verbosity version rawDir filepath = case parseFileGlob version filepath of
Left err -> die' verbosity $ explainGlobSyntaxError filepath err
Right pat -> do
-- The default data-dir is null. Our callers -should- be
-- converting that to '.' themselves, but it's a certainty that
-- some future call-site will forget and trigger a really
-- hard-to-debug failure if we don't check for that here.
when (null rawDir) $
warn verbosity $
"Null dir passed to matchDirFileGlob; interpreting it "
++ "as '.'. This is probably an internal error."
let dir = if null rawDir then "." else rawDir
debug verbosity $ "Expanding glob '" ++ filepath ++ "' in directory '" ++ dir ++ "'."
-- This function might be called from the project root with dir as
-- ".". Walking the tree starting there involves going into .git/
-- and dist-newstyle/, which is a lot of work for no reward, so
-- extract the constant prefix from the pattern and start walking
-- there, and only walk as much as we need to: recursively if **,
-- the whole directory if *, and just the specific file if it's a
-- literal.
let (prefixSegments, final) = splitConstantPrefix pat
joinedPrefix = joinPath prefixSegments
case final of
FinalMatch recursive multidot exts -> do
let prefix = dir </> joinedPrefix
directoryExists <- doesDirectoryExist prefix
if directoryExists
then do
candidates <- case recursive of
Recursive -> getDirectoryContentsRecursive prefix
NonRecursive -> filterM (doesFileExist . (prefix </>)) =<< getDirectoryContents prefix
let checkName candidate = do
let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate
guard (not (null candidateBase))
match <- checkExt multidot exts candidateExts
return (joinedPrefix </> candidate <$ match)
return $ mapMaybe checkName candidates
else
return [ GlobMissingDirectory joinedPrefix ]
FinalLit fn -> do
exists <- doesFileExist (dir </> joinedPrefix </> fn)
return [ GlobMatch (joinedPrefix </> fn) | exists ]
-- The returned values do not include the supplied @dir@ prefix, which
-- must itself be a valid directory (hence, it can't be the empty
-- string).
runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath]
runDirFileGlob verbosity rawDir pat = do
-- The default data-dir is null. Our callers -should- be
-- converting that to '.' themselves, but it's a certainty that
-- some future call-site will forget and trigger a really
-- hard-to-debug failure if we don't check for that here.
when (null rawDir) $
warn verbosity $
"Null dir passed to runDirFileGlob; interpreting it "
++ "as '.'. This is probably an internal error."
let dir = if null rawDir then "." else rawDir
debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'."
-- This function might be called from the project root with dir as
-- ".". Walking the tree starting there involves going into .git/
-- and dist-newstyle/, which is a lot of work for no reward, so
-- extract the constant prefix from the pattern and start walking
-- there, and only walk as much as we need to: recursively if **,
-- the whole directory if *, and just the specific file if it's a
-- literal.
let (prefixSegments, final) = splitConstantPrefix pat
joinedPrefix = joinPath prefixSegments
case final of
FinalMatch recursive multidot exts -> do
let prefix = dir </> joinedPrefix
directoryExists <- doesDirectoryExist prefix
if directoryExists
then do
candidates <- case recursive of
Recursive -> getDirectoryContentsRecursive prefix
NonRecursive -> filterM (doesFileExist . (prefix </>)) =<< getDirectoryContents prefix
let checkName candidate = do
let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate
guard (not (null candidateBase))
match <- checkExt multidot exts candidateExts
return (joinedPrefix </> candidate <$ match)
return $ mapMaybe checkName candidates
else
return [ GlobMissingDirectory joinedPrefix ]
FinalLit fn -> do
exists <- doesFileExist (dir </> joinedPrefix </> fn)
return [ GlobMatch (joinedPrefix </> fn) | exists ]
unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
unfoldr' f a = case f a of
......
......@@ -93,21 +93,23 @@ compatibilityTests version =
-- rather than once for each test.
testMatchesVersion :: Version -> FilePath -> [GlobResult FilePath] -> Assertion
testMatchesVersion version pat expected = do
-- Test the pure glob matcher.
case parseFileGlob version pat of
globPat <- case parseFileGlob version pat of
Left _ -> assertFailure "Couldn't compile the pattern."
Right globPat ->
let actual = mapMaybe (fileGlobMatches globPat) sampleFileNames
in unless (sort expected == sort actual) $
assertFailure $ "Unexpected result (pure matcher): " ++ show actual
-- ...and the impure glob matcher.
withSystemTempDirectory "globstar-sample" $ \tmpdir -> do
makeSampleFiles tmpdir
actual <- matchDirFileGlob' Verbosity.normal version tmpdir pat
unless (isEqual actual expected) $
assertFailure $ "Unexpected result (impure matcher): " ++ show actual
Right globPat -> return globPat
checkPure globPat
checkIO globPat
where
isEqual = (==) `on` (sort . fmap (fmap normalise))
checkPure globPat = do
let actual = mapMaybe (fileGlobMatches globPat) 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
unless (isEqual actual expected) $
assertFailure $ "Unexpected result (impure matcher): " ++ show actual
testFailParseVersion :: Version -> FilePath -> GlobSyntaxError -> Assertion
testFailParseVersion version pat expected =
......
# cabal check
Warning: The following errors will cause portability problems on other environments:
Warning: No 'synopsis' or 'description' field.
Warning: In the 'extra-doc-files' field: invalid file glob '***.html'. Wildcards '*' may only totally replace the file's base name, not only parts of it.
Warning: Hackage would reject this package.
import Test.Cabal.Prelude
main = cabalTest $
fails $ cabal "check" []
cabal-version: 2.2
name: pkg
version: 0
extra-doc-files:
***.html
category: example
maintainer: none@example.com
license: BSD-3-Clause
library
exposed-modules: Foo
default-language: Haskell2010
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment