From 061073b17947cae1be5d00298c616ef14fce0a51 Mon Sep 17 00:00:00 2001 From: quasicomputational Date: Thu, 28 Jun 2018 11:03:13 +0100 Subject: [PATCH] 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. --- .../Distribution/PackageDescription/Check.hs | 24 +-- Cabal/Distribution/Simple/Glob.hs | 142 ++++++++++-------- .../UnitTests/Distribution/Simple/Glob.hs | 26 ++-- .../PackageTests/Check/InvalidGlob/cabal.out | 5 + .../Check/InvalidGlob/cabal.test.hs | 3 + .../PackageTests/Check/InvalidGlob/pkg.cabal | 13 ++ 6 files changed, 126 insertions(+), 87 deletions(-) create mode 100644 cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.out create mode 100644 cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/Check/InvalidGlob/pkg.cabal diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs index 13fecd5691b..f8041c1a4d8 100644 --- a/Cabal/Distribution/PackageDescription/Check.hs +++ b/Cabal/Distribution/PackageDescription/Check.hs @@ -2167,17 +2167,19 @@ checkGlobFiles :: PackageDescription -> FilePath -> NoCallStackIO [PackageCheck] checkGlobFiles pkg root = - fmap concat $ for allGlobs $ \(field, dir, glob) -> do - --TODO: baked-in verbosity - results <- matchDirFileGlob' normal (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. + fmap concat $ for (parseFileGlob (specVersion pkg) glob) $ \ parsedGlob -> do + --TODO: baked-in verbosity + results <- runDirFileGlob normal (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 diff --git a/Cabal/Distribution/Simple/Glob.hs b/Cabal/Distribution/Simple/Glob.hs index 0b488ee776e..863bcc151a6 100644 --- a/Cabal/Distribution/Simple/Glob.hs +++ b/Cabal/Distribution/Simple/Glob.hs @@ -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 diff --git a/Cabal/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal/tests/UnitTests/Distribution/Simple/Glob.hs index f60960bc129..08e242b03de 100644 --- a/Cabal/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/Cabal/tests/UnitTests/Distribution/Simple/Glob.hs @@ -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 = diff --git a/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.out b/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.out new file mode 100644 index 00000000000..8342a9a5117 --- /dev/null +++ b/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.out @@ -0,0 +1,5 @@ +# 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. diff --git a/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.test.hs b/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.test.hs new file mode 100644 index 00000000000..3e2d39fa5bc --- /dev/null +++ b/cabal-testsuite/PackageTests/Check/InvalidGlob/cabal.test.hs @@ -0,0 +1,3 @@ +import Test.Cabal.Prelude +main = cabalTest $ + fails $ cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/InvalidGlob/pkg.cabal b/cabal-testsuite/PackageTests/Check/InvalidGlob/pkg.cabal new file mode 100644 index 00000000000..e6112ad741c --- /dev/null +++ b/cabal-testsuite/PackageTests/Check/InvalidGlob/pkg.cabal @@ -0,0 +1,13 @@ +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