Implement an upgrade command #237

Also implemented #378 along the way

src/Stack/Config.hs

@@ -94,7 +94,7 @@ configFromConfigMonoid
     -> Maybe Project
     -> ConfigMonoid
     -> m Config
-configFromConfigMonoid configStackRoot mproject ConfigMonoid{..} = do
+configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = do
      let configDocker = Docker.dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts
          configConnectionCount = fromMaybe 8 configMonoidConnectionCount
          configHideTHLoading = fromMaybe True configMonoidHideTHLoading
@@ -130,6 +130,8 @@ configFromConfigMonoid configStackRoot mproject ConfigMonoid{..} = do
 
          configRequireStackVersion = simplifyVersionRange configMonoidRequireStackVersion
 
+         configConfigMonoid = configMonoid
+
      origEnv <- getEnvOverride configPlatform
      let configEnvOverride _ = return origEnv
 
@@ -229,11 +231,13 @@ instance HasPlatform MiniConfig
 loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)
            => ConfigMonoid
            -- ^ Config monoid from parsed command-line arguments
+           -> Maybe (Path Abs File)
+           -- ^ Override stack.yaml
            -> m (LoadConfig m)
-loadConfig configArgs = do
+loadConfig configArgs mstackYaml = do
     stackRoot <- determineStackRoot
     extraConfigs <- getExtraConfigs stackRoot >>= mapM loadYaml
-    mproject <- loadProjectConfig
+    mproject <- loadProjectConfig mstackYaml
     config <- configFromConfigMonoid stackRoot (fmap (\(proj, _, _) -> proj) mproject) $ mconcat $
         case mproject of
             Nothing -> configArgs : extraConfigs
@@ -455,8 +459,11 @@ loadYaml path =
 
 -- | Get the location of the project config file, if it exists.
 getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
-                 => m (Maybe (Path Abs File))
-getProjectConfig = do
+                 => Maybe (Path Abs File)
+                 -- ^ Override stack.yaml
+                 -> m (Maybe (Path Abs File))
+getProjectConfig (Just stackYaml) = return $ Just stackYaml
+getProjectConfig Nothing = do
     env <- liftIO getEnvironment
     case lookup "STACK_YAML" env of
         Just fp -> do
@@ -488,9 +495,11 @@ getProjectConfig = do
 -- and otherwise traversing parents. If no config is found, we supply a default
 -- based on current directory.
 loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
-                  => m (Maybe (Project, Path Abs File, ConfigMonoid))
-loadProjectConfig = do
-    mfp <- getProjectConfig
+                  => Maybe (Path Abs File)
+                  -- ^ Override stack.yaml
+                  -> m (Maybe (Project, Path Abs File, ConfigMonoid))
+loadProjectConfig mstackYaml = do
+    mfp <- getProjectConfig mstackYaml
     case mfp of
         Just fp -> do
             currDir <- getWorkingDir

src/Stack/Types/Config.hs

@@ -95,6 +95,8 @@ data Config =
          -- ^ --extra-include-dirs arguments
          ,configExtraLibDirs        :: !(Set Text)
          -- ^ --extra-lib-dirs arguments
+         ,configConfigMonoid        :: !ConfigMonoid
+         -- ^ @ConfigMonoid@ used to generate this
          }
 
 -- | Information on a single package index

src/Stack/Upgrade.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TemplateHaskell       #-}
+module Stack.Upgrade (upgrade) where
+
+import           Control.Monad.Catch
+import           Control.Monad.IO.Class
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Control
+import qualified Data.Map                    as Map
+import qualified Data.Set                    as Set
+import           Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager)
+import           Path
+import           Stack.Build
+import           Stack.Build.Types
+import           Stack.Config
+import           Stack.Fetch
+import           Stack.PackageIndex
+import           Stack.Setup
+import           Stack.Types
+import           Stack.Types.Internal
+import           Stack.Types.StackT
+import           System.IO.Temp              (withSystemTempDirectory)
+import           System.Process.Run
+
+upgrade :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, HasTerminal env, HasLogLevel env, MonadBaseControl IO m)
+        => Bool -- ^ use Git?
+        -> Maybe Resolver
+        -> m ()
+upgrade fromGit mresolver = withSystemTempDirectory "stack-upgrade" $ \tmp' -> do
+    menv <- getMinimalEnvOverride
+    tmp <- parseAbsDir tmp'
+    dir <-
+        if fromGit
+            then do
+                $logInfo "Cloning stack"
+                runIn tmp "git" menv
+                    [ "clone"
+                    , "git@github.com:commercialhaskell/stack" -- TODO allow to be configured
+                    , "stack"
+                    , "--depth"
+                    , "1"
+                    ]
+                    Nothing
+                return $ tmp </> $(mkRelDir "stack")
+                    -- Stack.PackageIndex.updateAllIndices menv
+            else do
+                -- updateAllIndices menv
+                caches <- getPackageCaches menv
+                let latest = Map.fromListWith max
+                           $ map toTuple
+                           $ Map.keys caches
+                case Map.lookup $(mkPackageName "stack") latest of
+                    Nothing -> error "No stack found in package indices"
+                    Just version -> do
+                        let ident = PackageIdentifier $(mkPackageName "stack") version
+                        paths <- unpackPackageIdents menv tmp Nothing $ Set.singleton ident
+                        case Map.lookup ident paths of
+                            Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found"
+                            Just path -> return path
+
+    manager <- asks getHttpManager
+    logLevel <- asks getLogLevel
+    terminal <- asks getTerminal
+    configMonoid <- asks $ configConfigMonoid . getConfig
+
+    liftIO $ do
+        bconfig <- runStackLoggingT manager logLevel terminal $ do
+            lc <- loadConfig
+                configMonoid
+                (Just $ dir </> $(mkRelFile "stack.yaml"))
+            lcLoadBuildConfig lc mresolver ThrowException
+        envConfig1 <- runStackT manager logLevel bconfig terminal setupEnv
+        runStackT manager logLevel envConfig1 terminal $ build BuildOpts
+            { boptsTargets = ["stack"]
+            , boptsLibProfile = False
+            , boptsExeProfile = False
+            , boptsEnableOptimizations = Nothing
+            , boptsHaddock = False
+            , boptsHaddockDeps = Nothing
+            , boptsFinalAction = DoNothing
+            , boptsDryrun = False
+            , boptsGhcOptions = []
+            , boptsFlags = Map.empty
+            , boptsInstallExes = True
+            , boptsPreFetch = False
+            , boptsTestArgs = []
+            , boptsOnlySnapshot = False
+            , boptsCoverage = False
+            }

