From c846e52acbb3539bbad3235c537b68412394e42c Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 10 Oct 2021 20:02:15 +0200 Subject: [PATCH] Cleanup during unpack failures as well --- app/ghcup/BrickMain.hs | 1 + app/ghcup/Main.hs | 7 +++++++ lib/GHCup.hs | 23 +++++++++++++++------- lib/GHCup/Utils.hs | 44 +++++++++++++++++++++++++++--------------- 4 files changed, 52 insertions(+), 23 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index dd620f0..85b9d3f 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -434,6 +434,7 @@ install' _ (_, ListResult {..}) = do , NoUpdate , TarDirDoesNotExist , FileAlreadyExistsError + , ProcessError ] run (do diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 65325da..e1f0bd9 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -1852,6 +1852,7 @@ Report bugs at |] , NextVerNotFound , NoToolVersionSet , FileAlreadyExistsError + , ProcessError ] let runInstTool mInstPlatform action' = do @@ -1953,6 +1954,12 @@ Report bugs at |] , NotInstalled , DirNotEmpty , ArchiveResult + , FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , ProcessError + , CopyError + , BuildFailed ] let runCompileHLS = diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 89f7338..72353eb 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -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) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index c106e2f..94434a8 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -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 ()