From 7d4f1529eab375a2bfcee3304db2bd30ea34b537 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Tue, 30 Aug 2022 00:29:24 +0100 Subject: [PATCH 1/5] Add check for recursive glob in root directory Such globs might be expensive to include, as they might pull unnecessary directories just like `.git` or `dist-newstyle`. --- .../Distribution/PackageDescription/Check.hs | 33 +++++++++++++++---- Cabal/src/Distribution/Simple/Glob.hs | 8 +++++ 2 files changed, 35 insertions(+), 6 deletions(-) diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index af5c0063fe7..24bff8fdfc2 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -1601,20 +1601,35 @@ checkPaths pkg = ++ [ PackageDistInexcusable $ GlobSyntaxError "data-files" (explainGlobSyntaxError pat err) - | pat <- dataFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] + | (Left err, pat) <- zip globsDataFiles $ dataFiles pkg ] ++ [ PackageDistInexcusable (GlobSyntaxError "extra-source-files" (explainGlobSyntaxError pat err)) - | pat <- extraSrcFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] + | (Left err, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg ] ++ [ PackageDistInexcusable $ GlobSyntaxError "extra-doc-files" (explainGlobSyntaxError pat err) - | pat <- extraDocFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] + | (Left err, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg + ] + ++ + [ PackageBuildWarning $ + GlobSyntaxError "data-files" err + | (Right glob, pat) <- zip globsDataFiles $ dataFiles pkg + , Left err <- [isRecursiveInRoot glob pat] + ] + ++ + [ PackageBuildWarning $ + GlobSyntaxError "extra-source-files" err + | (Right glob, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg + , Left err <- [isRecursiveInRoot glob pat] + ] + ++ + [ PackageBuildWarning $ + GlobSyntaxError "extra-doc-files" err + | (Right glob, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg + , Left err <- [isRecursiveInRoot glob pat] ] where isOutsideTree path = case splitDirectories path of @@ -1655,6 +1670,12 @@ checkPaths pkg = [ (path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi ] | bi <- allBuildInfo pkg ] + globsDataFiles :: [Either GlobSyntaxError Glob] + globsDataFiles = parseFileGlob (specVersion pkg) <$> dataFiles pkg + globsExtraSrcFiles :: [Either GlobSyntaxError Glob] + globsExtraSrcFiles = parseFileGlob (specVersion pkg) <$> extraSrcFiles pkg + globsExtraDocFiles :: [Either GlobSyntaxError Glob] + globsExtraDocFiles = parseFileGlob (specVersion pkg) <$> extraDocFiles pkg --TODO: check sets of paths that would be interpreted differently between Unix -- and windows, ie case-sensitive or insensitive. Things that might clash, or diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index de14f2db7ef..74cd952ee3c 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -23,6 +23,7 @@ module Distribution.Simple.Glob ( fileGlobMatches, parseFileGlob, explainGlobSyntaxError, + isRecursiveInRoot, Glob, ) where @@ -336,3 +337,10 @@ splitConstantPrefix = unfoldr' step where step (GlobStem seg pat) = Right (seg, pat) step (GlobFinal pat) = Left pat + +isRecursiveInRoot :: Glob -> FilePath -> Either String () +isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) path = + Left $ "File glob " ++ path ++ " starts at project root directory" ++ + " this might include `.git/`, ``dist-newstyle/``, or" ++ + " other large directories!" +isRecursiveInRoot _ _= Right () From 524797dc2816fc2d09dd856ec9fc97870b671ca0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Thu, 1 Sep 2022 00:03:25 +0100 Subject: [PATCH 2/5] Move expensive glob warning to its own constructor --- .../Distribution/PackageDescription/Check.hs | 23 +++++++++++-------- Cabal/src/Distribution/Simple/Glob.hs | 10 ++++---- 2 files changed, 18 insertions(+), 15 deletions(-) diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs index 24bff8fdfc2..06f78c51bc4 100644 --- a/Cabal/src/Distribution/PackageDescription/Check.hs +++ b/Cabal/src/Distribution/PackageDescription/Check.hs @@ -196,6 +196,7 @@ data CheckExplanation = | BadRelativePAth String FilePath String | DistPoint (Maybe String) FilePath | GlobSyntaxError String String + | RecursiveGlobInRoot String FilePath | InvalidOnWin [FilePath] | FilePathTooLong FilePath | FilePathNameTooLong FilePath @@ -532,6 +533,10 @@ ppExplanation (DistPoint mfield path) = mfield ppExplanation (GlobSyntaxError field expl) = "In the '" ++ field ++ "' field: " ++ expl +ppExplanation (RecursiveGlobInRoot field glob) = + "In the '" ++ field ++ "': glob '" ++ glob + ++ "' starts at project root directory, this might " + ++ "include `.git/`, ``dist-newstyle/``, or other large directories!" ppExplanation (InvalidOnWin paths) = "The " ++ quotes paths ++ " invalid on Windows, which " ++ "would cause portability problems for this package. Windows file " @@ -1614,22 +1619,22 @@ checkPaths pkg = | (Left err, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg ] ++ - [ PackageBuildWarning $ - GlobSyntaxError "data-files" err + [ PackageDistSuspiciousWarn $ + RecursiveGlobInRoot "data-files" pat | (Right glob, pat) <- zip globsDataFiles $ dataFiles pkg - , Left err <- [isRecursiveInRoot glob pat] + , isRecursiveInRoot glob ] ++ - [ PackageBuildWarning $ - GlobSyntaxError "extra-source-files" err + [ PackageDistSuspiciousWarn $ + RecursiveGlobInRoot "extra-source-files" pat | (Right glob, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg - , Left err <- [isRecursiveInRoot glob pat] + , isRecursiveInRoot glob ] ++ - [ PackageBuildWarning $ - GlobSyntaxError "extra-doc-files" err + [ PackageDistSuspiciousWarn $ + RecursiveGlobInRoot "extra-doc-files" pat | (Right glob, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg - , Left err <- [isRecursiveInRoot glob pat] + , isRecursiveInRoot glob ] where isOutsideTree path = case splitDirectories path of diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 74cd952ee3c..87d80bebadb 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -338,9 +338,7 @@ splitConstantPrefix = unfoldr' step step (GlobStem seg pat) = Right (seg, pat) step (GlobFinal pat) = Left pat -isRecursiveInRoot :: Glob -> FilePath -> Either String () -isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) path = - Left $ "File glob " ++ path ++ " starts at project root directory" ++ - " this might include `.git/`, ``dist-newstyle/``, or" ++ - " other large directories!" -isRecursiveInRoot _ _= Right () + +isRecursiveInRoot :: Glob ->Bool +isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True +isRecursiveInRoot _ = False From f7eee18016a0ba0722bbcf72d31c13f13926460c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Thu, 1 Sep 2022 00:13:42 +0100 Subject: [PATCH 3/5] Add changelog entry --- changelog.d/pr-8441 | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 changelog.d/pr-8441 diff --git a/changelog.d/pr-8441 b/changelog.d/pr-8441 new file mode 100644 index 00000000000..39e8feac2c5 --- /dev/null +++ b/changelog.d/pr-8441 @@ -0,0 +1,10 @@ +synopsis: Add warning about expensive globs +packages: Cabal +prs: #8441 +issues: #5311 +description: { + +- Now cabal check will emit a warning when package uses +recursive globs starting at root of the project + +} From 161b2bedb71b71d424d662fea2142bfbee0a532d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Thu, 1 Sep 2022 00:58:04 +0100 Subject: [PATCH 4/5] Add test for recursive glob warning --- .../Paths/RecursiveGlobInRoot/a.dat | 0 .../Paths/RecursiveGlobInRoot/a.md | 0 .../Paths/RecursiveGlobInRoot/cabal.out | 11 +++++++++++ .../Paths/RecursiveGlobInRoot/cabal.test.hs | 4 ++++ .../Paths/RecursiveGlobInRoot/pkg.cabal | 19 +++++++++++++++++++ 5 files changed, 34 insertions(+) create mode 100644 cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/a.dat create mode 100644 cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/a.md create mode 100644 cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.out create mode 100644 cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/pkg.cabal diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/a.dat b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/a.dat new file mode 100644 index 00000000000..e69de29bb2d diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/a.md b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/a.md new file mode 100644 index 00000000000..e69de29bb2d diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.out b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.out new file mode 100644 index 00000000000..a68021cb6f6 --- /dev/null +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.out @@ -0,0 +1,11 @@ +# cabal check +Warning: These warnings may cause trouble when distributing the package: +Warning: In the 'data-files': glob '**/*.dat' starts at project root +directory, this might include `.git/`, ``dist-newstyle/``, or other large +directories! +Warning: In the 'extra-source-files': glob '**/*.hs' starts at project root +directory, this might include `.git/`, ``dist-newstyle/``, or other large +directories! +Warning: In the 'extra-doc-files': glob '**/*.md' starts at project root +directory, this might include `.git/`, ``dist-newstyle/``, or other large +directories! \ No newline at end of file diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.test.hs b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.test.hs new file mode 100644 index 00000000000..60a32cb7374 --- /dev/null +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude + +main = cabalTest $ + cabal "check" [] diff --git a/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/pkg.cabal b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/pkg.cabal new file mode 100644 index 00000000000..0d069990536 --- /dev/null +++ b/cabal-testsuite/PackageTests/Check/ConfiguredPackage/Paths/RecursiveGlobInRoot/pkg.cabal @@ -0,0 +1,19 @@ +cabal-version: 3.8 +name: pkg +version: 0 +extra-source-files: + **/*.hs +data-files: + **/*.dat +extra-doc-files: + **/*.md +license: BSD-3-Clause +synopsis: no +description: none +category: Test +maintainer: none + +library + default-language: Haskell2010 + exposed-modules: + Foo From c3e6a0361d005fcd7dfb1fd2edaedc10ba6e4568 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Dybiec?= Date: Wed, 11 Jan 2023 01:20:52 +0000 Subject: [PATCH 5/5] Fix formatting --- Cabal/src/Distribution/Simple/Glob.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs index 87d80bebadb..2586ddd68e0 100644 --- a/Cabal/src/Distribution/Simple/Glob.hs +++ b/Cabal/src/Distribution/Simple/Glob.hs @@ -339,6 +339,6 @@ splitConstantPrefix = unfoldr' step step (GlobFinal pat) = Left pat -isRecursiveInRoot :: Glob ->Bool +isRecursiveInRoot :: Glob -> Bool isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True isRecursiveInRoot _ = False