Redo file handling wrt #165 and #187

2021-07-22 15:45:08 +02:00
parent 1c2cf98850
commit 3bdc82c99b
8 changed files with 221 additions and 158 deletions
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@@ -54,6 +54,9 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                         hiding ( throwM )
+#if defined(IS_WINDOWS)
+import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
+#endif
 import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.List
@@ -252,22 +255,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 +270,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
@@ -295,13 +281,29 @@ installUnpackedGHC :: ( MonadReader env m
                      , MonadThrow m
                      , MonadLogger m
                      , MonadIO m
+                      , MonadUnliftIO m
+                      , MonadMask m
                      )
                   => FilePath      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
                   -> FilePath      -- ^ Path to install to
                   -> 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.
+  lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
+    mtime <- getModificationTime source
+    Win32.moveFile 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 +314,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 +321,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 +1310,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 +1322,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 +1347,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 +1378,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 +1416,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
@@ -1434,6 +1432,7 @@ rmGhcup :: ( MonadReader env m
           , MonadCatch m
           , MonadLogger m
           , MonadMask m
+           , MonadUnliftIO m
           )
        => m ()
 rmGhcup = do
@@ -1459,12 +1458,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,30 +1511,34 @@ rmGhcupDirs = do
    , binDir
    , logsDir
    , cacheDir
-    , tmpDir
+    , recycleDir
    } <- getDirs

  let envFilePath = baseDir </> "env"

  confFilePath <- getConfigFilePath

-  rmEnvFile  envFilePath
-  rmConfFile confFilePath
-  rmDir cacheDir
-  rmDir logsDir
-  rmBinDir   binDir
-  rmDir tmpDir
+  handleRm $ rmEnvFile  envFilePath
+  handleRm $ rmConfFile confFilePath
+  handleRm $ rmDir cacheDir
+  handleRm $ rmDir logsDir
+  handleRm $ rmBinDir binDir
+  handleRm $ rmDir recycleDir
 #if defined(IS_WINDOWS)
-  rmDir (baseDir </> "msys64")
+  $logInfo [i|removing #{(baseDir </> "msys64")}|]
+  handleRm $ rmPathForcibly (baseDir </> "msys64")
 #endif

-  removeEmptyDirsRecursive baseDir
+  handleRm $ removeEmptyDirsRecursive baseDir

  -- report files in baseDir that are left-over after
  -- the standard location deletions above
  hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir

  where
+    handleRm :: (MonadCatch m, MonadLogger m)  => m () -> m ()
+    handleRm = handleIO (\e -> $logWarn [i|Part of the cleanup action failed with error: #{displayException e}
+continuing regardless...|])

    rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
    rmEnvFile enFilePath = do
@@ -1607,7 +1610,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 +2139,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 $
--- 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
--- 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)

--- 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)
-
--- 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,21 @@ 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 -> handleIO (\e ->
+        $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|]
+      ) $ liftIO $ removePathForcibly (recycleDir </> fp))
+
--- 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
--- 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