Merge branch 'better-cleanup'

This commit is contained in:
Julian Ospald 2021-10-10 21:50:19 +02:00
commit aea8af513b
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
4 changed files with 52 additions and 23 deletions

View File

@ -434,6 +434,7 @@ install' _ (_, ListResult {..}) = do
, NoUpdate
, TarDirDoesNotExist
, FileAlreadyExistsError
, ProcessError
]
run (do

View File

@ -1852,6 +1852,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NextVerNotFound
, NoToolVersionSet
, FileAlreadyExistsError
, ProcessError
]
let runInstTool mInstPlatform action' = do
@ -1953,6 +1954,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NotInstalled
, DirNotEmpty
, ArchiveResult
, FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, ProcessError
, CopyError
, BuildFailed
]
let runCompileHLS =

View File

@ -205,6 +205,7 @@ installGHCBindist :: ( MonadFail m
, TarDirDoesNotExist
, DirNotEmpty
, ArchiveResult
, ProcessError
]
m
()
@ -283,6 +284,7 @@ installPackedGHC :: ( MonadMask m
, TarDirDoesNotExist
, DirNotEmpty
, ArchiveResult
, ProcessError
] m ()
installPackedGHC dl msubdir inst ver forceInstall = do
PlatformRequest {..} <- lift getPlatformReq
@ -292,7 +294,7 @@ installPackedGHC dl msubdir inst ver forceInstall = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
@ -402,12 +404,13 @@ installGHCBin :: ( MonadFail m
, TarDirDoesNotExist
, DirNotEmpty
, ArchiveResult
, ProcessError
]
m
()
installGHCBin ver isoFilepath forceInstall = do
dlinfo <- liftE $ getDownloadInfo GHC ver
installGHCBindist dlinfo ver isoFilepath forceInstall
liftE $ installGHCBindist dlinfo ver isoFilepath forceInstall
-- | Like 'installCabalBin', except takes the 'DownloadInfo' as
@ -472,7 +475,7 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
@ -614,7 +617,7 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
@ -784,7 +787,7 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack)
@ -1001,7 +1004,7 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do
-- unpack
tmpUnpack <- lift withGHCupTmpDir
liftE $ unpackToDir tmpUnpack dl
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
-- the subdir of the archive where we do the work
@ -2114,6 +2117,12 @@ compileGHC :: ( MonadMask m
, NotInstalled
, DirNotEmpty
, ArchiveResult
, FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, ProcessError
, CopyError
, BuildFailed
]
m
GHCTargetVersion
@ -2135,7 +2144,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
liftE $ cleanUpOnError tmpUnpack (unpackToDir tmpUnpack dl)
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
workdir <- maybe (pure tmpUnpack)

View File

@ -74,7 +74,6 @@ import System.Win32.Console
import System.Win32.File hiding ( copyFile )
import System.Win32.Types
#endif
import Text.PrettyPrint.HughesPJClass hiding ( (<>) )
import Text.Regex.Posix
import URI.ByteString
@ -926,11 +925,7 @@ 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)
, PopVariant BuildFailed e
, ToVariantMaybe BuildFailed e
, MonadReader env m
runBuildAction :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
@ -943,26 +938,43 @@ runBuildAction :: ( Pretty (V e)
=> 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
-> Excepts e m a
runBuildAction bdir instdir action = do
Settings {..} <- lift getSettings
let exAction = do
forM_ instdir $ \dir ->
lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
hideError doesNotExistErrorType $ recyclePathForcibly dir
when (keepDirs == Never)
$ lift $ rmBDir bdir
$ rmBDir bdir
v <-
flip onException exAction
$ catchAllE
(\es -> do
exAction
throwE (BuildFailed bdir es)
) action
flip onException (lift exAction)
$ onE_ exAction action
when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
pure v
-- | Clean up the given directory if the action fails,
-- depending on the Settings.
cleanUpOnError :: ( MonadReader env m
, HasDirs env
, HasSettings env
, MonadIO m
, MonadMask m
, HasLog env
, MonadUnliftIO m
, MonadFail m
, MonadCatch m
)
=> FilePath -- ^ build directory (cleaned up depending on Settings)
-> Excepts e m a
-> Excepts e m a
cleanUpOnError bdir action = do
Settings {..} <- lift getSettings
let exAction = when (keepDirs == Never) $ rmBDir bdir
flip onException (lift exAction) $ onE_ exAction action
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing.
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()