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.
geekosaur · Sep 12, 2024 · 82d977a · 82d977a
1 parent 1077091
commit 82d977a
Show file tree

Hide file tree

Showing 7 changed files with 77 additions and 2 deletions.
diff --git 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
@@ -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,14 +97,17 @@ import qualified Data.Map as Map
 import System.Directory
   ( doesDirectoryExist
   , removeDirectoryRecursive
+  , removePathForcibly
   )
 import System.FilePath
   ( takeDirectory
   , (</>)
   )
 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
@@ -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
@@ -0,0 +1,6 @@
+# cabal build
+Resolving dependencies...
+Build profile: -w ghc-<GHCVER> -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
@@ -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
@@ -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
@@ -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.
+
+}