Clean up on error, fixes #1004
This commit is contained in:
parent
57d23c477d
commit
be3db87410
@ -908,7 +908,7 @@ compileGHC targetGhc crossTarget vps bstrap jobs mbuildConfig patches aargs buil
|
|||||||
GitDist GitBranch{..} -> do
|
GitDist GitBranch{..} -> do
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
|
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
|
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)"
|
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
||||||
lEM $ git [ "init" ]
|
lEM $ git [ "init" ]
|
||||||
|
@ -437,7 +437,7 @@ compileHLS targetHLS ghcs jobs vps installDir cabalProject cabalProjectLocal upd
|
|||||||
GitDist GitBranch{..} -> do
|
GitDist GitBranch{..} -> do
|
||||||
tmpUnpack <- lift mkGhcupTmpDir
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing
|
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
|
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)"
|
lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
|
||||||
lEM $ git [ "init" ]
|
lEM $ git [ "init" ]
|
||||||
|
@ -1084,27 +1084,6 @@ cleanUpOnError bdir action = do
|
|||||||
flip onException (lift exAction) $ onE_ exAction action
|
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
|
-- | Remove a build directory, ignoring if it doesn't exist and gracefully
|
||||||
-- printing other errors without crashing.
|
-- printing other errors without crashing.
|
||||||
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m ()
|
rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => GHCupPath -> m ()
|
||||||
|
Loading…
Reference in New Issue
Block a user