From 6c1342a3c306948ce0d8af7816f7dbcd4ec6f7b5 Mon Sep 17 00:00:00 2001
From: quasicomputational <quasicomputational@gmail.com>
Date: Wed, 27 Jun 2018 10:31:41 +0100
Subject: [PATCH] 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. #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 | 2 +
.../Distribution/PackageDescription/Check.hs | 67 +++++++++++--------
Cabal/Distribution/Simple/Glob.hs | 51 +++++++++-----
Cabal/Distribution/Simple/Haddock.hs | 2 +-
Cabal/Distribution/Simple/Install.hs | 4 +-
Cabal/Distribution/Simple/SrcDist.hs | 7 +-
.../Check/MissingGlobDirectory/Foo.hs | 1 +
.../Check/MissingGlobDirectory/cabal.out | 9 +++
.../Check/MissingGlobDirectory/cabal.test.hs | 3 +
.../Check/MissingGlobDirectory/data/hello.dat | 1 +
.../MissingGlobDirectory/file-not-a-directory | 1 +
.../Check/MissingGlobDirectory/pkg.cabal | 21 ++++++
.../present/present/hello | 1 +
.../Check/MissingGlobDirectory2/Foo.hs | 1 +
.../Check/MissingGlobDirectory2/cabal.out | 6 ++
.../Check/MissingGlobDirectory2/cabal.test.hs | 3 +
.../Check/MissingGlobDirectory2/pkg.cabal | 14 ++++
17 files changed, 143 insertions(+), 51 deletions(-)
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory/Foo.hs
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.out
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory/data/hello.dat
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory/file-not-a-directory
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory/pkg.cabal
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory/present/present/hello
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/Foo.hs
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.out
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs
create mode 100644 cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/pkg.cabal
diff --git a/Cabal/ChangeLog.md b/Cabal/ChangeLog.md
index b8dfd884aa..672392cf0d 100644
--- a/Cabal/ChangeLog.md
+++ b/Cabal/ChangeLog.md
@@ -66,6 +66,8 @@
([#5386](https://github.com/haskell/cabal/issues/5386)).
* `Distribution.PackageDescription.Check.checkPackageFiles` now
accepts a `Verbosity` argument.
+ * `cabal check` now warns about globs that refer to missing
+ directories.
----
diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs
index e8567afb30..7dd5b33957 100644
--- a/Cabal/Distribution/PackageDescription/Check.hs
+++ b/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,31 @@ 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 =
+checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath -> NoCallStackIO [PackageCheck]
+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) -> 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
- ]
+ return $ results >>= getWarning field glob
where
adjustedDataDir = if null (dataDir pkg) then "." else dataDir pkg
allGlobs = concat
@@ -2184,6 +2175,26 @@ checkGlobMultiDot verbosity pkg root =
, (,,) "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
diff --git a/Cabal/Distribution/Simple/Glob.hs b/Cabal/Distribution/Simple/Glob.hs
index 629f45cf60..0b488ee776 100644
--- a/Cabal/Distribution/Simple/Glob.hs
+++ b/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 ]
diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs
index 7f2495ecf1..13e79755a8 100644
--- a/Cabal/Distribution/Simple/Haddock.hs
+++ b/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)
-- ------------------------------------------------------------------------------
diff --git a/Cabal/Distribution/Simple/Install.hs b/Cabal/Distribution/Simple/Install.hs
index 26b7d36185..83305bc0dc 100644
--- a/Cabal/Distribution/Simple/Install.hs
+++ b/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')
diff --git a/Cabal/Distribution/Simple/SrcDist.hs b/Cabal/Distribution/Simple/SrcDist.hs
index a02686ff40..88368dae7c 100644
--- a/Cabal/Distribution/Simple/SrcDist.hs
+++ b/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).
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/Foo.hs b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/Foo.hs
new file mode 100644
index 0000000000..85e9b7cee7
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/Foo.hs
@@ -0,0 +1 @@
+foo = True
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.out b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.out
new file mode 100644
index 0000000000..c9cc011d47
--- /dev/null
+++ b/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.
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs
new file mode 100644
index 0000000000..3e2d39fa5b
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/cabal.test.hs
@@ -0,0 +1,3 @@
+import Test.Cabal.Prelude
+main = cabalTest $
+ fails $ cabal "check" []
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/data/hello.dat b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/data/hello.dat
new file mode 100644
index 0000000000..6d96d67d91
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/data/hello.dat
@@ -0,0 +1 @@
+hello.dat
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/file-not-a-directory b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/file-not-a-directory
new file mode 100644
index 0000000000..cd00d26af7
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/file-not-a-directory
@@ -0,0 +1 @@
+This is not a directory.
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/pkg.cabal b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/pkg.cabal
new file mode 100644
index 0000000000..35b580e230
--- /dev/null
+++ b/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: none@example.com
+synopsis: synopsis
+description: description
+license: BSD-3-Clause
+
+library
+ exposed-modules: Foo
+ default-language: Haskell2010
\ No newline at end of file
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/present/present/hello b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/present/present/hello
new file mode 100644
index 0000000000..1e4f8c3402
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory/present/present/hello
@@ -0,0 +1 @@
+This file only exists so that Git will create its two parent directories.
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/Foo.hs b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/Foo.hs
new file mode 100644
index 0000000000..85e9b7cee7
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/Foo.hs
@@ -0,0 +1 @@
+foo = True
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.out b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.out
new file mode 100644
index 0000000000..e62a8a5329
--- /dev/null
+++ b/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.
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs
new file mode 100644
index 0000000000..3e2d39fa5b
--- /dev/null
+++ b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/cabal.test.hs
@@ -0,0 +1,3 @@
+import Test.Cabal.Prelude
+main = cabalTest $
+ fails $ cabal "check" []
diff --git a/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/pkg.cabal b/cabal-testsuite/PackageTests/Check/MissingGlobDirectory2/pkg.cabal
new file mode 100644
index 0000000000..29a45267a8
--- /dev/null
+++ b/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: none@example.com
+synopsis: synopsis
+description: description
+license: BSD-3-Clause
+
+library
+ exposed-modules: Foo
+ default-language: Haskell2010
\ No newline at end of file
--
GitLab