diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs index 9432ab5..bd9f854 100644 --- a/lib/GHCup/GHC.hs +++ b/lib/GHCup/GHC.hs @@ -908,7 +908,7 @@ compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buil GitDist GitBranch{..} -> do tmpUnpack <- lift mkGhcupTmpDir let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing - (tver, ov) <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do + (tver, ov) <- cleanUpOnError tmpUnpack $ reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, ContentLengthError, DownloadFailed, GPGError] DownloadFailed $ do let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" lEM $ git [ "init" ] diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs index a452671..70453f3 100644 --- a/lib/GHCup/HLS.hs +++ b/lib/GHCup/HLS.hs @@ -437,7 +437,7 @@ compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal upd GitDist GitBranch{..} -> do tmpUnpack <- lift mkGhcupTmpDir let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing - reThrowAll @_ @'[ProcessError] DownloadFailed $ do + cleanUpOnError tmpUnpack $ reThrowAll @_ @'[ProcessError] DownloadFailed $ do let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" lEM $ git [ "init" ] diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index ddc61e4..38d4eb5 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -1084,27 +1084,6 @@ cleanUpOnError bdir action = do flip onException (lift exAction) $ onE_ exAction action --- | Clean up the given directory if the action fails, --- depending on the Settings. -cleanFinally :: ( MonadReader env m - , HasDirs env - , HasSettings env - , MonadIO m - , MonadMask m - , HasLog env - , MonadUnliftIO m - , MonadFail m - , MonadCatch m - ) - => GHCupPath -- ^ build directory (cleaned up depending on Settings) - -> Excepts e m a - -> Excepts e m a -cleanFinally bdir action = do - Settings {..} <- lift getSettings - let exAction = when (keepDirs == Never) $ rmBDir bdir - flip finally (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) => GHCupPath -> m ()