From 66110b437deb809468042fe729d4705e1ac06eea Mon Sep 17 00:00:00 2001 From: Alberto Fanton Date: Mon, 10 Jun 2024 18:20:20 +0200 Subject: [PATCH 1/4] Add ProjectRootUsability datatype --- .../src/Distribution/Client/ProjectConfig.hs | 40 +++++++++++++++++-- .../Distribution/Client/ProjectConfig.hs | 26 ++++++++++++ .../cabal.project.dir.broken/.gitkeep | 0 .../project-root/cabal.project.symlink | 1 + .../project-root/cabal.project.symlink.broken | 1 + .../project-root/lib/cabal.project.symlink | 1 + .../lib/cabal.project.symlink.broken | 1 + 7 files changed, 66 insertions(+), 4 deletions(-) create mode 100644 cabal-install/tests/fixtures/project-root/cabal.project.dir.broken/.gitkeep create mode 120000 cabal-install/tests/fixtures/project-root/cabal.project.symlink create mode 120000 cabal-install/tests/fixtures/project-root/cabal.project.symlink.broken create mode 120000 cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink create mode 120000 cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink.broken diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 06f4e4e555d..b78e8d55cb3 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- | Handling project configuration. module Distribution.Client.ProjectConfig @@ -18,8 +19,10 @@ module Distribution.Client.ProjectConfig -- * Project root , findProjectRoot + , getProjectRootUsability , ProjectRoot (..) - , BadProjectRoot + , BadProjectRoot (..) + , ProjectRootUsability (..) -- * Project config files , readProjectConfig @@ -196,6 +199,7 @@ import qualified Codec.Archive.Tar.Entry as Tar import qualified Distribution.Client.GZipUtils as GZipUtils import qualified Distribution.Client.Tar as Tar +import Control.Exception (handle) import Control.Monad.Trans (liftIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS @@ -215,9 +219,11 @@ import System.Directory ( canonicalizePath , doesDirectoryExist , doesFileExist + , doesPathExist , getCurrentDirectory , getDirectoryContents , getHomeDirectory + , pathIsSymbolicLink ) import System.FilePath hiding (combine) import System.IO @@ -526,8 +532,24 @@ resolveBuildTimeSettings | otherwise = False --------------------------------------------- --- Reading and writing project config files --- + +-- | Get @ProjectRootUsability@ of a given file +getProjectRootUsability :: FilePath -> IO ProjectRootUsability +getProjectRootUsability filePath = do + exists <- doesFileExist filePath + if exists + then return ProjectRootUsabilityPresentAndUsable + else do + let isUsableAciton = + handle @IOException + -- NOTE: if any IOException is raised, we assume the file does not exist. + -- That is what happen when we call @pathIsSymbolicLink@ on an @FilePath@ + (const $ pure False) + ((||) <$> pathIsSymbolicLink filePath <*> doesPathExist filePath) + isUnusable <- isUsableAciton + if isUnusable + then return ProjectRootUsabilityPresentAndUnusable + else return ProjectRootUsabilityNotPresent -- | Find the root of this project. -- @@ -624,7 +646,17 @@ renderBadProjectRoot = \case BadProjectRootAbsoluteFile file -> "The given project file '" <> file <> "' does not exist." BadProjectRootDirFile dir file -> - "The given project directory/file combination '" <> dir file <> "' does not exist." + "The given projectdirectory/file combination '" <> dir file <> "' does not exist." + +-- | State of the project file, encodes if the file can be used +data ProjectRootUsability + = -- | The file is present and can be used + ProjectRootUsabilityPresentAndUsable + | -- | The file is present but can't be used (e.g. broken symlink) + ProjectRootUsabilityPresentAndUnusable + | -- | The file is not present + ProjectRootUsabilityNotPresent + deriving (Eq, Show) withGlobalConfig :: Verbosity diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 9b7c31e2376..6ff2ce0a129 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -98,6 +98,7 @@ tests = , testProperty "specific" prop_roundtrip_printparse_specific , testProperty "all" prop_roundtrip_printparse_all ] + , testGetProjectRootUsability , testFindProjectRoot ] where @@ -106,6 +107,31 @@ tests = CompilerId GHC v -> v < mkVersion [7, 7] _ -> False +testGetProjectRootUsability :: TestTree +testGetProjectRootUsability = + testGroup + "getProjectRootUsability" + [ test "relative path" file ProjectRootUsabilityPresentAndUsable + , test "absolute path" absFile ProjectRootUsabilityPresentAndUsable + , test "symbolic link" fileSymlink ProjectRootUsabilityPresentAndUsable + , test "file not present" fileNotPresent ProjectRootUsabilityNotPresent + , test "directory" brokenDirCabalProject ProjectRootUsabilityPresentAndUnusable + , test "broken symbolic link" fileSymlinkBroken ProjectRootUsabilityPresentAndUnusable + ] + where + dir = fixturesDir "project-root" + file = defaultProjectFile + absFile = dir file + fileNotPresent = file <.> "not-present" + fileSymlink = file <.> "symlink" + fileSymlinkBroken = fileSymlink <.> "broken" + brokenDirCabalProject = "cabal" <.> "project" <.> "dir" <.> "broken" + test name fileName expectedState = + testCase name $ + withCurrentDirectory dir $ + getProjectRootUsability fileName >>= + (@?= expectedState) + testFindProjectRoot :: TestTree testFindProjectRoot = testGroup diff --git a/cabal-install/tests/fixtures/project-root/cabal.project.dir.broken/.gitkeep b/cabal-install/tests/fixtures/project-root/cabal.project.dir.broken/.gitkeep new file mode 100644 index 00000000000..e69de29bb2d diff --git a/cabal-install/tests/fixtures/project-root/cabal.project.symlink b/cabal-install/tests/fixtures/project-root/cabal.project.symlink new file mode 120000 index 00000000000..b4c9ceac597 --- /dev/null +++ b/cabal-install/tests/fixtures/project-root/cabal.project.symlink @@ -0,0 +1 @@ +cabal.project \ No newline at end of file diff --git a/cabal-install/tests/fixtures/project-root/cabal.project.symlink.broken b/cabal-install/tests/fixtures/project-root/cabal.project.symlink.broken new file mode 120000 index 00000000000..cfa0a46515b --- /dev/null +++ b/cabal-install/tests/fixtures/project-root/cabal.project.symlink.broken @@ -0,0 +1 @@ +does-not-exist \ No newline at end of file diff --git a/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink b/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink new file mode 120000 index 00000000000..b4c9ceac597 --- /dev/null +++ b/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink @@ -0,0 +1 @@ +cabal.project \ No newline at end of file diff --git a/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink.broken b/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink.broken new file mode 120000 index 00000000000..cfa0a46515b --- /dev/null +++ b/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink.broken @@ -0,0 +1 @@ +does-not-exist \ No newline at end of file From 01e335b9c7c6b06cd423a4943969005a8e75f6ba Mon Sep 17 00:00:00 2001 From: Alberto Fanton Date: Tue, 11 Jun 2024 10:28:51 +0200 Subject: [PATCH 2/4] Make findProjectRoot aware of broken files --- .../src/Distribution/Client/ProjectConfig.hs | 74 ++++++++++++------- .../Distribution/Client/ProjectConfig.hs | 23 +++++- .../project-root/lib/cabal.project.symlink | 1 - .../lib/cabal.project.symlink.broken | 1 - 4 files changed, 69 insertions(+), 30 deletions(-) delete mode 120000 cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink delete mode 120000 cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink.broken diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index b78e8d55cb3..215fc3ffbde 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -532,6 +532,8 @@ resolveBuildTimeSettings | otherwise = False --------------------------------------------- +-- Reading and writing project config files +-- -- | Get @ProjectRootUsability@ of a given file getProjectRootUsability :: FilePath -> IO ProjectRootUsability @@ -543,7 +545,7 @@ getProjectRootUsability filePath = do let isUsableAciton = handle @IOException -- NOTE: if any IOException is raised, we assume the file does not exist. - -- That is what happen when we call @pathIsSymbolicLink@ on an @FilePath@ + -- That is what happen when we call @pathIsSymbolicLink@ on an @FilePath@ that does not exist. (const $ pure False) ((||) <$> pathIsSymbolicLink filePath <*> doesPathExist filePath) isUnusable <- isUsableAciton @@ -574,13 +576,18 @@ findProjectRoot verbosity mprojectDir mprojectFile = do "Specifying an absolute path to the project file is deprecated." <> " Use --project-dir to set the project's directory." - doesFileExist file >>= \case - False -> left (BadProjectRootExplicitFile file) - True -> uncurry projectRoot =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file + getProjectRootUsability file >>= \case + ProjectRootUsabilityPresentAndUsable -> + uncurry projectRoot + =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file + ProjectRootUsabilityNotPresent -> + left (BadProjectRootExplicitFileNotFound file) + ProjectRootUsabilityPresentAndUnusable -> + left (BadProjectRootFileBroken file) | otherwise -> probeProjectRoot mprojectFile Just dir -> doesDirectoryExist dir >>= \case - False -> left (BadProjectRootDir dir) + False -> left (BadProjectRootDirNotFound dir) True -> do projectDir <- canonicalizePath dir @@ -588,13 +595,21 @@ findProjectRoot verbosity mprojectDir mprojectFile = do Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile) Just projectFile | isAbsolute projectFile -> - doesFileExist projectFile >>= \case - False -> left (BadProjectRootAbsoluteFile projectFile) - True -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile + getProjectRootUsability projectFile >>= \case + ProjectRootUsabilityNotPresent -> + left (BadProjectRootAbsoluteFileNotFound projectFile) + ProjectRootUsabilityPresentAndUsable -> + Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile + ProjectRootUsabilityPresentAndUnusable -> + left (BadProjectRootFileBroken projectFile) | otherwise -> - doesFileExist (projectDir projectFile) >>= \case - False -> left (BadProjectRootDirFile dir projectFile) - True -> projectRoot projectDir projectFile + getProjectRootUsability (projectDir projectFile) >>= \case + ProjectRootUsabilityNotPresent -> + left (BadProjectRootDirFileNotFound dir projectFile) + ProjectRootUsabilityPresentAndUsable -> + projectRoot projectDir projectFile + ProjectRootUsabilityPresentAndUnusable -> + left (BadProjectRootFileBroken projectFile) where left = pure . Left @@ -619,34 +634,41 @@ probeProjectRoot mprojectFile = do go dir | isDrive dir || dir == homedir = case mprojectFile of Nothing -> return (Right (ProjectRootImplicit startdir)) - Just file -> return (Left (BadProjectRootExplicitFile file)) + Just file -> return (Left (BadProjectRootExplicitFileNotFound file)) go dir = do - exists <- doesFileExist (dir projectFileName) - if exists - then return (Right (ProjectRootExplicit dir projectFileName)) - else go (takeDirectory dir) + getProjectRootUsability (dir projectFileName) >>= \case + ProjectRootUsabilityNotPresent -> + go (takeDirectory dir) + ProjectRootUsabilityPresentAndUsable -> + return (Right $ ProjectRootExplicit dir projectFileName) + ProjectRootUsabilityPresentAndUnusable -> + return (Left $ BadProjectRootFileBroken projectFileName) -- | Errors returned by 'findProjectRoot'. data BadProjectRoot - = BadProjectRootExplicitFile FilePath - | BadProjectRootDir FilePath - | BadProjectRootAbsoluteFile FilePath - | BadProjectRootDirFile FilePath FilePath - deriving (Show, Typeable) + = BadProjectRootExplicitFileNotFound FilePath + | BadProjectRootDirNotFound FilePath + | BadProjectRootAbsoluteFileNotFound FilePath + | BadProjectRootDirFileNotFound FilePath FilePath + | BadProjectRootFileBroken FilePath + + deriving (Show, Typeable, Eq) instance Exception BadProjectRoot where displayException = renderBadProjectRoot renderBadProjectRoot :: BadProjectRoot -> String renderBadProjectRoot = \case - BadProjectRootExplicitFile projectFile -> + BadProjectRootExplicitFileNotFound projectFile -> "The given project file '" ++ projectFile ++ "' does not exist." - BadProjectRootDir dir -> + BadProjectRootDirNotFound dir -> "The given project directory '" <> dir <> "' does not exist." - BadProjectRootAbsoluteFile file -> + BadProjectRootAbsoluteFileNotFound file -> "The given project file '" <> file <> "' does not exist." - BadProjectRootDirFile dir file -> - "The given projectdirectory/file combination '" <> dir file <> "' does not exist." + BadProjectRootDirFileNotFound dir file -> + "The given project directory/file combination '" <> dir file <> "' does not exist." + BadProjectRootFileBroken file -> + "The given project file '" <> file <> "' is broken. Is it a broken symbolic link?" -- | State of the project file, encodes if the file can be used data ProjectRootUsability diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 6ff2ce0a129..1996dab1a1d 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -129,8 +129,8 @@ testGetProjectRootUsability = test name fileName expectedState = testCase name $ withCurrentDirectory dir $ - getProjectRootUsability fileName >>= - (@?= expectedState) + getProjectRootUsability fileName + >>= (@?= expectedState) testFindProjectRoot :: TestTree testFindProjectRoot = @@ -142,6 +142,10 @@ testFindProjectRoot = , test "explicit file in lib" (cd libDir) Nothing (Just file) (succeeds dir file) , test "other file" (cd dir) Nothing (Just fileOther) (succeeds dir fileOther) , test "other file in lib" (cd libDir) Nothing (Just fileOther) (succeeds dir fileOther) + , test "symbolic link" (cd dir) Nothing (Just fileSymlink) (succeeds dir fileSymlink) + , test "symbolic link in lib" (cd libDir) Nothing (Just fileSymlink) (succeeds dir fileSymlink) + , test "broken symbolic link" (cd dir) Nothing (Just fileSymlinkBroken) (failsWith $ BadProjectRootFileBroken fileSymlinkBroken) + , test "broken symbolic link in lib" (cd libDir) Nothing (Just fileSymlinkBroken) (failsWith $ BadProjectRootFileBroken fileSymlinkBroken) , -- Deprecated use-case test "absolute file" Nothing Nothing (Just absFile) (succeeds dir file) , test "nested file" (cd dir) Nothing (Just nixFile) (succeeds dir nixFile) @@ -163,6 +167,9 @@ testFindProjectRoot = nixFile = "nix" file nixOther = nixFile <.> "other" + fileSymlink = file <.> "symlink" + fileSymlinkBroken = fileSymlink <.> "broken" + missing path = Just (path <.> "does_not_exist") test name wrap projectDir projectFile validate = @@ -191,6 +198,18 @@ testFindProjectRoot = Left _ -> pure () Right x -> assertFailure $ "Expected an error, but found " <> show x + failsWith expectedError result = case result of + Left actualError -> + if actualError == expectedError + then pure () + else + assertFailure $ + "Expected an error " + <> show expectedError + <> ", but found " + <> show actualError + Right x -> assertFailure $ "Expected an error, but found " <> show x + fixturesDir :: FilePath fixturesDir = unsafePerformIO $ diff --git a/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink b/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink deleted file mode 120000 index b4c9ceac597..00000000000 --- a/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink +++ /dev/null @@ -1 +0,0 @@ -cabal.project \ No newline at end of file diff --git a/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink.broken b/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink.broken deleted file mode 120000 index cfa0a46515b..00000000000 --- a/cabal-install/tests/fixtures/project-root/lib/cabal.project.symlink.broken +++ /dev/null @@ -1 +0,0 @@ -does-not-exist \ No newline at end of file From 22fbc138d073a4e56e8208c3e6c77ad7a588f36b Mon Sep 17 00:00:00 2001 From: Alberto Fanton Date: Thu, 13 Jun 2024 21:58:31 +0200 Subject: [PATCH 3/4] Add changelog entry --- changelog.d/pr-10103 | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 changelog.d/pr-10103 diff --git a/changelog.d/pr-10103 b/changelog.d/pr-10103 new file mode 100644 index 00000000000..3e68cf38d3c --- /dev/null +++ b/changelog.d/pr-10103 @@ -0,0 +1,14 @@ +synopsis: Enhance error detection for cabal root project files, including broken symlinks + +packages: cabal-install + +prs: #10103 + +issues: #9937 + +description: { + +- Added proper detection and reporting for issues with cabal root project files. Previously, these files were silently ignored if they were broken symlinks. Now, `cabal` will exit +with an error in such case. + +} From 908e57ef9eff4243a79c4490ca79ccc6a635a667 Mon Sep 17 00:00:00 2001 From: Alberto Fanton Date: Thu, 25 Jul 2024 17:55:10 +0200 Subject: [PATCH 4/4] Fix typos --- cabal-install/src/Distribution/Client/ProjectConfig.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 215fc3ffbde..aabb318e9d9 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -542,13 +542,13 @@ getProjectRootUsability filePath = do if exists then return ProjectRootUsabilityPresentAndUsable else do - let isUsableAciton = + let isUsableAction = handle @IOException -- NOTE: if any IOException is raised, we assume the file does not exist. - -- That is what happen when we call @pathIsSymbolicLink@ on an @FilePath@ that does not exist. + -- That is what happen when we call @pathIsSymbolicLink@ on a @FilePath@ that does not exist. (const $ pure False) ((||) <$> pathIsSymbolicLink filePath <*> doesPathExist filePath) - isUnusable <- isUsableAciton + isUnusable <- isUsableAction if isUnusable then return ProjectRootUsabilityPresentAndUnusable else return ProjectRootUsabilityNotPresent @@ -651,7 +651,6 @@ data BadProjectRoot | BadProjectRootAbsoluteFileNotFound FilePath | BadProjectRootDirFileNotFound FilePath FilePath | BadProjectRootFileBroken FilePath - deriving (Show, Typeable, Eq) instance Exception BadProjectRoot where