From fd597d882e09be9595693013ac4b181733f0521b Mon Sep 17 00:00:00 2001 From: Tristan Webb Date: Mon, 28 Sep 2015 23:42:21 -0700 Subject: [PATCH 1/2] Stack config add resolver command config selects the projects stack.yaml, regardless of directory Parsing of config add command Integration test helper (will be used to compare stack.yaml files) Check to see if snapshot exists before writing TODO: Adding differnt fields Additional subcommands for git --- src/Stack/ConfigCmd.hs | 71 +++++++++++++++++++++++++++++++ src/Stack/Options.hs | 30 +++++++++++-- src/main/Main.hs | 17 ++++++++ stack.cabal | 1 + test/integration/lib/StackTest.hs | 14 ++++++ 5 files changed, 130 insertions(+), 3 deletions(-) create mode 100644 src/Stack/ConfigCmd.hs diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs new file mode 100644 index 0000000000..5f87ff573a --- /dev/null +++ b/src/Stack/ConfigCmd.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Make changes to the stack yaml file + +module Stack.ConfigCmd + (ConfigCmdSet(..) + ,cfgCmdSet + ,cfgCmdSetName + ,cfgCmdName) where + +import Control.Monad.Catch (MonadMask, throwM, MonadThrow) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as L +import qualified Data.HashMap.Strict as HMap +import qualified Data.Yaml as Yaml +import Network.HTTP.Client.Conduit (HasHttpManager) +import Path +import Stack.BuildPlan +import Stack.Init +import Stack.Types + +data ConfigCmdSet = ConfigCmdSetResolver AbstractResolver + +cfgCmdSet :: ( MonadIO m + , MonadBaseControl IO m + , MonadMask m + , MonadReader env m + , HasConfig env + , HasBuildConfig env + , HasHttpManager env + , HasGHCVariant env + , MonadThrow m + , MonadLogger m) + => ConfigCmdSet -> m () +cfgCmdSet (ConfigCmdSetResolver newResolver) = do + stackYaml <- bcStackYaml <$> asks getBuildConfig + let stackYamlFp = + toFilePath stackYaml + -- We don't need to worry about checking for a valid yaml here + (projectYamlConfig :: Yaml.Object) <- + liftIO (Yaml.decodeFileEither stackYamlFp) >>= + either throwM return + newResolverText <- resolverName <$> makeConcreteResolver newResolver + -- We checking here that the snapshot actually exists + snap <- parseSnapName newResolverText + _ <- loadMiniBuildPlan snap + + let projectYamlConfig' = + HMap.insert + "resolver" + (Yaml.String newResolverText) + projectYamlConfig + liftIO + (L.writeFile + stackYamlFp + (B.toLazyByteString + (B.byteString + (Yaml.encode projectYamlConfig')))) + return () + +cfgCmdName :: String +cfgCmdName = "config" + +cfgCmdSetName :: String +cfgCmdSetName = "set" diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index fda0555d5d..f34bbd6812 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -4,6 +4,7 @@ module Stack.Options (Command(..) ,benchOptsParser ,buildOptsParser + ,configCmdSetParser ,configOptsParser ,dockerOptsParser ,dockerCleanupOptsParser @@ -36,8 +37,9 @@ import Data.Text.Read (decimal) import Options.Applicative.Args import Options.Applicative.Builder.Extra import Options.Applicative.Simple -import Options.Applicative.Types (readerAsk) +import Options.Applicative.Types (fromM, oneM, readerAsk) import Stack.Config (packagesParser) +import Stack.ConfigCmd import Stack.Constants (stackProgName) import Stack.Docker import qualified Stack.Docker as Docker @@ -701,5 +703,27 @@ pvpBoundsOption = readPvpBounds = do s <- readerAsk case parsePvpBounds $ T.pack s of - Left e -> readerError e - Right v -> return v + Left e -> + readerError e + Right v -> + return v + +configCmdSetParser :: Parser ConfigCmdSet +configCmdSetParser = + fromM + (do field <- + oneM + (strArgument + (metavar "FIELD VALUE")) + oneM (fieldToValParser field)) + where + fieldToValParser :: String -> Parser ConfigCmdSet + fieldToValParser s = do + case s of + "resolver" -> + ConfigCmdSetResolver <$> + argument + readAbstractResolver + idm + _ -> + error "parse stack config set field: only set resolver is implemented" diff --git a/src/main/Main.hs b/src/main/Main.hs index d5bfc9225f..075573c37d 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -50,6 +50,7 @@ import Prelude hiding (pi, mapM) import Stack.Build import Stack.Types.Build import Stack.Config +import Stack.ConfigCmd as ConfigCmd import Stack.Constants import qualified Stack.Docker as Docker import Stack.Dot @@ -305,6 +306,13 @@ main = withInterpreterArgs stackProgName $ \args isInterpreter -> do "Clean up Docker images and containers" dockerCleanupCmd dockerCleanupOptsParser) + addSubCommands + ConfigCmd.cfgCmdName + "Subcommands specific to modifying stack.yaml files" + (addCommand ConfigCmd.cfgCmdSetName + "Sets a field in the project's stack.yaml to value" + cfgSetCmd + configCmdSetParser) addSubCommands Image.imgCmdName "Subcommands specific to imaging (EXPERIMENTAL)" @@ -890,6 +898,15 @@ dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do Docker.preventInContainer $ Docker.cleanup cleanupOpts +cfgSetCmd :: ConfigCmd.ConfigCmdSet -> GlobalOpts -> IO () +cfgSetCmd co go@GlobalOpts{..} = do + withBuildConfigAndLock + go + (\_ -> do env <- ask + runReaderT + (cfgCmdSet co) + env) + imgDockerCmd :: () -> GlobalOpts -> IO () imgDockerCmd () go@GlobalOpts{..} = do withBuildConfigExt diff --git a/stack.cabal b/stack.cabal index 5ed01eebff..6208684976 100644 --- a/stack.cabal +++ b/stack.cabal @@ -52,6 +52,7 @@ library Stack.BuildPlan Stack.Config Stack.Config.Docker + Stack.ConfigCmd Stack.Constants Stack.Docker Stack.Docker.GlobalDB diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs index e0170c6e17..1a1e435306 100644 --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -71,3 +71,17 @@ copy :: FilePath -> FilePath -> IO () copy src dest = do putStrLn ("Copy " ++ show src ++ " to " ++ show dest) System.Directory.copyFile src dest + +fileContentsMatch :: FilePath -> FilePath -> IO () +fileContentsMatch f1 f2 = do + doesExist f1 + doesExist f2 + f1Contents <- readFile f1 + f2Contents <- readFile f2 + if f1Contents == f2Contents + then return () + else error + ("contents do not match for " ++ + show f1 ++ + " " ++ + show f2) From c86302276b209866d0814afbab5089d10dfa8f43 Mon Sep 17 00:00:00 2001 From: Tristan Webb Date: Tue, 20 Oct 2015 08:57:10 -0700 Subject: [PATCH 2/2] Fix 7.8.4 compile and remove unnecessary --- src/Stack/ConfigCmd.hs | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/src/Stack/ConfigCmd.hs b/src/Stack/ConfigCmd.hs index 5f87ff573a..987845583f 100644 --- a/src/Stack/ConfigCmd.hs +++ b/src/Stack/ConfigCmd.hs @@ -15,8 +15,7 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (MonadReader, asks) import Control.Monad.Trans.Control (MonadBaseControl) -import qualified Data.ByteString.Builder as B -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S import qualified Data.HashMap.Strict as HMap import qualified Data.Yaml as Yaml import Network.HTTP.Client.Conduit (HasHttpManager) @@ -39,14 +38,14 @@ cfgCmdSet :: ( MonadIO m , MonadLogger m) => ConfigCmdSet -> m () cfgCmdSet (ConfigCmdSetResolver newResolver) = do - stackYaml <- bcStackYaml <$> asks getBuildConfig + stackYaml <- fmap bcStackYaml (asks getBuildConfig) let stackYamlFp = toFilePath stackYaml -- We don't need to worry about checking for a valid yaml here (projectYamlConfig :: Yaml.Object) <- liftIO (Yaml.decodeFileEither stackYamlFp) >>= either throwM return - newResolverText <- resolverName <$> makeConcreteResolver newResolver + newResolverText <- fmap resolverName (makeConcreteResolver newResolver) -- We checking here that the snapshot actually exists snap <- parseSnapName newResolverText _ <- loadMiniBuildPlan snap @@ -57,11 +56,9 @@ cfgCmdSet (ConfigCmdSetResolver newResolver) = do (Yaml.String newResolverText) projectYamlConfig liftIO - (L.writeFile + (S.writeFile stackYamlFp - (B.toLazyByteString - (B.byteString - (Yaml.encode projectYamlConfig')))) + (Yaml.encode projectYamlConfig')) return () cfgCmdName :: String