From 82d977afdf33d0297cad7fc5a8c180bf56e8827f Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 13 Sep 2024 01:01:36 +0200 Subject: [PATCH] Remove read-only and force-remove on Windows Some git files are marked as read-only. To ensure we delete the folders we are supposed to, we first remove the read-only attribute via `CMD.exe`, then we forcibly delete the relevant directory. --- .../src/Distribution/Client/CmdClean.hs | 25 ++++++++++++++++++- cabal-install/src/Distribution/Client/VCS.hs | 21 +++++++++++++++- .../CleanSourceRepositoryPackage/a.cabal | 6 +++++ .../CleanSourceRepositoryPackage/cabal.out | 6 +++++ .../cabal.project | 5 ++++ .../cabal.test.hs | 5 ++++ changelog.d/pr-10190 | 11 ++++++++ 7 files changed, 77 insertions(+), 2 deletions(-) create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/a.cabal create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.out create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.project create mode 100644 cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.test.hs create mode 100644 changelog.d/pr-10190 diff --git a/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal-install/src/Distribution/Client/CmdClean.hs index 2ffda4dce6a..a738f38336a 100644 --- a/cabal-install/src/Distribution/Client/CmdClean.hs +++ b/cabal-install/src/Distribution/Client/CmdClean.hs @@ -52,6 +52,10 @@ import Distribution.Simple.Utils , info , wrapText ) +import Distribution.System + ( OS (Windows) + , buildOS + ) import Distribution.Utils.Path hiding ( (<.>) , () @@ -60,6 +64,9 @@ import Distribution.Verbosity ( normal ) +import Control.Exception + ( throw + ) import Control.Monad ( forM , forM_ @@ -74,10 +81,15 @@ import System.Directory , listDirectory , removeDirectoryRecursive , removeFile + , removePathForcibly ) import System.FilePath ( () ) +import System.IO.Error + ( isPermissionError + ) +import qualified System.Process as Process data CleanFlags = CleanFlags { cleanSaveConfig :: Flag Bool @@ -168,7 +180,18 @@ cleanAction (ProjectFlags{..}, CleanFlags{..}) extraArgs _ = do let distRoot = distDirectory distLayout info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") - handleDoesNotExist () $ removeDirectoryRecursive distRoot + handleDoesNotExist () $ do + if buildOS == Windows + then do + -- Windows can't delete some git files #10182 + void $ + Process.createProcess_ "attrib" $ + Process.shell $ + "attrib -s -h -r " <> distRoot <> "\\*.* /s /d" + catch + (removePathForcibly distRoot) + (\e -> if isPermissionError e then removePathForcibly distRoot else throw e) + else removeDirectoryRecursive distRoot removeEnvFiles $ distProjectRootDirectory distLayout diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 2f2686c6ae2..57c0a82376e 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -64,6 +64,10 @@ import Distribution.Simple.Program import Distribution.Simple.Program.Db ( prependProgramSearchPath ) +import Distribution.System + ( OS (Windows) + , buildOS + ) import Distribution.Types.SourceRepo ( KnownRepoType (..) , RepoType (..) @@ -93,6 +97,7 @@ import qualified Data.Map as Map import System.Directory ( doesDirectoryExist , removeDirectoryRecursive + , removePathForcibly ) import System.FilePath ( takeDirectory @@ -100,7 +105,9 @@ import System.FilePath ) import System.IO.Error ( isDoesNotExistError + , isPermissionError ) +import qualified System.Process as Process -- | A driver for a version control system, e.g. git, darcs etc. data VCS program = VCS @@ -509,7 +516,19 @@ vcsGit = git localDir ["submodule", "deinit", "--force", "--all"] let gitModulesDir = localDir ".git" "modules" gitModulesExists <- doesDirectoryExist gitModulesDir - when gitModulesExists $ removeDirectoryRecursive gitModulesDir + when gitModulesExists $ + if buildOS == Windows + then do + -- Windows can't delete some git files #10182 + void $ + Process.createProcess_ "attrib" $ + Process.shell $ + "attrib -s -h -r " <> gitModulesDir <> "\\*.* /s /d" + + catch + (removePathForcibly gitModulesDir) + (\e -> if isPermissionError e then removePathForcibly gitModulesDir else throw e) + else removeDirectoryRecursive gitModulesDir git localDir resetArgs git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/a.cabal b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/a.cabal new file mode 100644 index 00000000000..77f47fbbcf5 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/a.cabal @@ -0,0 +1,6 @@ +cabal-version: 3.0 +name: aa +version: 0.1.0.0 +build-type: Simple + +library diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.out b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.out new file mode 100644 index 00000000000..e4f538647f6 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.out @@ -0,0 +1,6 @@ +# cabal build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following would be built: + - aa-0.1.0.0 (lib) (first run) +# cabal clean diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.project b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.project new file mode 100644 index 00000000000..60739ea84dd --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.project @@ -0,0 +1,5 @@ +packages: . + +source-repository-package + type: git + location: https://github.com/haskell-hvr/Only diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.test.hs b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.test.hs new file mode 100644 index 00000000000..9e93c607ce4 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewBuild/CmdClean/CleanSourceRepositoryPackage/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = cabalTest $ withProjectFile "cabal.project" $ do + void $ cabal' "build" ["--dry-run"] + void $ cabal' "clean" [] diff --git a/changelog.d/pr-10190 b/changelog.d/pr-10190 new file mode 100644 index 00000000000..d9e4f009b94 --- /dev/null +++ b/changelog.d/pr-10190 @@ -0,0 +1,11 @@ +synopsis: Fix `cabal clean` permissions on Windows +packages: cabal-install +prs: #10190 +issues: #10182 +significance: + +description: { + +- `cabal clean` now removes the read-only mark recursively in the `dist-newstyle` folder on Windows before attempting to delete it. + +}