hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Redo file handling wrt #165 and #187

Browse Source
This commit is contained in:
Julian Ospald 2021-07-22 15:45:08 +02:00
parent 1c2cf98850
commit 3bdc82c99b
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
8 changed files with 221 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
app/ghcup/Main.hs
View File

@ -1387,8 +1387,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq let s' = AppState settings dirs keybindings ghcupInfo pfreq
race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupGHCupTmp) race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
(threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{tmpDir} manually|])) (threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{recycleDir} manually|]))
lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
@ -1422,6 +1422,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- Effect interpreters -- -- Effect interpreters --
------------------------- -------------------------
let runInstTool' appstate' mInstPlatform = let runInstTool' appstate' mInstPlatform =
runLogger runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform) . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
@ -1519,6 +1520,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runRm = let runRm =
runLogger . runAppState . runE @'[NotInstalled] runLogger . runAppState . runE @'[NotInstalled]
let runNuke s' =
runLogger . flip runReaderT s' . runE @'[NotInstalled]
let runDebugInfo = let runDebugInfo =
runLogger runLogger
. runAppState . runAppState
@ -2067,7 +2071,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
) )
pure ExitSuccess pure ExitSuccess
Just uri -> do Just uri -> do
pfreq <- runAppState getPlatformReq s' <- appState
pfreq <- flip runReaderT s' getPlatformReq
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of cmd = case _rPlatform pfreq of
Darwin -> "open" Darwin -> "open"
@ -2077,7 +2082,6 @@ Make sure to clean up #{tmpdir} afterwards.|])
if clOpen if clOpen
then do then do
s' <- appState
flip runReaderT s' $ flip runReaderT s' $
exec cmd exec cmd
[T.unpack $ decUTF8Safe $ serializeURIRef' uri] [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
@ -2089,10 +2093,10 @@ Make sure to clean up #{tmpdir} afterwards.|])
>> pure (ExitFailure 13) >> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess else putStrLn uri' >> pure ExitSuccess
Nuke -> Nuke -> do
runRm (do s' <- liftIO appState
s' <- liftIO appState void $ liftIO $ evaluate $ force s'
void $ liftIO $ evaluate $ force s' runNuke s' (do
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system." 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." lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s liftIO $ threadDelay 10000000 -- wait 10s

100
lib/GHCup.hs
View File

@ -54,6 +54,9 @@ import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
#if defined(IS_WINDOWS)
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#endif
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Either import Data.Either
import Data.List import Data.List
@ -252,22 +255,6 @@ installPackedGHC :: ( MonadMask m
#endif #endif
] m () ] m ()
installPackedGHC dl msubdir inst ver = do 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 PlatformRequest {..} <- lift getPlatformReq
-- unpack -- unpack
@ -283,7 +270,6 @@ installPackedGHC dl msubdir inst ver = do
liftE $ runBuildAction tmpUnpack liftE $ runBuildAction tmpUnpack
(Just inst) (Just inst)
(installUnpackedGHC workdir inst ver) (installUnpackedGHC workdir inst ver)
#endif
-- | Install an unpacked GHC distribution. This only deals with the GHC -- | Install an unpacked GHC distribution. This only deals with the GHC
@ -295,13 +281,29 @@ installUnpackedGHC :: ( MonadReader env m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadUnliftIO m
, MonadMask m
) )
=> FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides) => FilePath -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Version -- ^ The GHC version -> Version -- ^ The GHC version
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver = do 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 PlatformRequest {..} <- lift getPlatformReq
liftIO $ copyDirectoryRecursive path inst $ \source dest -> do
mtime <- getModificationTime source
copyFile source dest
setModificationTime dest mtime
let alpineArgs let alpineArgs
| ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform | 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)" lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ execLogged "sh" lEM $ execLogged "sh"
("./configure" : ("--prefix=" <> inst) ("./configure" : ("--prefix=" <> inst)
#if defined(IS_WINDOWS)
: "--enable-tarballs-autodownload"
#endif
: alpineArgs : alpineArgs
) )
(Just path) (Just path)
@ -322,6 +321,7 @@ installUnpackedGHC path inst ver = do
Nothing Nothing
lEM $ make ["install"] (Just path) lEM $ make ["install"] (Just path)
pure () pure ()
#endif
-- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the -- | 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) -- then fix them (e.g. with an earlier version)
lift $ $(logInfo) [i|Removing directory recursively: #{dir}|] lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
lift $ rmPathForcibly dir lift $ recyclePathForcibly dir
v' <- v' <-
handle handle
@ -1322,9 +1322,7 @@ rmGHCVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
lift lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
$ hideError doesNotExistErrorType
$ rmFile (baseDir </> "share")
-- | Delete a cabal version. Will try to fix the @cabal@ symlink -- | Delete a cabal version. Will try to fix the @cabal@ symlink
@ -1349,7 +1347,7 @@ rmCabalVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt 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 when (Just ver == cSet) $ do
cVers <- lift $ fmap rights getInstalledCabals cVers <- lift $ fmap rights getInstalledCabals
@ -1380,7 +1378,7 @@ rmHLSVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
bins <- lift $ hlsAllBinaries ver bins <- lift $ hlsAllBinaries ver
forM_ bins $ \f -> lift $ rmFile (binDir </> f) forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
when (Just ver == isHlsSet) $ do when (Just ver == isHlsSet) $ do
-- delete all set symlinks -- delete all set symlinks
@ -1418,7 +1416,7 @@ rmStackVer ver = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt 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 when (Just ver == sSet) $ do
sVers <- lift $ fmap rights getInstalledStacks sVers <- lift $ fmap rights getInstalledStacks
@ -1434,6 +1432,7 @@ rmGhcup :: ( MonadReader env m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadMask m , MonadMask m
, MonadUnliftIO m
) )
=> m () => m ()
rmGhcup = do rmGhcup = do
@ -1459,12 +1458,12 @@ rmGhcup = do
unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#if defined(IS_WINDOWS) #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 -- we move it to temp dir, to be deleted at next reboot
let tempFilepath = tmpDir </> ghcupFilename tempFilepath <- mkGhcupTmpDir
hideError UnsupportedOperation $ hideError UnsupportedOperation $
liftIO $ hideError NoSuchThing $ liftIO $ hideError NoSuchThing $
Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
#else #else
-- delete it. -- delete it.
hideError doesNotExistErrorType $ rmFile ghcupFilepath hideError doesNotExistErrorType $ rmFile ghcupFilepath
@ -1512,30 +1511,34 @@ rmGhcupDirs = do
, binDir , binDir
, logsDir , logsDir
, cacheDir , cacheDir
, tmpDir , recycleDir
} <- getDirs } <- getDirs
let envFilePath = baseDir </> "env" let envFilePath = baseDir </> "env"
confFilePath <- getConfigFilePath confFilePath <- getConfigFilePath
rmEnvFile envFilePath handleRm $ rmEnvFile envFilePath
rmConfFile confFilePath handleRm $ rmConfFile confFilePath
rmDir cacheDir handleRm $ rmDir cacheDir
rmDir logsDir handleRm $ rmDir logsDir
rmBinDir binDir handleRm $ rmBinDir binDir
rmDir tmpDir handleRm $ rmDir recycleDir
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
rmDir (baseDir </> "msys64") $logInfo [i|removing #{(baseDir </> "msys64")}|]
handleRm $ rmPathForcibly (baseDir </> "msys64")
#endif #endif
removeEmptyDirsRecursive baseDir handleRm $ removeEmptyDirsRecursive baseDir
-- report files in baseDir that are left-over after -- report files in baseDir that are left-over after
-- the standard location deletions above -- the standard location deletions above
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
where 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 :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile enFilePath = do rmEnvFile enFilePath = do
@ -1607,7 +1610,7 @@ rmGhcupDirs = do
hideError UnsatisfiedConstraints $ hideError UnsatisfiedConstraints $
handleIO' InappropriateType handleIO' InappropriateType
(handleIfSym filepath) (handleIfSym filepath)
(liftIO $ rmPath filepath) (liftIO $ rmDirectory filepath)
where where
handleIfSym fp e = do handleIfSym fp e = do
isSym <- liftIO $ pathIsSymbolicLink fp isSym <- liftIO $ pathIsSymbolicLink fp
@ -2136,27 +2139,14 @@ upgradeGHCup mtarget force' = do
let fn = "ghcup" <> exeExt let fn = "ghcup" <> exeExt
p <- liftE $ download dli tmp (Just fn) p <- liftE $ download dli tmp (Just fn)
let destDir = takeDirectory destFile let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn <> exeExt) mtarget destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) [i|mkdir -p #{destDir}|] lift $ $(logDebug) [i|mkdir -p #{destDir}|]
liftIO $ createDirRecursive' 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 $ $(logDebug) [i|rm -f #{destFile}|]
lift $ hideError NoSuchThing $ rmFile destFile lift $ hideError NoSuchThing $ recycleFile destFile
lift $ $(logDebug) [i|cp #{p} #{destFile}|] lift $ $(logDebug) [i|cp #{p} #{destFile}|]
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile destFile
#endif
lift $ chmod_755 destFile lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $ liftIO (isInPath destFile) >>= \b -> unless b $

6
lib/GHCup/Download.hs
View File

@ -265,7 +265,7 @@ getBase uri = do
pure bs pure bs
dlWithoutMod json_file = do dlWithoutMod json_file = do
bs <- liftE $ downloadBS uri' bs <- liftE $ downloadBS uri'
lift $ hideError doesNotExistErrorType $ rmFile json_file lift $ hideError doesNotExistErrorType $ recycleFile json_file
liftIO $ L.writeFile json_file bs liftIO $ L.writeFile json_file bs
liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0)) liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
pure bs pure bs
@ -388,10 +388,10 @@ download dli dest mfn
-- download -- download
flip onException flip onException
(lift $ hideError doesNotExistErrorType $ rmFile destFile) (lift $ hideError doesNotExistErrorType $ recycleFile destFile)
$ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme] $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
(\e -> (\e ->
lift (hideError doesNotExistErrorType $ rmFile destFile) lift (hideError doesNotExistErrorType $ recycleFile destFile)
>> (throwE . DownloadFailed $ e) >> (throwE . DownloadFailed $ e)
) $ do ) $ do
Settings{ downloader, noNetwork } <- lift getSettings Settings{ downloader, noNetwork } <- lift getSettings

