Implement --keep

2020-04-22 18:12:40 +02:00 · 2020-04-22 18:12:40 +02:00 · bcaccaaf31
parent 818a5d2d85
commit bcaccaaf31
5 changed files with 92 additions and 46 deletions
--- 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 ())
--- 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 "<always|errors|never>"
+          <> 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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
            (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 <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                          [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}|])
--- 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
--- 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
--- 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