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

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module UnitTests.Distribution.Simple.Glob
     ( tests
     ) where
@@ -54,7 +55,7 @@ compatibilityTests version =
   [ testCase "literal match" $
       testMatches "foo/a" [GlobMatch "foo/a"]
   , testCase "literal no match on prefix" $
-      testMatches "foo/c.html" []
+      testMatches "foo/c.html" [GlobMatchesDirectory "foo/c.html"]
   , testCase "literal no match on suffix" $
       testMatches "foo/a.html" [GlobMatch "foo/a.html"]
   , testCase "literal no prefix" $
@@ -64,7 +65,7 @@ compatibilityTests version =
   , testCase "glob" $
       testMatches "*.html" [GlobMatch "a.html", GlobMatch "b.html"]
   , testCase "glob in subdir" $
-      testMatches "foo/*.html" [GlobMatch "foo/a.html", GlobMatch "foo/b.html"]
+      testMatches "foo/*.html" [GlobMatchesDirectory "foo/c.html", GlobMatch "foo/b.html", GlobMatch "foo/a.html"]
   , testCase "glob multiple extensions" $
       testMatches "foo/*.html.gz" [GlobMatch "foo/a.html.gz", GlobMatch "foo/b.html.gz"]
   , testCase "glob in deep subdir" $
@@ -102,7 +103,10 @@ testMatchesVersion version pat expected = do
     isEqual = (==) `on` (sort . fmap (fmap normalise))
     checkPure globPat = do
       let actual = mapMaybe (\p -> (p <$) <$> fileGlobMatches version globPat p) sampleFileNames
-      unless (sort expected == sort actual) $
+          -- We drop directory matches from the expected results since the pure
+          -- check can't identify that kind of match.
+          expected' = filter (\case GlobMatchesDirectory _ -> False; _ -> True) expected
+      unless (sort expected' == sort actual) $
         assertFailure $ "Unexpected result (pure matcher): " ++ show actual
     checkIO globPat =
       withSystemTempDirectory "globstar-sample" $ \tmpdir -> do

Cabal/src/Distribution/PackageDescription/Check.hs

@@ -170,7 +170,7 @@ checkPackageFilesGPD verbosity gpd root =
 
     checkPreIO =
       CheckPreDistributionOps
-        { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just $ specVersion $ packageDescription gpd) (root </> fp) g
+        { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root </> fp) g
         , getDirectoryContentsM = System.Directory.getDirectoryContents . relative
         }
 
@@ -853,14 +853,14 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
           [PackageDistSuspiciousWarn $ GlobNoMatch title fp]
       | otherwise = []
 
-    -- If there's a missing directory in play, since our globs don't
-    -- (currently) support disjunction, (ROMES:TODO: We do now...)
-    -- that will always mean there are
+    -- If there's a missing directory in play, since globs in Cabal packages
+    -- 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.
     withoutNoMatchesWarning (GlobMatch _) = True
     withoutNoMatchesWarning (GlobWarnMultiDot _) = False
     withoutNoMatchesWarning (GlobMissingDirectory _) = True
+    withoutNoMatchesWarning (GlobMatchesDirectory _) = True
 
     getWarning :: GlobResult FilePath -> Maybe PackageCheck
     getWarning (GlobMatch _) = Nothing
@@ -872,6 +872,7 @@ checkGlobResult title fp rs = dirCheck ++ catMaybes (map getWarning rs)
       Just $ PackageDistSuspiciousWarn (GlobExactMatch title fp file)
     getWarning (GlobMissingDirectory dir) =
       Just $ PackageDistSuspiciousWarn (GlobNoDir title fp dir)
+    getWarning (GlobMatchesDirectory _) = Nothing -- is handled elsewhere if relevant, it is not necessarily a problem
 
 -- ------------------------------------------------------------
 -- Other exports

Cabal/src/Distribution/Simple/Glob.hs

@@ -148,6 +148,7 @@ matchFileGlobRel root glob =
     ( \case
         GlobMatch a -> Just a
         GlobWarnMultiDot a -> Just a
+        GlobMatchesDirectory a -> Just a
         GlobMissingDirectory{} -> Nothing
     )
     <$> runDirFileGlob silent Nothing root glob
@@ -284,7 +285,7 @@ instance Parsec FilePathGlobRel where
       parsecPath = do
         glob <- parsecGlob
         dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
-      -- TODO: We could support parsing recursive directory search syntax
+      -- We could support parsing recursive directory search syntax
       -- @**@ here too, rather than just in 'parseFileGlob'
 
       dirSep :: CabalParsing m => m ()
@@ -413,7 +414,9 @@ data GlobResult a
     --   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').
-    GlobMissingDirectory FilePath
+    GlobMissingDirectory a
+  | -- | The glob matched a directory when we were looking for files only. It didn't match a file!
+    GlobMatchesDirectory a
   deriving (Show, Eq, Ord, Functor)
 
 -- | Extract the matches from a list of 'GlobResult's.
@@ -450,6 +453,7 @@ matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob
     let missingDirectories =
           [missingDir | GlobMissingDirectory missingDir <- results]
         matches = globMatches results
+        directoryMatches = [a | GlobMatchesDirectory a <- results]
 
     let errors :: [String]
         errors =
@@ -462,11 +466,22 @@ matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob
           | missingDir <- missingDirectories
           ]
             ++ [ "filepath wildcard '" ++ filepath ++ "' does not match any files."
-               | null matches
+               | null matches && null directoryMatches
+               -- we don't error out on directory matches, simply warn about them and ignore.
                ]
 
