Make sure sdist is robust to accidentally-listed directories

The refactor of the globbing modules re-uncovered this issue, and
required a prompt fix for the refactor not to break some things.

Fixes haskell#5349

Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs

@@ -101,13 +101,13 @@ testMatchesVersion version pat expected = do
   where
     isEqual = (==) `on` (sort . fmap (fmap normalise))
     checkPure globPat = do
-      let actual = mapMaybe (matchGlob globPat) ({- splitDirectories -} sampleFileNames)
+      let actual = mapMaybe (\p -> (p <$) <$> fileGlobMatches version globPat p) 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
+        actual <- runDirFileGlob Verbosity.normal (Just version) tmpdir globPat
         unless (isEqual actual expected) $
           assertFailure $ "Unexpected result (impure matcher): " ++ show actual
 

Cabal/src/Distribution/Simple/Glob.hs

@@ -509,7 +509,7 @@ runDirFileGlob verbosity mspec rawRoot pat = do
     -- The glob matching function depends on whether we care about the cabal version or not
     doesGlobMatch :: Glob -> String -> Maybe (GlobResult ())
     doesGlobMatch glob str = case mspec of
-      Just spec -> checkName spec glob str
+      Just spec -> checkNameMatches spec glob str
       Nothing -> if matchGlob glob str then Just (GlobMatch ()) else Nothing
 
     go (GlobFile glob) dir = do
@@ -532,38 +532,11 @@ runDirFileGlob verbosity mspec rawRoot pat = do
       concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
     go GlobDirTrailing dir = return [GlobMatch dir]
 
-    checkName spec glob candidate
-      -- Check if glob matches in its general form
-      | matchGlob glob candidate =
-          -- if multidot is supported, then this is a clean match
-          if enableMultidot spec
-            then pure (GlobMatch ())
-            else -- if not, issue a warning if multidot is needed for the match
-
-              let (_, candidateExts) = splitExtensions $ takeFileName candidate
-               in case extractExts glob of
-                    Just exts
-                      | exts == candidateExts ->
-                          return (GlobMatch ())
-                      | exts `isSuffixOf` candidateExts ->
-                          return (GlobWarnMultiDot ())
-                    _ -> return (GlobMatch ())
-      | otherwise = empty
-
   directoryExists <- doesDirectoryExist (root </> joinedPrefix)
   if directoryExists
     then go variablePattern joinedPrefix
     else return [GlobMissingDirectory joinedPrefix]
   where
-    extractExts :: Glob -> Maybe String
-    extractExts [] = Nothing
-    extractExts [Literal lit]
-      -- Any literal terminating a glob, and which does have an extension,
-      -- returns that extension. Otherwise, recurse until Nothing is returned.
-      | let ext = takeExtension lit
-      , ext /= "" =
-          Just (takeExtension ext)
-    extractExts (_ : x) = extractExts x
 
     -- \| Extract the (possibly null) constant prefix from the pattern.
     -- This has the property that, if @(pref, final) = splitConstantPrefix pat@,
@@ -584,3 +557,48 @@ runDirFileGlob verbosity mspec rawRoot pat = do
 isRecursiveInRoot :: FilePathGlobRel -> Bool
 isRecursiveInRoot (GlobDirRecursive _) = True
 isRecursiveInRoot _ = False