2
lib/GHCup/Types.hs
View File

@ -384,7 +384,7 @@ data Dirs = Dirs
, cacheDir :: FilePath , cacheDir :: FilePath
, logsDir :: FilePath , logsDir :: FilePath
, confDir :: FilePath , confDir :: FilePath
, tmpDir :: FilePath , recycleDir :: FilePath -- mainly used on windows
} }
deriving (Show, GHC.Generic) deriving (Show, GHC.Generic)

47
lib/GHCup/Utils.hs
View File

@ -53,6 +53,7 @@ import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Control.Monad.IO.Unlift ( MonadUnliftIO( withRunInIO ) )
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
import Data.Bits import Data.Bits
#endif #endif
@ -886,8 +887,17 @@ getChangeLog dls tool (Right tag) =
-- --
-- 1. the build directory, depending on the KeepDirs setting -- 1. the build directory, depending on the KeepDirs setting
-- 2. the install destination, depending on whether the build failed -- 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) runBuildAction :: ( Pretty (V e)
=> FilePath -- ^ build directory (cleaned up depending on Settings) , 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 -> Maybe FilePath -- ^ dir to *always* clean up on exception
-> Excepts e m a -> Excepts e m a
-> Excepts '[BuildFailed] m a -> Excepts '[BuildFailed] m a
@ -895,11 +905,9 @@ runBuildAction bdir instdir action = do
Settings {..} <- lift getSettings Settings {..} <- lift getSettings
let exAction = do let exAction = do
forM_ instdir $ \dir -> forM_ instdir $ \dir ->
lift $ hideError doesNotExistErrorType $ rmPathForcibly dir lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
when (keepDirs == Never) when (keepDirs == Never)
$ lift $ lift $ rmBDir bdir
$ hideError doesNotExistErrorType
$ rmPathForcibly bdir
v <- v <-
flip onException exAction flip onException exAction
$ catchAllE $ catchAllE
@ -908,10 +916,20 @@ runBuildAction bdir instdir action = do
throwE (BuildFailed bdir es) throwE (BuildFailed bdir es)
) action ) action
when (keepDirs == Never || keepDirs == Errors) $ lift $ rmPathForcibly bdir when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
pure v 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 getVersionInfo :: Version
-> Tool -> Tool
-> GHCupDownloads -> GHCupDownloads
@ -1001,10 +1019,10 @@ pathIsLink = pathIsSymbolicLink
rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
rmLink fp = do rmLink fp = do
hideError doesNotExistErrorType . rmFile $ fp hideError doesNotExistErrorType . recycleFile $ fp
hideError doesNotExistErrorType . rmFile $ (dropExtension fp <.> "shim") hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
#else #else
rmLink = hideError doesNotExistErrorType . rmFile rmLink = hideError doesNotExistErrorType . recycleFile
#endif #endif
@ -1049,7 +1067,7 @@ createLink link exe = do
liftIO $ writeFile shim shimContents liftIO $ writeFile shim shimContents
#else #else
$(logDebug) [i|rm -f #{exe}|] $(logDebug) [i|rm -f #{exe}|]
hideError doesNotExistErrorType $ rmFile exe hideError doesNotExistErrorType $ recycleFile exe
$(logDebug) [i|ln -s #{link} #{exe}|] $(logDebug) [i|ln -s #{link} #{exe}|]
liftIO $ createFileLink link exe liftIO $ createFileLink link exe
@ -1078,7 +1096,7 @@ ensureGlobalTools = do
void $ (\(DigestError _ _) -> do void $ (\(DigestError _ _) -> do
lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|] lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
lift $ $(logDebug) [i|rm -f #{shimDownload}|] 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 liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl) ) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
pure () pure ()
@ -1089,14 +1107,14 @@ ensureGlobalTools = do
-- | Ensure ghcup directory structure exists. -- | Ensure ghcup directory structure exists.
ensureDirectories :: Dirs -> IO () 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
createDirRecursive' (baseDir </> "ghc") createDirRecursive' (baseDir </> "ghc")
createDirRecursive' binDir createDirRecursive' binDir
createDirRecursive' cacheDir createDirRecursive' cacheDir
createDirRecursive' logsDir createDirRecursive' logsDir
createDirRecursive' confDir createDirRecursive' confDir
createDirRecursive' tmpDir createDirRecursive' trashDir
pure () pure ()
@ -1110,4 +1128,3 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
ghcBinaryName :: GHCTargetVersion -> String ghcBinaryName :: GHCTargetVersion -> String
ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt) 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) ghcBinaryName (GHCTargetVersion Nothing v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)

66
lib/GHCup/Utils/Dirs.hs
View File

@ -30,7 +30,7 @@ module GHCup.Utils.Dirs
#if !defined(IS_WINDOWS) #if !defined(IS_WINDOWS)
, useXDG , useXDG
#endif #endif
, cleanupGHCupTmp , cleanupTrash
) )
where where
@ -190,23 +190,21 @@ ghcupLogsDir = do
#endif #endif
-- | Defaults to '~/.ghcup/tmp. -- | '~/.ghcup/trash'.
-- -- Mainly used on windows to improve file removal operations
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), ghcupRecycleDir :: IO FilePath
-- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec. ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
ghcupTmpDir :: IO FilePath
ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
getAllDirs :: IO Dirs getAllDirs :: IO Dirs
getAllDirs = do getAllDirs = do
baseDir <- ghcupBaseDir baseDir <- ghcupBaseDir
binDir <- ghcupBinDir binDir <- ghcupBinDir
cacheDir <- ghcupCacheDir cacheDir <- ghcupCacheDir
logsDir <- ghcupLogsDir logsDir <- ghcupLogsDir
confDir <- ghcupConfigDir confDir <- ghcupConfigDir
tmpDir <- ghcupTmpDir recycleDir <- ghcupRecycleDir
pure Dirs { .. } pure Dirs { .. }
@ -271,10 +269,6 @@ mkGhcupTmpDir :: ( MonadReader env m
, MonadIO m) , MonadIO m)
=> m FilePath => m FilePath
mkGhcupTmpDir = do mkGhcupTmpDir = do
#if defined(IS_WINDOWS)
Dirs { tmpDir } <- getDirs
liftIO $ createTempDirectory tmpDir "ghcup"
#else
tmpdir <- liftIO getCanonicalTemporaryDirectory tmpdir <- liftIO getCanonicalTemporaryDirectory
let minSpace = 5000 -- a rough guess, aight? let minSpace = 5000 -- a rough guess, aight?
@ -292,7 +286,6 @@ mkGhcupTmpDir = do
truncate' :: Double -> Int -> Double truncate' :: Double -> Int -> Double
truncate' x n = fromIntegral (floor (x * t) :: Integer) / t truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
where t = 10^n where t = 10^n
#endif
withGHCupTmpDir :: ( MonadReader env m withGHCupTmpDir :: ( MonadReader env m
@ -305,7 +298,15 @@ withGHCupTmpDir :: ( MonadReader env m
, MonadMask m , MonadMask m
, MonadIO m) , MonadIO m)
=> m FilePath => 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) <> joinPath ([pathSeparator] : drop (length common) d2)
cleanupGHCupTmp :: ( MonadIO m cleanupTrash :: ( MonadIO m
, MonadMask m , MonadMask m
, MonadLogger m , MonadLogger m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
) )
=> m () => m ()
cleanupGHCupTmp = do cleanupTrash = do
Dirs { tmpDir } <- getDirs Dirs { recycleDir } <- getDirs
contents <- liftIO $ listDirectory tmpDir contents <- liftIO $ listDirectory recycleDir
if null contents if null contents
then pure () then pure ()
else do else do
$(logWarn) [i|Removing leftover files in #{tmpDir}|] $(logWarn) [i|Removing leftover files in #{recycleDir}|]
forM_ contents (\fp -> liftIO $ removePathForcibly (tmpDir </> fp)) forM_ contents (\fp -> handleIO (\e ->
$(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|]
) $ liftIO $ removePathForcibly (recycleDir </> fp))

2
lib/GHCup/Utils/Logger.hs
View File

@ -97,7 +97,7 @@ initGHCupFileLogging = do
execBlank execBlank
([s|^.*\.log$|] :: B.ByteString) ([s|^.*\.log$|] :: B.ByteString)
) )
forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>) forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
liftIO $ writeFile logfile "" liftIO $ writeFile logfile ""
pure logfile pure logfile

