Merge pull request #1202 from commercialhaskell/115-set-resolver

Stack config add resolver command

src/Stack/ConfigCmd.hs

@@ -0,0 +1,68 @@
+{-# 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 as S
+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 <- 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 <- fmap 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
+        (S.writeFile
+             stackYamlFp
+             (Yaml.encode projectYamlConfig'))
+    return ()
+
+cfgCmdName :: String
+cfgCmdName = "config"
+
+cfgCmdSetName :: String
+cfgCmdSetName = "set"

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"

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

stack.cabal

@@ -52,6 +52,7 @@ library
                      Stack.BuildPlan
                      Stack.Config
                      Stack.Config.Docker
+                     Stack.ConfigCmd
                      Stack.Constants
                      Stack.Docker
                      Stack.Docker.GlobalDB

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)