+        warns :: [String]
+        warns =
+          [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)."
+          | path <- directoryMatches
+          ]
+
     if null errors
-      then return matches
+      then do
+        unless (null warns) $
+          warn verbosity $
+            unlines warns
+        return matches
       else rip verbosity $ MatchDirFileGlobErrors errors
 
 -- | Match files against a pre-parsed glob, starting in a directory.
@@ -523,17 +538,28 @@ runDirFileGlob verbosity mspec rawRoot pat = do
               -- when a cabal spec version is passed as an argument), we
               -- disallow matching a @GlobFile@ against a directory, preferring
               -- @GlobDir dir GlobDirTrailing@ to specify a directory match.
-              shouldMatch <- maybe (return True) (const $ doesFileExist (root </> dir </> s)) mspec
+              isFile <- maybe (return True) (const $ doesFileExist (root </> dir </> s)) mspec
+              let match = (dir </> s <$) <$> doesGlobMatch glob s
               return $
-                if shouldMatch
-                  then (dir </> s <$) <$> doesGlobMatch glob s
-                  else Nothing
+                if isFile
+                  then match
+                  else case match of
+                    Just (GlobMatch x) -> Just $ GlobMatchesDirectory x
+                    Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x
+                    Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x
+                    Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess
+                    Nothing -> Nothing
           )
           entries
     go (GlobDirRecursive glob) dir = do
       entries <- getDirectoryContentsRecursive (root </> dir)
       return $
-        mapMaybe (\s -> (dir </> s <$) <$> doesGlobMatch glob (takeFileName s)) entries
+        mapMaybe
+          ( \s -> do
+              globMatch <- doesGlobMatch glob (takeFileName s)
+              pure ((dir </> s) <$ globMatch)
+          )
+          entries
     go (GlobDir glob globPath) dir = do
       entries <- getDirectoryContents (root </> dir)
       subdirs <-
@@ -601,6 +627,8 @@ checkNameMatches spec glob candidate
   | otherwise = empty
 
 -- | How/does the glob match the given filepath, according to the cabal version?
+-- Since this is pure, we don't make a distinction between matching on
+-- directories or files (i.e. this function won't return 'GlobMatchesDirectory')
 fileGlobMatches :: CabalSpecVersion -> FilePathGlobRel -> FilePath -> Maybe (GlobResult ())
 fileGlobMatches version g path = go g (splitDirectories path)
   where

Cabal/src/Distribution/Simple/SrcDist.hs

@@ -245,12 +245,13 @@ 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)
     , -- Extra source files.
       fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
         matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath

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

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

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

@@ -0,0 +1,5 @@
+# cabal v2-sdist
+Warning: Ignoring directory '././actually-a-directory' listed in field 'data-files' in the Cabal package. This field can only include files (not directories).
+Warning: Ignoring directory './actually-a-directory' listed in field 'extra-source-files' in the Cabal package. This field can only include files (not directories).
+Warning: Ignoring directory './actually-a-directory' listed in field 'extra-doc-files' in the Cabal package. This field can only include files (not directories).
+Wrote source list to <TMPDIR>/t5195and5349-0.list

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