136
lib/GHCup/Utils/Prelude.hs
View File

@ -323,17 +323,16 @@ createDirRecursive' p =
-- | Recursively copy the contents of one directory to another path. -- | Recursively copy the contents of one directory to another path.
-- --
-- This is a rip-off of Cabal library. -- This is a rip-off of Cabal library.
copyDirectoryRecursive :: FilePath -> FilePath -> IO () copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
copyDirectoryRecursive srcDir destDir = do copyDirectoryRecursive srcDir destDir doCopy = do
srcFiles <- getDirectoryContentsRecursive srcDir srcFiles <- getDirectoryContentsRecursive srcDir
copyFilesWith copyFile destDir [ (srcDir, f) copyFilesWith destDir [ (srcDir, f)
| f <- srcFiles ] | f <- srcFiles ]
where where
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles', -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'. -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
copyFilesWith :: (FilePath -> FilePath -> IO ()) copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
-> FilePath -> [(FilePath, FilePath)] -> IO () copyFilesWith targetDir srcFiles = do
copyFilesWith doCopy targetDir srcFiles = do
-- Create parent directories for everything -- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
@ -378,37 +377,54 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
ignore ['.', '.'] = True ignore ['.', '.'] = True
ignore _ = False ignore _ = False
-- https://github.com/haskell/directory/issues/110 -- https://github.com/haskell/directory/issues/110
-- https://github.com/haskell/directory/issues/96 -- https://github.com/haskell/directory/issues/96
-- https://www.sqlite.org/src/info/89f1848d7f -- https://www.sqlite.org/src/info/89f1848d7f
rmPathForcibly :: (MonadIO m recyclePathForcibly :: ( MonadIO m
, MonadReader env m , MonadReader env m
, HasDirs env , 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 , MonadMask m
) )
=> FilePath => FilePath
-> m () -> m ()
rmPathForcibly fp = do rmPathForcibly fp =
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
Dirs { tmpDir } <- getDirs recovering (fullJitterBackoff 25000 <> limitRetries 10)
tmp <- liftIO $ createTempDirectory tmpDir "rmPathForcibly" [\_ -> Handler (\e -> pure $ isPermissionError e)
let dest = tmp </> takeFileName fp ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
liftIO (Win32.moveFileEx fp (Just dest) 0) ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
`finally` ]
recovering (fullJitterBackoff 25000 <> limitRetries 10) (\_ -> liftIO $ removePathForcibly fp)
[\_ -> Handler (\e -> pure $ isPermissionError e)
,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
]
(\_ -> liftIO $ removePathForcibly tmp)
#else #else
liftIO $ removeDirectoryRecursive fp liftIO $ removePathForcibly fp
#endif #endif
rmPath :: (MonadIO m, MonadMask m)
=> FilePath rmDirectory :: (MonadIO m, MonadMask m)
-> m () => FilePath
rmPath fp = -> m ()
rmDirectory fp =
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
recovering (fullJitterBackoff 25000 <> limitRetries 10) recovering (fullJitterBackoff 25000 <> limitRetries 10)
[\_ -> Handler (\e -> pure $ isPermissionError e) [\_ -> Handler (\e -> pure $ isPermissionError e)
@ -423,27 +439,42 @@ rmPath fp =
-- https://www.sqlite.org/src/info/89f1848d7f -- https://www.sqlite.org/src/info/89f1848d7f
-- https://github.com/haskell/directory/issues/96 -- 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 rmFile :: ( MonadIO m
, MonadMask m , MonadMask m
, MonadReader env m
, HasDirs env
) )
=> FilePath => FilePath
-> m () -> m ()
rmFile fp = do rmFile fp =
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
Dirs { tmpDir } <- getDirs recovering (fullJitterBackoff 25000 <> limitRetries 10)
liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "rmFile" "" Nothing (Just fp)) [\_ -> Handler (\e -> pure $ isPermissionError e)
tmp <- liftIO $ createTempDirectory tmpDir "rmFile" ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
let dest = tmp </> takeFileName fp ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
liftIO (Win32.moveFileEx fp (Just dest) 0) ]
`finally` (\_ -> liftIO $ removeFile fp)
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)
#else #else
liftIO $ removeFile fp liftIO $ removeFile fp
#endif #endif
@ -454,9 +485,26 @@ rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
-> m () -> m ()
rmDirectoryLink fp = rmDirectoryLink fp =
#if defined(IS_WINDOWS) #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 #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 #endif