Make cabal check warn about missing directories in globs

This also significantly improves the error when trying to refer to
missing directories, hopefully making it clear that it's coming from
Cabal. haskell#5318 and snowleopard/hadrian#634 are two bugs which manifested
as Cabal trying to glob in a non-existent directory and both took some
debugging because of the obscurity of the error.

Cabal/ChangeLog.md

@@ -61,6 +61,8 @@
     path components on Windows and warn about other unsafe characters
     in the path to the source directory on all platforms
     ([#5386](https://github.com/haskell/cabal/issues/5386)).
+  * `cabal check` now warns about globs that refer to missing
+    directories.
 
 ----
 

Cabal/Distribution/PackageDescription/Check.hs

@@ -1843,11 +1843,11 @@ checkDevelopmentOnlyFlags pkg =
 checkPackageFiles :: PackageDescription -> FilePath -> NoCallStackIO [PackageCheck]
 checkPackageFiles pkg root = do
   contentChecks <- checkPackageContent checkFilesIO pkg
-  missingFileChecks <- checkPackageMissingFiles pkg root
+  preDistributionChecks <- checkPackageFilesPreDistribution 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,47 +2143,58 @@ 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 :: 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 :: PackageDescription
-                  -> FilePath
-                  -> NoCallStackIO [PackageCheck]
-checkGlobMultiDot pkg root =
+checkPackageFilesPreDistribution :: PackageDescription -> FilePath -> NoCallStackIO [PackageCheck]
+checkPackageFilesPreDistribution = checkGlobFiles
+
+-- | Discover problems with the package's wildcards.
+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
-    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
-      ]
+    return $ results >>= getWarning field glob
   where
     adjustedDataDir = if null (dataDir pkg) then "." else dataDir pkg
     allGlobs = concat
       [ (,,) "extra-source-files" "." <$> extraSrcFiles pkg
       , (,,) "extra-doc-files" "." <$> extraDocFiles pkg
       , (,,) "data-files" adjustedDataDir <$> dataFiles pkg
       ]
+    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) =
+      [ PackageDistInexcusable $
+             "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,7 +17,6 @@
 module Distribution.Simple.Glob (
         GlobSyntaxError(..),
         GlobResult(..),
-        globMatches,
         matchDirFileGlob,
         matchDirFileGlob',
         fileGlobMatches,
@@ -35,7 +34,7 @@ import Distribution.Simple.Utils
 import Distribution.Verbosity
 import Distribution.Version
 
-import System.Directory (getDirectoryContents, doesFileExist)
+import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)
 import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>))
 
 -- Note throughout that we use splitDirectories, not splitPath. On
@@ -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 ]
 
@@ -193,11 +200,20 @@ parseFileGlob version filepath = case reverse (splitDirectories filepath) of
       | otherwise = MultiDotDisabled
 
 -- | Like 'matchDirFileGlob'', but will 'die'' when the glob matches
--- no files.
-matchDirFileGlob :: Verbosity -> Version -> FilePath -> FilePath -> IO [GlobResult FilePath]
+-- no files, or if the glob refers to a missing directory.
+matchDirFileGlob :: Verbosity -> Version -> FilePath -> FilePath -> IO [FilePath]
 matchDirFileGlob verbosity version dir filepath = do
-  matches <- matchDirFileGlob' verbosity version dir filepath
-  when (null $ globMatches matches) $ die' verbosity $
+  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
@@ -231,15 +247,20 @@ matchDirFileGlob' verbosity version rawDir filepath = case parseFileGlob version
     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
+        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 ]

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)
 
 -- ------------------------------------------------------------------------------

Cabal/Distribution/Simple/Install.hs

