From 3bdc82c99ba515c0b22bed35df816716eb8097bc Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 22 Jul 2021 15:45:08 +0200 Subject: [PATCH] Redo file handling wrt #165 and #187 --- app/ghcup/Main.hs | 20 +++--- lib/GHCup.hs | 100 ++++++++++++--------------- lib/GHCup/Download.hs | 6 +- lib/GHCup/Types.hs | 2 +- lib/GHCup/Utils.hs | 47 +++++++++---- lib/GHCup/Utils/Dirs.hs | 66 +++++++++--------- lib/GHCup/Utils/Logger.hs | 2 +- lib/GHCup/Utils/Prelude.hs | 136 +++++++++++++++++++++++++------------ 8 files changed, 221 insertions(+), 158 deletions(-) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 9a97b1d..4078c62 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1387,8 +1387,8 @@ Report bugs at |] 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 |] -- Effect interpreters -- ------------------------- + let runInstTool' appstate' mInstPlatform = runLogger . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform) @@ -1519,6 +1520,9 @@ Report bugs at |] let runRm = runLogger . runAppState . runE @'[NotInstalled] + let runNuke s' = + runLogger . flip runReaderT s' . runE @'[NotInstalled] + let runDebugInfo = runLogger . runAppState @@ -2067,7 +2071,8 @@ Make sure to clean up #{tmpdir} afterwards.|]) ) pure ExitSuccess Just uri -> do - pfreq <- runAppState getPlatformReq + s' <- appState + pfreq <- flip runReaderT s' getPlatformReq let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri cmd = case _rPlatform pfreq of Darwin -> "open" @@ -2077,7 +2082,6 @@ Make sure to clean up #{tmpdir} afterwards.|]) if clOpen then do - s' <- appState flip runReaderT s' $ exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] @@ -2089,10 +2093,10 @@ Make sure to clean up #{tmpdir} afterwards.|]) >> pure (ExitFailure 13) else putStrLn uri' >> pure ExitSuccess - Nuke -> - runRm (do - s' <- liftIO appState - void $ liftIO $ evaluate $ force s' + Nuke -> do + s' <- liftIO appState + void $ liftIO $ evaluate $ force s' + runNuke s' (do lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system." lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time." liftIO $ threadDelay 10000000 -- wait 10s diff --git a/lib/GHCup.hs b/lib/GHCup.hs index e1fd846..a95d7ed 100644 --- 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/\@ 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 $ diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index 8f19ccb..c1046bd 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 284b47d..762cb30 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 eb2228e..e5e68d3 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 3d25063..aa3c3f7 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,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)) + diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index 3ce6afc..f761f27 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 e222c15..259bc40 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