Commit 6c1342a3 authored by quasicomputational's avatar quasicomputational Committed by Alexis Williams

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.
parent 7499b44e
......@@ -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.
----
......
......@@ -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
......
......@@ -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 ]
......
......@@ -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)
-- ------------------------------------------------------------------------------
......
......@@ -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')
......
......@@ -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 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.
import Test.Cabal.Prelude
main = cabalTest $
fails $ cabal "check" []
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
This file only exists so that Git will create its two parent directories.
# 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.
import Test.Cabal.Prelude
main = cabalTest $
fails $ cabal "check" []
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
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