@@ -33,7 +33,7 @@ import Distribution.Package
 import Distribution.PackageDescription
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.BuildPaths (haddockName, haddockPref)
-import Distribution.Simple.Glob (matchDirFileGlob, globMatches)
+import Distribution.Simple.Glob (matchDirFileGlob)
 import Distribution.Simple.Utils
          ( createDirectoryIfMissingVerbose
          , installDirectoryContents, installOrdinaryFile, isInSearchPath
@@ -238,7 +238,7 @@ installDataFiles verbosity pkg_descr destDataDir =
         srcDataDir = if null srcDataDirRaw
           then "."
           else srcDataDirRaw
-    files <- globMatches <$> matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir file
+    files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir file
     let dir = takeDirectory file
     createDirectoryIfMissingVerbose verbosity True (destDataDir </> dir)
     sequence_ [ installOrdinaryFile verbosity (srcDataDir  </> file')

Cabal/Distribution/Simple/SrcDist.hs

@@ -148,8 +148,7 @@ listPackageSourcesMaybeExecutable :: Verbosity -> PackageDescription -> IO [File
 listPackageSourcesMaybeExecutable verbosity pkg_descr =
   -- Extra source files.
   fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
-    fmap globMatches $
-      matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
+    matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
 
 -- | List those source files that should be copied with ordinary permissions.
 listPackageSourcesOrdinary :: Verbosity
@@ -216,13 +215,11 @@ listPackageSourcesOrdinary verbosity pkg_descr pps =
               then "."
               else srcDataDirRaw
         in fmap (fmap (srcDataDir </>)) $
-             fmap globMatches $
-               matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir filename
+             matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir filename
 
     -- Extra doc files.
   , fmap concat
     . for (extraDocFiles pkg_descr) $ \ filename ->
-      fmap globMatches $
         matchDirFileGlob verbosity (specVersion pkg_descr) "." filename
 
     -- License file(s).

cabal-testsuite/PackageTests/Check/MissingGlobDirectory/Foo.hs

@@ -0,0 +1 @@
+foo = True

cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.out

@@ -0,0 +1,9 @@
+# cabal check
+Warning: The package will not build sanely due to these errors:
+Warning: This package description follows version 2.4 of the Cabal specification. This tool only supports up to version 2.3.0.0.
+Warning: The following errors will cause portability problems on other environments:
+Warning: In 'data-files': the pattern 'another-non-existent-directory/**/*.dat' attempts to match files in the directory 'another-non-existent-directory', but there is no directory by that name.
+Warning: In 'extra-doc-files': the pattern 'non-existent-directory/*.html' attempts to match files in the directory 'non-existent-directory', but there is no directory by that name.
+Warning: In 'extra-doc-files': the pattern 'present/present/missing/*.tex' attempts to match files in the directory 'present/present/missing', but there is no directory by that name.
+Warning: In 'extra-source-files': the pattern 'file-not-a-directory/*.js' attempts to match files in the directory 'file-not-a-directory', but there is no directory by that name.
+Warning: Hackage would reject this package.

cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs

@@ -0,0 +1,3 @@
+import Test.Cabal.Prelude
+main = cabalTest $
+  fails $ cabal "check" []

cabal-testsuite/PackageTests/Check/MissingGlobDirectory/data/hello.dat

@@ -0,0 +1 @@
+hello.dat

cabal-testsuite/PackageTests/Check/MissingGlobDirectory/file-not-a-directory

@@ -0,0 +1 @@
+This is not a directory.

cabal-testsuite/PackageTests/Check/MissingGlobDirectory/pkg.cabal

@@ -0,0 +1,21 @@
+cabal-version: 2.4
+name: pkg
+version: 0
+extra-doc-files:
+  non-existent-directory/*.html
+  present/present/missing/*.tex
+extra-source-files:
+  file-not-a-directory/*.js
+data-dir:
+  data
+data-files:
+  another-non-existent-directory/**/*.dat
+category: example
+maintainer: [email protected]
+synopsis: synopsis
+description: description
+license: BSD-3-Clause
+
+library
+  exposed-modules: Foo
+  default-language: Haskell2010

cabal-testsuite/PackageTests/Check/MissingGlobDirectory/present/present/hello

@@ -0,0 +1 @@
+This file only exists so that Git will create its two parent directories.

cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/Foo.hs

@@ -0,0 +1 @@
+foo = True

cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.out

@@ -0,0 +1,6 @@
+# cabal check
+Warning: The package will not build sanely due to these errors:
+Warning: This package description follows version 2.4 of the Cabal specification. This tool only supports up to version 2.3.0.0.
+Warning: The following errors will cause portability problems on other environments:
+Warning: In 'data-files': the pattern 'non-existent-directory/**/*.dat' attempts to match files in the directory 'non-existent-directory', but there is no directory by that name.
+Warning: Hackage would reject this package.

cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs

@@ -0,0 +1,3 @@
+import Test.Cabal.Prelude
+main = cabalTest $
+  fails $ cabal "check" []

cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/pkg.cabal

@@ -0,0 +1,14 @@
+cabal-version: 2.4
+name: pkg
+version: 0
+data-files:
+  non-existent-directory/**/*.dat
+category: example
+maintainer: [email protected]
+synopsis: synopsis
+description: description
+license: BSD-3-Clause
+
+library
+  exposed-modules: Foo
+  default-language: Haskell2010