Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Remove read-only mark on dist-newstyle when doing cabal clean on Windows #10190

Merged
merged 1 commit into from
Sep 13, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
25 changes: 24 additions & 1 deletion cabal-install/src/Distribution/Client/CmdClean.hs
Original file line number Diff line number Diff line change
Expand Up @@ -52,6 +52,10 @@ import Distribution.Simple.Utils
, info
, wrapText
)
import Distribution.System
( OS (Windows)
, buildOS
)
import Distribution.Utils.Path hiding
( (<.>)
, (</>)
Expand All @@ -60,6 +64,9 @@ import Distribution.Verbosity
( normal
)

import Control.Exception
( throw
)
import Control.Monad
( forM
, forM_
Expand All @@ -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
Expand Down Expand Up @@ -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

Expand Down
21 changes: 20 additions & 1 deletion cabal-install/src/Distribution/Client/VCS.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 (..)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
@@ -0,0 +1,6 @@
cabal-version: 3.0
name: aa
version: 0.1.0.0
build-type: Simple

library
Original file line number Diff line number Diff line change
@@ -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
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
packages: .

source-repository-package
type: git
location: https://github.com/haskell-hvr/Only
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
import Test.Cabal.Prelude

main = cabalTest $ withProjectFile "cabal.project" $ do
void $ cabal' "build" ["--dry-run"]
void $ cabal' "clean" []
11 changes: 11 additions & 0 deletions changelog.d/pr-10190
Original file line number Diff line number Diff line change
@@ -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.

}
Loading