Skip to content
Snippets Groups Projects
Commit 82d977af authored by Javier Sagredo's avatar Javier Sagredo
Browse files

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.
parent 10770916
No related branches found
No related tags found
No related merge requests found
......@@ -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
......
......@@ -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
......
cabal-version: 3.0
name: aa
version: 0.1.0.0
build-type: Simple
library
# 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
packages: .
source-repository-package
type: git
location: https://github.com/haskell-hvr/Only
import Test.Cabal.Prelude
main = cabalTest $ withProjectFile "cabal.project" $ do
void $ cabal' "build" ["--dry-run"]
void $ cabal' "clean" []
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.
}
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment