cabal check improvements for globs

Cabal/ChangeLog.md

@@ -21,18 +21,30 @@
   * Added `Eta` to `CompilerFlavor` and to known compilers.
   * `cabal haddock` now generates per-component documentation
     ([#5226](https://github.com/haskell/cabal/issues/5226)).
-  * Allow `**` wildcards in `data-files`, `extra-source-files` and
-    `extra-doc-files`. These allow a limited form of recursive
-    matching, and require `cabal-version: 2.4`.
-
-    Wildcard syntax errors (misplaced `*`, etc) are also now detected
-    by `cabal check`.
-
-    `FileGlob`, `parseFileGlob`, `matchFileGlob` and `matchDirFileGlob`
-    have beem moved from `Distribution.Simple.Utils` to a new file,
-    `Distribution.Simple.Glob` and `FileGlob` has been made abstract.
-
-    ([#5284](https://github.com/haskell/cabal/issues/5284), [#3178](https://github.com/haskell/cabal/issues/3178), et al.)
+  * Wildcard improvements:
+    * Allow `**` wildcards in `data-files`, `extra-source-files` and
+      `extra-doc-files`. These allow a limited form of recursive
+      matching, and require `cabal-version: 2.4`.
+      ([#5284](https://github.com/haskell/cabal/issues/5284),
+      [#3178](https://github.com/haskell/cabal/issues/3178), et al.)
+    * With `cabal-version: 2.4`, when matching a wildcard, the
+      requirement for the full extension to match exactly has been
+      loosened. Instead, if the wildcard's extension is a suffix of the
+      file's extension, the file will be selected. For example,
+      previously `foo.en.html` would not match `*.html`, and
+      `foo.solaris.tar.gz` would not match `*.tar.gz`, but now both
+      do. This may lead to files unexpectedly being included by `sdist`;
+      please audit your package descriptions if you rely on this
+      behaviour to keep sensitive data out of distributed packages
+      ([#5372](https://github.com/haskell/cabal/pull/5372),
+      [#784](https://github.com/haskell/cabal/issues/784),
+      [#5057](https://github.com/haskell/cabal/issues/5057)).
+    * Wildcard syntax errors (misplaced `*`, etc), wildcards that
+      refer to missing directoies, and wildcards that do not match
+      anything are now all detected by `cabal check`.
+    * Wildcard ('globbing') functions have been moved from
+      `Distribution.Simple.Utils` to `Distribution.Simple.Glob` and
+      have been refactored.
   * Fixed `cxx-options` and `cxx-sources` buildinfo fields for
     separate compilation of C++ source files to correctly build and link
     non-library components ([#5309](https://github.com/haskell/cabal/issues/5309)).
@@ -47,15 +59,6 @@
     `cxx-options`, `cpp-options` are not deduplicated anymore
     ([#4449](https://github.com/haskell/cabal/issues/4449)).
   * Deprecated `cabal hscolour` in favour of `cabal haddock --hyperlink-source` ([#5236](https://github.com/haskell/cabal/pull/5236/)).
-  * With `cabal-version: 2.4`, when matching a wildcard, the
-    requirement for the full extension to match exactly has been
-    loosened. Instead, if the wildcard's extension is a suffix of the
-    file's extension, the file will be selected. For example,
-    previously `foo.en.html` would not match `*.html`, and
-    `foo.solaris.tar.gz` would not match `*.tar.gz`, but now both
-    do. This may lead to files unexpectedly being included by `sdist`;
-    please audit your package descriptions if you rely on this
-    behaviour to keep sensitive data out of distributed packages.
   * Recognize `powerpc64le` as architecture PPC64.
   * Cabal now deduplicates more `-I` and `-L` and flags to avoid `E2BIG`
     ([#5356](https://github.com/haskell/cabal/issues/5356)).

Cabal/Distribution/PackageDescription/Check.hs

@@ -1843,11 +1843,11 @@ checkDevelopmentOnlyFlags pkg =
 checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> NoCallStackIO [PackageCheck]
 checkPackageFiles verbosity pkg root = do
   contentChecks <- checkPackageContent checkFilesIO pkg
-  missingFileChecks <- checkPackageMissingFiles verbosity pkg root
+  preDistributionChecks <- checkPackageFilesPreDistribution verbosity pkg root
   -- Sort because different platforms will provide files from
   -- `getDirectoryContents` in different orders, and we'd like to be
   -- stable for test output.
-  return (sort contentChecks ++ sort missingFileChecks)
+  return (sort contentChecks ++ sort preDistributionChecks)
   where
     checkFilesIO = CheckPackageContentOps {
       doesFileExist        = System.doesFileExist                  . relative,
@@ -2143,40 +2143,45 @@ checkTarPath path
       ++ "Files with an empty name cannot be stored in a tar archive or in "
       ++ "standard file systems."
 
--- ------------------------------------------------------------
--- * Checks for missing content
--- ------------------------------------------------------------
+-- --------------------------------------------------------------
+-- * Checks for missing content and other pre-distribution checks
+-- --------------------------------------------------------------
 
--- | Similar to 'checkPackageContent', 'checkPackageMissingFiles' inspects
--- the files included in the package, but is primarily looking for files in
--- the working tree that may have been missed.
+-- | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution'
+-- inspects the files included in the package, but is primarily looking for
+-- files in the working tree that may have been missed or other similar
+-- problems that can only be detected pre-distribution.
 --
 -- Because Hackage necessarily checks the uploaded tarball, it is too late to
 -- check these on the server; these checks only make sense in the development
 -- and package-creation environment. Hence we can use IO, rather than needing
 -- to pass a 'CheckPackageContentOps' dictionary around.
-checkPackageMissingFiles :: Verbosity -> PackageDescription -> FilePath -> NoCallStackIO [PackageCheck]
-checkPackageMissingFiles = checkGlobMultiDot
-
--- | Before Cabal 2.4, the extensions of globs had to match the file
--- exactly. This has been relaxed in 2.4 to allow matching only the
--- suffix. This warning detects when pre-2.4 package descriptions are
--- omitting files purely because of the stricter check.
-checkGlobMultiDot :: Verbosity
-                  -> PackageDescription
-                  -> FilePath
-                  -> NoCallStackIO [PackageCheck]
-checkGlobMultiDot verbosity pkg root =
-  fmap concat $ for allGlobs $ \(field, dir, glob) -> do
-    results <- matchDirFileGlob' verbosity (specVersion pkg) (root </> dir) glob
-    return
-      [ PackageDistSuspiciousWarn $
-             "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"
-          ++ " match the file '" ++ file ++ "' because the extensions do not"
-          ++ " exactly match (e.g., foo.en.html does not exactly match *.html)."
-          ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or higher."
-      | GlobWarnMultiDot file <- results
-      ]
+checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath -> NoCallStackIO [PackageCheck]
+-- Note: this really shouldn't return any 'Inexcusable' warnings,
+-- because that will make us say that Hackage would reject the package.
+-- But, because Hackage doesn't run these tests, that will be a lie!
+checkPackageFilesPreDistribution = checkGlobFiles
+
+-- | Discover problems with the package's wildcards.
+checkGlobFiles :: Verbosity
+               -> PackageDescription
+               -> FilePath
+               -> NoCallStackIO [PackageCheck]
+checkGlobFiles verbosity pkg root =
+  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
@@ -2185,6 +2190,35 @@ checkGlobMultiDot verbosity pkg root =
       , (,,) "data-files" adjustedDataDir <$> dataFiles pkg
       ]
 
+    -- If there's a missing directory in play, since our globs don't
+    -- (currently) support disjunction, that will always mean there are no
+    -- matches. The no matches error in this case is strictly less informative
+    -- than the missing directory error, so sit on it.
+    suppressesNoMatchesWarning (GlobMatch _) = True
+    suppressesNoMatchesWarning (GlobWarnMultiDot _) = False
+    suppressesNoMatchesWarning (GlobMissingDirectory _) = True
+
+    getWarning :: String -> FilePath -> GlobResult FilePath -> [PackageCheck]
+    getWarning _ _ (GlobMatch _) =
+      []
+    -- Before Cabal 2.4, the extensions of globs had to match the file
+    -- exactly. This has been relaxed in 2.4 to allow matching only the
+    -- suffix. This warning detects when pre-2.4 package descriptions are
+    -- omitting files purely because of the stricter check.
+    getWarning field glob (GlobWarnMultiDot file) =
+      [ PackageDistSuspiciousWarn $
+             "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"
+          ++ " match the file '" ++ file ++ "' because the extensions do not"
+          ++ " exactly match (e.g., foo.en.html does not exactly match *.html)."
+          ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or higher."
+      ]
+    getWarning field glob (GlobMissingDirectory dir) =
+      [ PackageDistSuspiciousWarn $
+             "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to"
+          ++ " match files in the directory '" ++ dir ++ "', but there is no"
+          ++ " directory by that name."
+      ]
+
 -- ------------------------------------------------------------
 -- * Utils
 -- ------------------------------------------------------------

Cabal/Distribution/Simple/Glob.hs

@@ -17,9 +17,8 @@
 module Distribution.Simple.Glob (
         GlobSyntaxError(..),
         GlobResult(..),
-        globMatches,
         matchDirFileGlob,
-        matchDirFileGlob',
+        runDirFileGlob,
         fileGlobMatches,
         parseFileGlob,
         explainGlobSyntaxError,
@@ -35,8 +34,8 @@ import Distribution.Simple.Utils
 import Distribution.Verbosity
 import Distribution.Version
 
-import System.Directory (getDirectoryContents, doesFileExist)
-import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>))
+import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)
+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
@@ -52,9 +51,17 @@ data GlobResult a
     --   not precisely match the glob's extensions, but rather the
     --   glob was a proper suffix of the file's extensions; i.e., if
     --   not for the low cabal-version, it would have matched.
+  | GlobMissingDirectory FilePath
+    -- ^ The glob couldn't match because the directory named doesn't
+    --   exist. The directory will be as it appears in the glob (i.e.,
+    --   relative to the directory passed to 'matchDirFileGlob', and,
+    --   for 'data-files', relative to 'data-dir').
   deriving (Show, Eq, Ord, Functor)
 
 -- | Extract the matches from a list of 'GlobResult's.
+--
+-- Note: throws away the 'GlobMissingDirectory' results; chances are
+-- that you want to check for these and error out if any are present.
 globMatches :: [GlobResult a] -> [a]
 globMatches input = [ a | GlobMatch a <- input ]
 
@@ -120,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).
@@ -192,57 +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.
-matchDirFileGlob :: Verbosity -> Version -> FilePath -> FilePath -> IO [GlobResult FilePath]
-matchDirFileGlob verbosity version dir filepath = do
-  matches <- matchDirFileGlob' verbosity version dir filepath
-  when (null $ globMatches matches) $ die' verbosity $
-       "filepath wildcard '" ++ filepath
-    ++ "' does not match any files."
-  return matches
-
--- | Match files against a glob, starting in a 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.
-matchDirFileGlob' :: Verbosity -> Version -> FilePath -> FilePath -> IO [GlobResult FilePath]
-matchDirFileGlob' verbosity version rawDir filepath = case parseFileGlob version filepath of
+-- 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 = 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
-        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
-      FinalLit fn -> do
-        exists <- doesFileExist (dir </> joinedPrefix </> fn)
-        return [ GlobMatch (joinedPrefix </> fn) | exists ]
+  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 pre-parsed glob, starting in a directory.
+--
+-- 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

Cabal/Distribution/Simple/Haddock.hs

@@ -306,7 +306,7 @@ haddock pkg_descr lbi suffixes flags' = do
         CBench _ -> (when (flag haddockBenchmarks)  $ smsg >> doExe component) >> return index
 
     for_ (extraDocFiles pkg_descr) $ \ fpath -> do
-      files <- fmap globMatches $ matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
+      files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
       for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
 
 -- ------------------------------------------------------------------------------