src/main/Main.hs

@@ -52,7 +52,9 @@ import           Stack.Solver (solveExtraDeps)
 import           Stack.Types
 import           Stack.Types.Internal
 import           Stack.Types.StackT
+import           Stack.Upgrade
 import qualified Stack.Upload as Upload
+import           System.Directory (canonicalizePath)
 import           System.Environment (getArgs, getProgName)
 import           System.Exit
 import           System.FilePath (searchPathSeparator)
@@ -137,6 +139,13 @@ main =
                         "Update the package index"
                         updateCmd
                         (pure ())
+             addCommand "upgrade"
+                        "Upgrade to the latest stack (experimental)"
+                        upgradeCmd
+                        (switch
+                            ( long "git"
+                           <> help "Clone from Git instead of downloading from Hackage (more dangerous)"
+                            ))
              addCommand "upload"
                         "Upload a package to Hackage"
                         uploadCmd
@@ -499,6 +508,14 @@ updateCmd () go@GlobalOpts{..} = do
             runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
                 getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices
 
+upgradeCmd :: Bool -> GlobalOpts -> IO ()
+upgradeCmd fromGit go@GlobalOpts{..} = do
+    (manager,lc) <- loadConfigWithOpts go
+    runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.rerunWithOptionalContainer (lcProjectRoot lc) $
+            runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+                upgrade fromGit globalResolver
+
 -- | Upload to Hackage
 uploadCmd :: [String] -> GlobalOpts -> IO ()
 uploadCmd args0 go = do
@@ -702,7 +719,11 @@ globalOpts defaultTerminal =
         False
         (long "no-terminal" <>
          help
-             "Override terminal detection in the case of running in a false terminal")
+             "Override terminal detection in the case of running in a false terminal") <*>
+    (optional (strOption
+        (long "stack-yaml" <>
+         metavar "STACK-YAML" <>
+         help "Override project stack.yaml file (overrides any STACK_YAML environment variable)")))
 
 -- | Parse for a logging level.
 logLevelOpt :: Parser LogLevel
@@ -748,18 +769,25 @@ data GlobalOpts = GlobalOpts
     , globalConfigMonoid :: ConfigMonoid -- ^ Config monoid, for passing into 'loadConfig'
     , globalResolver     :: Maybe Resolver -- ^ Resolver override
     , globalTerminal     :: Bool -- ^ We're in a terminal?
+    , globalStackYaml    :: Maybe FilePath -- ^ Override project stack.yaml
     } deriving (Show)
 
 -- | Load the configuration with a manager. Convenience function used
 -- throughout this module.
 loadConfigWithOpts :: GlobalOpts -> IO (Manager,LoadConfig (StackLoggingT IO))
 loadConfigWithOpts GlobalOpts{..} = do
     manager <- newTLSManager
+    mstackYaml <-
+        case globalStackYaml of
+            Nothing -> return Nothing
+            Just fp -> do
+                path <- canonicalizePath fp >>= parseAbsFile
+                return $ Just path
     lc <- runStackLoggingT
               manager
               globalLogLevel
               globalTerminal
-              (loadConfig globalConfigMonoid)
+              (loadConfig globalConfigMonoid mstackYaml)
     return (manager,lc)
 
 -- | Project initialization

src/test/Stack/BuildPlanSpec.hs

@@ -39,7 +39,7 @@ main = hspec spec
 spec :: Spec
 spec = beforeAll setup $ afterAll teardown $ do
     let logLevel = LevelDebug
-    let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty)
+    let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty Nothing)
     let loadBuildConfigRest m = runStackLoggingT m logLevel False
     let inTempDir action = do
             currentDirectory <- getCurrentDirectory

src/test/Stack/ConfigSpec.hs

@@ -60,7 +60,7 @@ spec = beforeAll setup $ afterAll teardown $ do
 
 
   describe "loadConfig" $ do
-    let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty)
+    let loadConfig' m = runStackLoggingT m logLevel False (loadConfig mempty Nothing)
     let loadBuildConfigRest m = runStackLoggingT m logLevel False
     -- TODO(danburton): make sure parent dirs also don't have config file
     it "works even if no config file exists" $ \T{..} -> example $ do

stack.cabal

@@ -78,6 +78,7 @@ library
                      Stack.Build.Installed
                      Stack.Build.Source
                      Stack.Build.Types
+                     Stack.Upgrade
                      Stack.Upload
                      System.Process.Read
                      System.Process.Log