diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 06f4e4e555d..aabb318e9d9 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 @@ -529,6 +535,24 @@ resolveBuildTimeSettings -- 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 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 a @FilePath@ that does not exist. + (const $ pure False) + ((||) <$> pathIsSymbolicLink filePath <*> doesPathExist filePath) + isUnusable <- isUsableAction + if isUnusable + then return ProjectRootUsabilityPresentAndUnusable + else return ProjectRootUsabilityNotPresent + -- | Find the root of this project. -- -- The project directory will be one of the following: @@ -552,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 @@ -566,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 @@ -597,34 +634,50 @@ 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 -> + 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 + = -- | 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..1996dab1a1d 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 @@ -116,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) @@ -137,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 = @@ -165,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/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/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. + +}