diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs
index 9a97b1d3cca2d80d598ec4f127262175d3e2d78c..60a8414f7caf5f330b34f26b3f86797acb8a11c3 100644
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@@ -1387,8 +1387,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq
- race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupGHCupTmp)
- (threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{tmpDir} manually|]))
+ race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
+ (threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{recycleDir} manually|]))
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
@@ -1422,6 +1422,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- Effect interpreters --
-------------------------
+
let runInstTool' appstate' mInstPlatform =
runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
diff --git a/lib/GHCup.hs b/lib/GHCup.hs
index e1fd84614bea9b1ab6d5db728903e35e99a52272..cc33ace78ecd11ddae1814cdf32823cf5cad687f 100644
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@@ -252,22 +252,6 @@ installPackedGHC :: ( MonadMask m
#endif
] m ()
installPackedGHC dl msubdir inst ver = do
-#if defined(IS_WINDOWS)
- lift $ $(logInfo) "Installing GHC (this may take a while)"
-
- Dirs { tmpDir } <- lift getDirs
- unpackDir <- liftIO $ emptyTempFile tmpDir "ghc"
- lift $ rmFile unpackDir
-
- liftE $ unpackToDir unpackDir dl
-
- d <- case msubdir of
- Just td -> liftE $ intoSubdir unpackDir td
- Nothing -> pure unpackDir
-
- liftIO $ Win32.moveFileEx d (Just inst) 0
- lift $ rmPathForcibly unpackDir
-#else
PlatformRequest {..} <- lift getPlatformReq
-- unpack
@@ -283,7 +267,6 @@ installPackedGHC dl msubdir inst ver = do
liftE $ runBuildAction tmpUnpack
(Just inst)
(installUnpackedGHC workdir inst ver)
-#endif
-- | Install an unpacked GHC distribution. This only deals with the GHC
@@ -301,7 +284,21 @@ installUnpackedGHC :: ( MonadReader env m
-> Version -- ^ The GHC version
-> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver = do
+#if defined(IS_WINDOWS)
+ lift $ $(logInfo) "Installing GHC (this may take a while)"
+ -- Windows bindists are relocatable and don't need
+ -- to run configure.
+ -- We also must make sure to preserve mtime to not confuse ghc-pkg.
+ liftIO $ flip onException (recyclePathForcibly dest) $ copyDirectoryRecursive path inst $ \source dest -> do
+ mtime <- getModificationTime source
+ copyFile source dest
+ setModificationTime dest mtime
+#else
PlatformRequest {..} <- lift getPlatformReq
+ liftIO $ copyDirectoryRecursive path inst $ \source dest -> do
+ mtime <- getModificationTime source
+ copyFile source dest
+ setModificationTime dest mtime
let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
@@ -312,9 +309,6 @@ installUnpackedGHC path inst ver = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst)
-#if defined(IS_WINDOWS)
- : "--enable-tarballs-autodownload"
-#endif
: alpineArgs
)
(Just path)
@@ -322,6 +316,7 @@ installUnpackedGHC path inst ver = do
Nothing
lEM $ make ["install"] (Just path)
pure ()
+#endif
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@@ -1310,7 +1305,7 @@ rmGHCVer ver = do
-- then fix them (e.g. with an earlier version)
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
- lift $ rmPathForcibly dir
+ lift $ recyclePathForcibly dir
v' <-
handle
@@ -1322,9 +1317,7 @@ rmGHCVer ver = do
Dirs {..} <- lift getDirs
- lift
- $ hideError doesNotExistErrorType
- $ rmFile (baseDir </> "share")
+ lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
-- | Delete a cabal version. Will try to fix the @cabal@ symlink
@@ -1349,7 +1342,7 @@ rmCabalVer ver = do
Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
- lift $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
+ lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)
when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals
@@ -1380,7 +1373,7 @@ rmHLSVer ver = do
Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver
- forM_ bins $ \f -> lift $ rmFile (binDir </> f)
+ forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
when (Just ver == isHlsSet) $ do
-- delete all set symlinks
@@ -1418,7 +1411,7 @@ rmStackVer ver = do
Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
- lift $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
+ lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)
when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks
@@ -1459,12 +1452,12 @@ rmGhcup = do
unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#if defined(IS_WINDOWS)
- -- since it doesn't seem possible to delete a running exec in windows
+ -- since it doesn't seem possible to delete a running exe on windows
-- we move it to temp dir, to be deleted at next reboot
- let tempFilepath = tmpDir </> ghcupFilename
+ tempFilepath <- mkGhcupTmpDir
hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $
- Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
+ Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
#else
-- delete it.
hideError doesNotExistErrorType $ rmFile ghcupFilepath
@@ -1512,7 +1505,7 @@ rmGhcupDirs = do
, binDir
, logsDir
, cacheDir
- , tmpDir
+ , recycleDir
} <- getDirs
let envFilePath = baseDir </> "env"
@@ -1524,7 +1517,7 @@ rmGhcupDirs = do
rmDir cacheDir
rmDir logsDir
rmBinDir binDir
- rmDir tmpDir
+ rmDir recycleDir
#if defined(IS_WINDOWS)
rmDir (baseDir </> "msys64")
#endif
@@ -1607,7 +1600,7 @@ rmGhcupDirs = do
hideError UnsatisfiedConstraints $
handleIO' InappropriateType
(handleIfSym filepath)
- (liftIO $ rmPath filepath)
+ (liftIO $ rmDirectory filepath)
where
handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp
@@ -2136,27 +2129,14 @@ upgradeGHCup mtarget force' = do
let fn = "ghcup" <> exeExt
p <- liftE $ download dli tmp (Just fn)
let destDir = takeDirectory destFile
- destFile = fromMaybe (binDir </> fn <> exeExt) mtarget
+ destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) [i|mkdir -p #{destDir}|]
liftIO $ createDirRecursive' destDir
-#if defined(IS_WINDOWS)
- let tempGhcup = tmpDir </> "ghcup.old"
- lift $ hideError NoSuchThing $ rmFile tempGhcup
-
- lift $ $(logDebug) [i|mv #{destFile} #{tempGhcup}|]
- -- NoSuchThing may be raised when we're updating ghcup from
- -- a non-standard location
- liftIO $ hideError NoSuchThing $ Win32.moveFileEx destFile (Just tempGhcup) 0
- lift $ $(logDebug) [i|cp #{p} #{destFile}|]
- handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
- destFile
-#else
lift $ $(logDebug) [i|rm -f #{destFile}|]
- lift $ hideError NoSuchThing $ rmFile destFile
+ lift $ hideError NoSuchThing $ recycleFile destFile
lift $ $(logDebug) [i|cp #{p} #{destFile}|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile
-#endif
lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $
diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs
index 8f19ccb33bd899b3dc058536a9a370d439c0948d..c1046bd30a45698cb3ecdb475af14d22a2da0533 100644
--- a/lib/GHCup/Download.hs
+++ b/lib/GHCup/Download.hs
@@ -265,7 +265,7 @@ getBase uri = do
pure bs
dlWithoutMod json_file = do
bs <- liftE $ downloadBS uri'
- lift $ hideError doesNotExistErrorType $ rmFile json_file
+ lift $ hideError doesNotExistErrorType $ recycleFile json_file
liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
pure bs
@@ -388,10 +388,10 @@ download dli dest mfn
-- download
flip onException
- (lift $ hideError doesNotExistErrorType $ rmFile destFile)
+ (lift $ hideError doesNotExistErrorType $ recycleFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e ->
- lift (hideError doesNotExistErrorType $ rmFile destFile)
+ lift (hideError doesNotExistErrorType $ recycleFile destFile)
>> (throwE . DownloadFailed $ e)
) $ do
Settings{ downloader, noNetwork } <- lift getSettings
diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs
index 284b47d2587a67d4fa95e1d19d30c7d4d58bb8c9..762cb30119935daeee3aac17be6fe6aa69b3a0ef 100644
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -384,7 +384,7 @@ data Dirs = Dirs
, cacheDir :: FilePath
, logsDir :: FilePath
, confDir :: FilePath
- , tmpDir :: FilePath
+ , recycleDir :: FilePath -- mainly used on windows
}
deriving (Show, GHC.Generic)
diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs
index eb2228e1567cb37ff97a2a54c095f80e7a951e8e..e5e68d30a25cca1dce4b962886f7400b2b7baad1 100644
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@@ -53,6 +53,7 @@ import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
hiding ( throwM )
+import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#if defined(IS_WINDOWS)
import Data.Bits
#endif
@@ -886,8 +887,17 @@ getChangeLog dls tool (Right tag) =
--
-- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed
-runBuildAction :: (Pretty (V e), Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
- => FilePath -- ^ build directory (cleaned up depending on Settings)
+runBuildAction :: ( Pretty (V e)
+ , Show (V e)
+ , MonadReader env m
+ , HasDirs env
+ , HasSettings env
+ , MonadIO m
+ , MonadMask m
+ , MonadLogger m
+ , MonadUnliftIO m
+ )
+ => FilePath -- ^ build directory (cleaned up depending on Settings)
-> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a
-> Excepts '[BuildFailed] m a
@@ -895,11 +905,9 @@ runBuildAction bdir instdir action = do
Settings {..} <- lift getSettings
let exAction = do
forM_ instdir $ \dir ->
- lift $ hideError doesNotExistErrorType $ rmPathForcibly dir
+ lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
when (keepDirs == Never)
- $ lift
- $ hideError doesNotExistErrorType
- $ rmPathForcibly bdir
+ $ lift $ rmBDir bdir
v <-
flip onException exAction
$ catchAllE
@@ -908,10 +916,20 @@ runBuildAction bdir instdir action = do
throwE (BuildFailed bdir es)
) action
- when (keepDirs == Never || keepDirs == Errors) $ lift $ rmPathForcibly bdir
+ when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
pure v
+-- | Remove a build directory, ignoring if it doesn't exist and gracefully
+-- printing other errors without crashing.
+rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
+rmBDir dir = withRunInIO (\run -> run $
+ liftIO $ handleIO (\e -> run $ $(logWarn)
+ [i|Couldn't remove build dir #{dir}, error was: #{displayException e}|])
+ $ hideError doesNotExistErrorType
+ $ rmPathForcibly dir)
+
+
getVersionInfo :: Version
-> Tool
-> GHCupDownloads
@@ -1001,10 +1019,10 @@ pathIsLink = pathIsSymbolicLink
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
#if defined(IS_WINDOWS)
rmLink fp = do
- hideError doesNotExistErrorType . rmFile $ fp
- hideError doesNotExistErrorType . rmFile $ (dropExtension fp <.> "shim")
+ hideError doesNotExistErrorType . recycleFile $ fp
+ hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
#else
-rmLink = hideError doesNotExistErrorType . rmFile
+rmLink = hideError doesNotExistErrorType . recycleFile
#endif
@@ -1049,7 +1067,7 @@ createLink link exe = do
liftIO $ writeFile shim shimContents
#else
$(logDebug) [i|rm -f #{exe}|]
- hideError doesNotExistErrorType $ rmFile exe
+ hideError doesNotExistErrorType $ recycleFile exe
$(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe
@@ -1078,7 +1096,7 @@ ensureGlobalTools = do
void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|]
- lift $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
+ lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure ()
@@ -1089,14 +1107,14 @@ ensureGlobalTools = do
-- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
createDirRecursive' baseDir
createDirRecursive' (baseDir </> "ghc")
createDirRecursive' binDir
createDirRecursive' cacheDir
createDirRecursive' logsDir
createDirRecursive' confDir
- createDirRecursive' tmpDir
+ createDirRecursive' trashDir
pure ()
@@ -1110,4 +1128,3 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
-
diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs
index 3d25063fbb2864e3a42224c9bb1080f96b2cc693..a1cf1acf1274036715ffe47f95f9d1cbf30298a3 100644
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@@ -30,7 +30,7 @@ module GHCup.Utils.Dirs
#if !defined(IS_WINDOWS)
, useXDG
#endif
- , cleanupGHCupTmp
+ , cleanupTrash
)
where
@@ -190,23 +190,21 @@ ghcupLogsDir = do
#endif
--- | Defaults to '~/.ghcup/tmp.
---
--- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
--- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec.
-ghcupTmpDir :: IO FilePath
-ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
+-- | '~/.ghcup/trash'.
+-- Mainly used on windows to improve file removal operations
+ghcupRecycleDir :: IO FilePath
+ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
getAllDirs :: IO Dirs
getAllDirs = do
- baseDir <- ghcupBaseDir
- binDir <- ghcupBinDir
- cacheDir <- ghcupCacheDir
- logsDir <- ghcupLogsDir
- confDir <- ghcupConfigDir
- tmpDir <- ghcupTmpDir
+ baseDir <- ghcupBaseDir
+ binDir <- ghcupBinDir
+ cacheDir <- ghcupCacheDir
+ logsDir <- ghcupLogsDir
+ confDir <- ghcupConfigDir
+ recycleDir <- ghcupRecycleDir
pure Dirs { .. }
@@ -271,10 +269,6 @@ mkGhcupTmpDir :: ( MonadReader env m
, MonadIO m)
=> m FilePath
mkGhcupTmpDir = do
-#if defined(IS_WINDOWS)
- Dirs { tmpDir } <- getDirs
- liftIO $ createTempDirectory tmpDir "ghcup"
-#else
tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight?
@@ -292,7 +286,6 @@ mkGhcupTmpDir = do
truncate' :: Double -> Int -> Double
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
where t = 10^n
-#endif
withGHCupTmpDir :: ( MonadReader env m
@@ -305,7 +298,15 @@ withGHCupTmpDir :: ( MonadReader env m
, MonadMask m
, MonadIO m)
=> m FilePath
-withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) (run . rmPathForcibly))
+withGHCupTmpDir = snd <$> withRunInIO (\run ->
+ run
+ $ allocate
+ (run mkGhcupTmpDir)
+ (\fp ->
+ handleIO (\e -> run
+ $ $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|])
+ . rmPathForcibly
+ $ fp))
@@ -333,18 +334,18 @@ relativeSymlink p1 p2 =
<> joinPath ([pathSeparator] : drop (length common) d2)
-cleanupGHCupTmp :: ( MonadIO m
- , MonadMask m
- , MonadLogger m
- , MonadReader env m
- , HasDirs env
- )
- => m ()
-cleanupGHCupTmp = do
- Dirs { tmpDir } <- getDirs
- contents <- liftIO $ listDirectory tmpDir
+cleanupTrash :: ( MonadIO m
+ , MonadMask m
+ , MonadLogger m
+ , MonadReader env m
+ , HasDirs env
+ )
+ => m ()
+cleanupTrash = do
+ Dirs { recycleDir } <- getDirs
+ contents <- liftIO $ listDirectory recycleDir
if null contents
then pure ()
else do
- $(logWarn) [i|Removing leftover files in #{tmpDir}|]
- forM_ contents (\fp -> liftIO $ removePathForcibly (tmpDir </> fp))
+ $(logWarn) [i|Removing leftover files in #{recycleDir}|]
+ forM_ contents (\fp -> liftIO $ removePathForcibly (recycleDir </> fp))
diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs
index 3ce6afc8237e8213f904bc2167716e3578196ce9..f761f2779959eeb6f3d38af5061ff240f9821415 100644
--- a/lib/GHCup/Utils/Logger.hs
+++ b/lib/GHCup/Utils/Logger.hs
@@ -97,7 +97,7 @@ initGHCupFileLogging = do
execBlank
([s|^.*\.log$|] :: B.ByteString)
)
- forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
+ forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
liftIO $ writeFile logfile ""
pure logfile
diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs
index e222c15eb2337a3ac5a2df7bd69796010400ce6f..259bc40cea2df9e57d4b1a55c51d4d9979fea3b8 100644
--- a/lib/GHCup/Utils/Prelude.hs
+++ b/lib/GHCup/Utils/Prelude.hs
@@ -323,17 +323,16 @@ createDirRecursive' p =
-- | Recursively copy the contents of one directory to another path.
--
-- This is a rip-off of Cabal library.
-copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
-copyDirectoryRecursive srcDir destDir = do
+copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
+copyDirectoryRecursive srcDir destDir doCopy = do
srcFiles <- getDirectoryContentsRecursive srcDir
- copyFilesWith copyFile destDir [ (srcDir, f)
- | f <- srcFiles ]
+ copyFilesWith destDir [ (srcDir, f)
+ | f <- srcFiles ]
where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
- copyFilesWith :: (FilePath -> FilePath -> IO ())
- -> FilePath -> [(FilePath, FilePath)] -> IO ()
- copyFilesWith doCopy targetDir srcFiles = do
+ copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
+ copyFilesWith targetDir srcFiles = do
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
@@ -378,37 +377,54 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
ignore ['.', '.'] = True
ignore _ = False
+
-- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f
-rmPathForcibly :: (MonadIO m
- , MonadReader env m
- , HasDirs env
+recyclePathForcibly :: ( MonadIO m
+ , MonadReader env m
+ , HasDirs env
+ , MonadMask m
+ )
+ => FilePath
+ -> m ()
+recyclePathForcibly fp = do
+#if defined(IS_WINDOWS)
+ Dirs { recycleDir } <- getDirs
+ tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
+ let dest = tmp </> takeFileName fp
+ liftIO (Win32.moveFileEx fp (Just dest) 0)
+ `catch`
+ (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+ `finally`
+ (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+#else
+ liftIO $ removePathForcibly fp
+#endif
+
+
+rmPathForcibly :: ( MonadIO m
, MonadMask m
)
=> FilePath
-> m ()
-rmPathForcibly fp = do
+rmPathForcibly fp =
#if defined(IS_WINDOWS)
- Dirs { tmpDir } <- getDirs
- tmp <- liftIO $ createTempDirectory tmpDir "rmPathForcibly"
- let dest = tmp </> takeFileName fp
- liftIO (Win32.moveFileEx fp (Just dest) 0)
- `finally`
- recovering (fullJitterBackoff 25000 <> limitRetries 10)
- [\_ -> Handler (\e -> pure $ isPermissionError e)
- ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
- ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
- ]
- (\_ -> liftIO $ removePathForcibly tmp)
+ recovering (fullJitterBackoff 25000 <> limitRetries 10)
+ [\_ -> Handler (\e -> pure $ isPermissionError e)
+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+ ]
+ (\_ -> liftIO $ removePathForcibly fp)
#else
- liftIO $ removeDirectoryRecursive fp
+ liftIO $ removePathForcibly fp
#endif
-rmPath :: (MonadIO m, MonadMask m)
- => FilePath
- -> m ()
-rmPath fp =
+
+rmDirectory :: (MonadIO m, MonadMask m)
+ => FilePath
+ -> m ()
+rmDirectory fp =
#if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e)
@@ -423,27 +439,42 @@ rmPath fp =
-- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96
+recycleFile :: ( MonadIO m
+ , MonadMask m
+ , MonadReader env m
+ , HasDirs env
+ )
+ => FilePath
+ -> m ()
+recycleFile fp = do
+#if defined(IS_WINDOWS)
+ Dirs { recycleDir } <- getDirs
+ liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
+ tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
+ let dest = tmp </> takeFileName fp
+ liftIO (Win32.moveFileEx fp (Just dest) 0)
+ `catch`
+ (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+ `finally`
+ (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+#else
+ liftIO $ removeFile fp
+#endif
+
+
rmFile :: ( MonadIO m
, MonadMask m
- , MonadReader env m
- , HasDirs env
)
=> FilePath
-> m ()
-rmFile fp = do
+rmFile fp =
#if defined(IS_WINDOWS)
- Dirs { tmpDir } <- getDirs
- liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "rmFile" "" Nothing (Just fp))
- tmp <- liftIO $ createTempDirectory tmpDir "rmFile"
- let dest = tmp </> takeFileName fp
- liftIO (Win32.moveFileEx fp (Just dest) 0)
- `finally`
- recovering (fullJitterBackoff 25000 <> limitRetries 10)
- [\_ -> Handler (\e -> pure $ isPermissionError e)
- ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
- ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
- ]
- (\_ -> liftIO $ removePathForcibly tmp)
+ recovering (fullJitterBackoff 25000 <> limitRetries 10)
+ [\_ -> Handler (\e -> pure $ isPermissionError e)
+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+ ]
+ (\_ -> liftIO $ removeFile fp)
#else
liftIO $ removeFile fp
#endif
@@ -454,9 +485,26 @@ rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
-> m ()
rmDirectoryLink fp =
#if defined(IS_WINDOWS)
- rmPathForcibly fp
+ recovering (fullJitterBackoff 25000 <> limitRetries 10)
+ [\_ -> Handler (\e -> pure $ isPermissionError e)
+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+ ]
+ (\_ -> liftIO $ removeDirectoryLink fp)
#else
- liftIO $ removeFile fp
+ liftIO $ removeDirectoryLink fp
+#endif
+
+
+#if defined(IS_WINDOWS)
+recover :: (MonadIO m, MonadMask m) => m a -> m a
+recover action =
+ recovering (fullJitterBackoff 25000 <> limitRetries 10)
+ [\_ -> Handler (\e -> pure $ isPermissionError e)
+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+ ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+ ]
+ (\_ -> action)
#endif