From bcaccaaf312eb7ef77bbcf8ad3fbe12481893f92 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 22 Apr 2020 18:12:40 +0200 Subject: [PATCH] Implement --keep --- app/ghcup-gen/Validate.hs | 2 +- app/ghcup/Main.hs | 46 ++++++++++++++++++++++++++++----------- lib/GHCup.hs | 46 ++++++++++++--------------------------- lib/GHCup/Types.hs | 7 ++++++ lib/GHCup/Utils.hs | 37 +++++++++++++++++++++++++++++++ 5 files changed, 92 insertions(+), 46 deletions(-) diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 14e7818..53ef367 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -175,7 +175,7 @@ validateTarballs dls = do where downloadAll dli = do - let settings = Settings True False + let settings = Settings True False Never let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True , colorOutter = B.hPut stderr , rawOutter = (\_ -> pure ()) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 655de6d..714c266 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -74,6 +74,7 @@ data Options = Options , optCache :: Bool , optUrlSource :: Maybe URI , optNoVerify :: Bool + , optKeepDirs :: KeepDirs -- commands , optCommand :: Command } @@ -164,6 +165,14 @@ opts = (short 'n' <> long "no-verify" <> help "Skip tarball checksum verification" ) + <*> option + (eitherReader keepOnParser) + ( long "keep" + <> metavar "" + <> help + "Keep build directories?" + <> value Never + ) <*> com where parseUri s' = @@ -507,6 +516,14 @@ criteriaParser s' | t == T.pack "installed" = Right ListInstalled where t = T.toLower (T.pack s') +keepOnParser :: String -> Either String KeepDirs +keepOnParser s' | t == T.pack "always" = Right Always + | t == T.pack "errors" = Right Errors + | t == T.pack "never" = Right Never + | otherwise = Left ("Unknown keep value: " <> s') + where t = T.toLower (T.pack s') + + platformParser :: String -> Either String PlatformRequest platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of Right r -> pure r @@ -584,6 +601,7 @@ toSettings :: Options -> Settings toSettings Options {..} = let cache = optCache noVerify = optNoVerify + keepDirs = optKeepDirs in Settings { .. } @@ -654,7 +672,7 @@ Report bugs at |] (footerDoc (Just $ text main_footer)) ) >>= \opt@Options {..} -> do - let settings = toSettings opt + let settings@Settings{..} = toSettings opt -- create ~/.ghcup dir ghcdir <- ghcupBaseDir @@ -792,10 +810,11 @@ Report bugs at |] [i|GHC ver #{prettyVer v} already installed|] pure ExitSuccess VLeft (V (BuildFailed tmpdir e)) -> do - runLogger - ($(logError) [i|Build failed with #{e} -Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|] - ) + case keepDirs of + Never -> runLogger ($(logError) [i|Build failed with #{e}|]) + _ -> runLogger ($(logError) [i|Build failed with #{e} +Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues. +Make sure to clean up #{tmpdir} afterwards.|]) pure $ ExitFailure 3 VLeft (V NoDownload) -> do @@ -902,11 +921,11 @@ Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues [i|GHC ver #{prettyVer v} already installed|] pure ExitSuccess VLeft (V (BuildFailed tmpdir e)) -> do - runLogger - ($(logError) [i|Build failed with #{e} + case keepDirs of + Never -> runLogger ($(logError) [i|Build failed with #{e}|]) + _ -> runLogger ($(logError) [i|Build failed with #{e} Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues. -Make sure to clean up #{tmpdir} afterwards.|] - ) +Make sure to clean up #{tmpdir} afterwards.|]) pure $ ExitFailure 9 VLeft e -> do runLogger ($(logError) [i|#{e}|]) @@ -924,10 +943,11 @@ Make sure to clean up #{tmpdir} afterwards.|] ) pure ExitSuccess VLeft (V (BuildFailed tmpdir e)) -> do - runLogger - ($(logError) [i|Build failed with #{e} -Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues.|] - ) + case keepDirs of + Never -> runLogger ($(logError) [i|Build failed with #{e}|]) + _ -> runLogger ($(logError) [i|Build failed with #{e} +Check the logs at ~/.ghcup/logs and the build directory #{tmpdir} for more clues. +Make sure to clean up #{tmpdir} afterwards.|]) pure $ ExitFailure 10 VLeft e -> do runLogger ($(logError) [i|#{e}|]) diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 0150580..343fc32 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -97,15 +97,15 @@ installGHCBin bDls ver mpfReq = do lift $ $(logDebug) [i|Requested to install GHC with #{ver}|] whenM (liftIO $ toolAlreadyInstalled GHC ver) $ (throwE $ AlreadyInstalled GHC ver) - Settings {..} <- lift ask + Settings {..} <- lift ask pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq -- download (or use cached version) - dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls - dl <- liftE $ downloadCached dlinfo Nothing + dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls + dl <- liftE $ downloadCached dlinfo Nothing -- unpack - tmpUnpack <- lift mkGhcupTmpDir + tmpUnpack <- lift mkGhcupTmpDir liftE $ unpackToDir tmpUnpack dl void $ liftIO $ darwinNotarization _rPlatform tmpUnpack @@ -115,19 +115,7 @@ installGHCBin bDls ver mpfReq = do -- the subdir of the archive where we do the work let workdir = maybe tmpUnpack (tmpUnpack ) (view dlSubdir dlinfo) - -- Be careful about cleanup. We must catch both pure exceptions - -- as well as async ones. - flip onException - (liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir) - $ catchAllE - (\es -> do - liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir) - >> throwE (BuildFailed workdir es) - ) - $ installGHC' workdir ghcdir - - -- only clean up dir if the build succeeded - liftIO $ deleteDirRecursive tmpUnpack + liftE $ runBuildAction tmpUnpack (Just ghcdir) (installGHC' workdir ghcdir) liftE $ postGHCInstall ver @@ -533,20 +521,10 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir = do let workdir = maybe id (flip ()) (view dlSubdir dlInfo) $ tmpUnpack ghcdir <- liftIO $ ghcupGHCDir tver - -- Be careful about cleanup. We must catch both pure exceptions - -- as well as async ones. - flip onException - (liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive ghcdir) - $ catchAllE - (\es -> - liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir) - >> throwE (BuildFailed workdir es) - ) - $ compile bghc ghcdir workdir - markSrcBuilt ghcdir workdir - - -- only clean up dir if the build succeeded - liftIO $ deleteDirRecursive tmpUnpack + liftE $ runBuildAction + tmpUnpack + (Just ghcdir) + (compile bghc ghcdir workdir >> markSrcBuilt ghcdir workdir) reThrowAll GHCupSetError $ postGHCInstall tver pure () @@ -666,7 +644,11 @@ compileCabal dls tver bghc jobs patchdir = do let workdir = maybe id (flip ()) (view dlSubdir dlInfo) $ tmpUnpack - reThrowAll (BuildFailed workdir) $ compile workdir + + liftE $ runBuildAction + tmpUnpack + Nothing + (compile workdir) -- only clean up dir if the build succeeded liftIO $ deleteDirRecursive tmpUnpack diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index b17feaf..e5c8338 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -142,10 +142,17 @@ data URLSource = GHCupURL data Settings = Settings { cache :: Bool , noVerify :: Bool + , keepDirs :: KeepDirs } deriving Show +data KeepDirs = Always + | Errors + | Never + deriving (Eq, Show, Ord) + + data DebugInfo = DebugInfo { diBaseDir :: Path Abs , diBinDir :: Path Abs diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index fc85483..9ebe964 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -406,3 +406,40 @@ getChangeLog dls tool (Right tag) = preview % viChangeLog % _Just ) dls + + +-- | Execute a build action while potentially cleaning up: +-- +-- 1. the build directory, depending on the KeepDirs setting +-- 2. the install destination, depending on whether the build failed +runBuildAction :: (Show (V e), MonadReader Settings m, MonadIO m, MonadMask m) + => Path Abs -- ^ build directory + -> Maybe (Path Abs) -- ^ install location (e.g. for GHC) + -> Excepts e m () + -> Excepts '[BuildFailed] m () +runBuildAction bdir instdir action = do + Settings {..} <- lift ask + flip + onException + (do + forM_ instdir $ \dir -> + liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir + when (keepDirs == Never) + $ liftIO + $ hideError doesNotExistErrorType + $ deleteDirRecursive bdir + ) + $ catchAllE + (\es -> do + forM_ instdir $ \dir -> + liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir + when (keepDirs == Never) + $ liftIO + $ hideError doesNotExistErrorType + $ deleteDirRecursive bdir + throwE (BuildFailed bdir es) + ) + $ action + + when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive + bdir