+
+
+-- | Check how the string matches the glob under this cabal version
+checkNameMatches :: CabalSpecVersion -> Glob -> String -> Maybe (GlobResult ())
+checkNameMatches spec glob candidate
+  -- Check if glob matches in its general form
+  | matchGlob glob candidate =
+      -- if multidot is supported, then this is a clean match
+      if enableMultidot spec
+        then pure (GlobMatch ())
+        else -- if not, issue a warning if multidot is needed for the match
+          let (_, candidateExts) = splitExtensions $ takeFileName candidate
+              extractExts :: Glob -> Maybe String
+              extractExts [] = Nothing
+              extractExts [Literal lit]
+                -- Any literal terminating a glob, and which does have an extension,
+                -- returns that extension. Otherwise, recurse until Nothing is returned.
+                | let ext = takeExtension lit
+                , ext /= "" =
+                    Just (takeExtension ext)
+              extractExts (_ : x) = extractExts x
+           in case extractExts glob of
+                Just exts
+                  | exts == candidateExts ->
+                      return (GlobMatch ())
+                  | exts `isSuffixOf` candidateExts ->
+                      return (GlobWarnMultiDot ())
+                _ -> return (GlobMatch ())
+  | otherwise = empty
+
+
+-- | Does the glob match the given filepath?
+fileGlobMatches :: CabalSpecVersion -> FilePathGlobRel -> FilePath -> Maybe (GlobResult ())
+fileGlobMatches version g path = go g (splitDirectories path) where
+  go GlobDirTrailing [] = Just (GlobMatch ())
+  go (GlobFile glob) [file] = checkNameMatches version glob file
+  go (GlobDirRecursive glob) dirs
+    | [] <- reverse dirs
+    = Nothing -- @dir/**/x.txt@ should not match @dir/hello@
+    | file:_ <- reverse dirs
+    = checkNameMatches version glob file
+  go (GlobDir glob globPath) (dir:dirs) = do
+    _ <- checkNameMatches version glob dir -- we only care if dir segment matches
+    go globPath dirs
+  go _ _ = Nothing

Cabal/src/Distribution/Simple/SrcDist.hs

@@ -245,20 +245,24 @@ listPackageSources' verbosity rip cwd pkg_descr pps =
     , -- Data files.
       fmap concat
         . for (dataFiles pkg_descr)
-        $ \filename -> do
-          let srcDataDirRaw = dataDir pkg_descr
-              srcDataDir
-                | null srcDataDirRaw = "."
-                | otherwise = srcDataDirRaw
-          matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
+        $ \filename ->
+          do
+            let srcDataDirRaw = dataDir pkg_descr
+                srcDataDir
+                  | null srcDataDirRaw = "."
+                  | otherwise = srcDataDirRaw
+            matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
+            >>= filterOutDirectories "data-files"
     , -- Extra source files.
       fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
         matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath
+          >>= filterOutDirectories "extra-source-files"
     , -- Extra doc files.
       fmap concat
         . for (extraDocFiles pkg_descr)
         $ \filename ->
           matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename
+            >>= filterOutDirectories "extra-doc-files"
     , -- License file(s).
       return (map getSymbolicPath $ licenseFiles pkg_descr)
     , -- Install-include files, without autogen-include files
@@ -283,6 +287,19 @@ listPackageSources' verbosity rip cwd pkg_descr pps =
     withAllTest action = traverse action (testSuites pkg_descr)
     withAllBenchmark action = traverse action (benchmarks pkg_descr)
 
+    -- For data-files, extra-source-files, and extra-doc-files, we filter out
+    -- directories since the function must only return paths to files. This
+    -- filtering is necessary because globs may match directories.
+    filterOutDirectories loc matches = flip filterM matches $ \path -> do
+      isFile <- doesFileExist path
+      -- Must be a directory, since it is a path that matched the glob and
+      -- isn't a file.
+      if isFile
+        then return True
+        else do
+          warn verbosity $ "Ignoring directory '" ++ path ++ "'" ++ " listed in field '" ++ loc ++ "' in the Cabal package. This field can only include files (not directories)."
+          return False
+
 -- | Prepare a directory tree of source files.
 prepareTree
   :: Verbosity

cabal-testsuite/PackageTests/SDist/T5195and5349/actually-a-file

@@ -0,0 +1 @@
+Hi

cabal-testsuite/PackageTests/SDist/T5195and5349/cabal.test.hs

@@ -0,0 +1,5 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+  tmpdir <- fmap testTmpDir getTestEnv
+  cabal' "v2-sdist" ["--list-only", "--output-directory", tmpdir]
+  return ()

cabal-testsuite/PackageTests/SDist/T5195and5349/t5195and5349.cabal

@@ -0,0 +1,19 @@
+cabal-version: 2.2
+name: t5195and5349
+version: 0
+
+extra-source-files:
+  ./actually-a-directory
+  ./actually-a-file
+
+extra-doc-files:
+  ./actually-a-directory
+  ./actually-a-file
+
+data-files:
+  ./actually-a-directory
+  ./actually-a-file
+
+executable foo
+  default-language: Haskell2010
+  main-is: Main.hs