From fee99c76c5233e99d6aaf458fb733281410c1419 Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Sun, 15 May 2016 02:51:03 -0700 Subject: [PATCH] Have upgrade only use CLI and global conf #1392 --- src/Stack/Config.hs | 2 -- src/Stack/Types/Config.hs | 2 -- src/Stack/Upgrade.hs | 24 ++++++++---------- src/main/Main.hs | 52 ++++++++++++++++++++++++++------------- 4 files changed, 45 insertions(+), 35 deletions(-) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index eec7a1a2..53ceb008 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -243,8 +243,6 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c configRequireStackVersion = simplifyVersionRange (getIntersectingVersionRange configMonoidRequireStackVersion) - configConfigMonoid = configMonoid - configImage = Image.imgOptsFromMonoid configMonoidImageOpts configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 17440ee7..9ced2480 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -286,8 +286,6 @@ data Config = -- ^ --extra-include-dirs arguments ,configExtraLibDirs :: !(Set Text) -- ^ --extra-lib-dirs arguments - ,configConfigMonoid :: !ConfigMonoid - -- ^ @ConfigMonoid@ used to generate this ,configConcurrentTests :: !Bool -- ^ Run test suites concurrently ,configImage :: !ImageOpts diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index db29ab9e..57f21691 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -8,13 +8,12 @@ import Control.Monad (when) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Reader (MonadReader) import Control.Monad.Trans.Control import Data.Foldable (forM_) import qualified Data.Map as Map import Data.Maybe (isNothing) import Data.Monoid.Extra -import qualified Data.Monoid import qualified Data.Text as T import Lens.Micro (set) import Network.HTTP.Client.Conduit (HasHttpManager) @@ -33,11 +32,12 @@ import System.Process (readProcess) import System.Process.Run upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m) - => Maybe String -- ^ git repository to use + => ConfigMonoid + -> Maybe String -- ^ git repository to use -> Maybe AbstractResolver -> Maybe String -- ^ git hash at time of building, if known -> m () -upgrade gitRepo mresolver builtHash = +upgrade gConfigMonoid gitRepo mresolver builtHash = withSystemTempDir "stack-upgrade" $ \tmp -> do menv <- getMinimalEnvOverride mdir <- case gitRepo of @@ -89,19 +89,15 @@ upgrade gitRepo mresolver builtHash = Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found" Just path -> return $ Just path - config <- asks getConfig forM_ mdir $ \dir -> do - bconfig <- runInnerStackLoggingT $ do - lc <- loadConfig - (configConfigMonoid config <> Data.Monoid.mempty - { configMonoidInstallGHC = First (Just True) - }) - mresolver - (Just $ dir $(mkRelFile "stack.yaml")) - lcLoadBuildConfig lc Nothing + lc <- loadConfig + gConfigMonoid + mresolver + (Just $ dir $(mkRelFile "stack.yaml")) + bconfig <- lcLoadBuildConfig lc Nothing envConfig1 <- runInnerStackT bconfig $ setupEnv $ Just $ "Try rerunning with --install-ghc to install the correct GHC into " <> - T.pack (toFilePath (configLocalPrograms config)) + T.pack (toFilePath (configLocalPrograms (getConfig bconfig))) runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True envConfig1) $ build (const $ return ()) Nothing defaultBuildOptsCLI { boptsCLITargets = ["stack"] diff --git a/src/main/Main.hs b/src/main/Main.hs index 65d0aefc..1972c3c6 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -827,31 +827,48 @@ withUserFileLock go@GlobalOpts{} dir act = do act $ Just lk)) else act Nothing -withConfigAndLock :: GlobalOpts - -> StackT Config IO () - -> IO () +withConfigAndLock + :: GlobalOpts + -> StackT Config IO () + -> IO () withConfigAndLock go@GlobalOpts{..} inner = do (manager, lc) <- loadConfigWithOpts go withUserFileLock go (configStackRoot $ lcConfig lc) $ \lk -> - runStackTGlobal manager (lcConfig lc) go $ - Docker.reexecWithOptionalContainer (lcProjectRoot lc) - Nothing - (runStackTGlobal manager (lcConfig lc) go inner) - Nothing - (Just $ munlockFile lk) + runStackTGlobal manager (lcConfig lc) go $ + Docker.reexecWithOptionalContainer + (lcProjectRoot lc) + Nothing + (runStackTGlobal manager (lcConfig lc) go inner) + Nothing + (Just $ munlockFile lk) + +-- | Loads global config, ignoring any configuration which would be +-- loaded due to $PWD. +withGlobalConfigAndLock + :: GlobalOpts + -> StackT Config IO () + -> IO () +withGlobalConfigAndLock go@GlobalOpts{..} inner = do + manager <- newTLSManager + lc <- runStackLoggingTGlobal manager go $ + loadConfigMaybeProject globalConfigMonoid Nothing Nothing + withUserFileLock go (configStackRoot $ lcConfig lc) $ \_lk -> + runStackTGlobal manager (lcConfig lc) go inner -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point. -withBuildConfig :: GlobalOpts - -> StackT EnvConfig IO () - -> IO () +withBuildConfig + :: GlobalOpts + -> StackT EnvConfig IO () + -> IO () withBuildConfig go inner = withBuildConfigAndLock go (\lk -> do munlockFile lk inner) -withBuildConfigAndLock :: GlobalOpts - -> (Maybe FileLock -> StackT EnvConfig IO ()) - -> IO () +withBuildConfigAndLock + :: GlobalOpts + -> (Maybe FileLock -> StackT EnvConfig IO ()) + -> IO () withBuildConfigAndLock go inner = withBuildConfigExt go Nothing inner Nothing @@ -956,8 +973,9 @@ updateCmd () go = withConfigAndLock go $ getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices upgradeCmd :: (Bool, String) -> GlobalOpts -> IO () -upgradeCmd (fromGit, repo) go = withConfigAndLock go $ - upgrade (if fromGit then Just repo else Nothing) +upgradeCmd (fromGit, repo) go = withGlobalConfigAndLock go $ do + upgrade (globalConfigMonoid go) + (if fromGit then Just repo else Nothing) (globalResolver go) #ifdef USE_GIT_INFO (find (/= "UNKNOWN") [$gitHash])