Docker: move into StackT

borsboom · borsboom · commit 0860f0bcc94f · 2015-06-22T05:38:58.000-07:00
diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns,
+{-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns,
              OverloadedStrings, RankNTypes, RecordWildCards, TemplateHaskell, TupleSections #-}
 
 -- | Run commands in Docker containers
@@ -22,9 +22,10 @@ module Stack.Docker
 import           Control.Applicative
 import           Control.Exception.Lifted
 import           Control.Monad
-import           Control.Monad.Catch (MonadThrow, throwM, MonadCatch)
+import           Control.Monad.Catch (MonadThrow,throwM,MonadCatch)
 import           Control.Monad.IO.Class (MonadIO,liftIO)
 import           Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn)
+import           Control.Monad.Reader (MonadReader,asks)
 import           Control.Monad.Writer (execWriter,runWriter,tell)
 import           Control.Monad.Trans.Control (MonadBaseControl)
 import           Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
@@ -49,6 +50,7 @@ import           Path
 import           Path.IO (getWorkingDir,listDirectory)
 import           Stack.Constants (projectDockerSandboxDir,stackProgName,stackDotYaml,stackRootEnvVar)
 import           Stack.Types
+import           Stack.Types.Internal
 import           Stack.Docker.GlobalDB
 import           System.Directory (createDirectoryIfMissing,removeDirectoryRecursive,removeFile)
 import           System.Directory (doesDirectoryExist)
@@ -70,10 +72,12 @@ import           System.Posix.Signals (installHandler,sigTERM,Handler(Catch))
 -- | If Docker is enabled, re-runs the currently running OS command in a Docker container.
 -- Otherwise, runs the inner action.
 rerunWithOptionalContainer
-    :: (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
-    => Config -> Maybe (Path Abs Dir) -> IO () -> m ()
-rerunWithOptionalContainer config mprojectRoot =
-  rerunCmdWithOptionalContainer config mprojectRoot getCmdArgs
+    :: M env m
+    => Maybe (Path Abs Dir)
+    -> IO ()
+    -> m ()
+rerunWithOptionalContainer mprojectRoot =
+  rerunCmdWithOptionalContainer mprojectRoot getCmdArgs
   where
     getCmdArgs =
       do args <- getArgs
@@ -82,41 +86,41 @@ rerunWithOptionalContainer config mprojectRoot =
                      let mountPath = concat ["/opt/host/bin/",takeBaseName exePath]
                      return (mountPath
                             ,args
-                            ,config{configDocker=docker{dockerMount=Mount exePath mountPath :
-                                                                    dockerMount docker}})
+                            ,\c -> c{configDocker=(configDocker c)
+                                                  {dockerMount=Mount exePath mountPath :
+                                                               dockerMount (configDocker c)}})
              else do progName <- getProgName
-                     return (takeBaseName progName,args,config)
-    docker = configDocker config
+                     return (takeBaseName progName,args,id)
 
 -- | If Docker is enabled, re-runs the OS command returned by the second argument in a
 -- Docker container.  Otherwise, runs the inner action.
 rerunCmdWithOptionalContainer
-    :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m, MonadCatch m)
-    => Config
-    -> Maybe (Path Abs Dir)
-    -> IO (FilePath,[String],Config)
+    :: M env m
+    => Maybe (Path Abs Dir)
+    -> IO (FilePath,[String],Config -> Config)
     -> IO ()
     -> m ()
-rerunCmdWithOptionalContainer config mprojectRoot getCmdArgs inner =
-  do inContainer <- getInContainer
+rerunCmdWithOptionalContainer mprojectRoot getCmdArgs inner =
+  do config <- asks getConfig
+     inContainer <- getInContainer
      if inContainer || not (dockerEnable (configDocker config))
         then liftIO inner
-        else do (cmd_,args,config') <- liftIO getCmdArgs
-                runContainerAndExit config' mprojectRoot cmd_ args [] (return ())
+        else do (cmd_,args,modConfig) <- liftIO getCmdArgs
+                runContainerAndExit modConfig mprojectRoot cmd_ args [] (return ())
 
 -- | If Docker is enabled, re-runs the OS command returned by the second argument in a
 -- Docker container.  Otherwise, runs the inner action.
 rerunCmdWithRequiredContainer
-    :: (MonadLogger m,MonadIO m,MonadThrow m,MonadBaseControl IO m, MonadCatch m)
-    => Config
-    -> Maybe (Path Abs Dir)
-    -> IO (FilePath,[String],Config)
+    :: M env m
+    => Maybe (Path Abs Dir)
+    -> IO (FilePath,[String],Config -> Config)
     -> m ()
-rerunCmdWithRequiredContainer config mprojectRoot getCmdArgs =
-  do when (not (dockerEnable (configDocker config)))
+rerunCmdWithRequiredContainer mprojectRoot getCmdArgs =
+  do config <- asks getConfig
+     when (not (dockerEnable (configDocker config)))
           (throwM DockerMustBeEnabledException)
-     (cmd_,args,config') <- liftIO getCmdArgs
-     runContainerAndExit config' mprojectRoot cmd_ args [] (return ())
+     (cmd_,args,modConfig) <- liftIO getCmdArgs
+     runContainerAndExit modConfig mprojectRoot cmd_ args [] (return ())
 
 -- | Error if running in a container.
 preventInContainer :: (MonadIO m,MonadThrow m) => m () -> m ()
@@ -135,21 +139,23 @@ getInContainer =
        Just _ -> return True
 
 -- | Run a command in a new Docker container, then exit the process.
-runContainerAndExit :: (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
-                    => Config
+runContainerAndExit :: M env m
+                    => (Config -> Config)
                     -> Maybe (Path Abs Dir)
                     -> FilePath
                     -> [String]
                     -> [(String, String)]
                     -> IO ()
                     -> m ()
-runContainerAndExit config
+runContainerAndExit modConfig
                     mprojectRoot
                     cmnd
                     args
                     envVars
                     successPostAction =
-  do envOverride <- getEnvOverride (configPlatform config)
+  do config <- fmap modConfig (asks getConfig)
+     let docker = configDocker config
+     envOverride <- getEnvOverride (configPlatform config)
      checkDockerVersion envOverride
      uidOut <- readProcessStdout Nothing envOverride "id" ["-u"]
      gidOut <- readProcessStdout Nothing envOverride "id" ["-g"]
@@ -275,13 +281,13 @@ runContainerAndExit config
     sandboxSubdirArg subdir = ["-v",toFPNoTrailingSep subdir++ ":" ++ toFPNoTrailingSep subdir]
     toFPNoTrailingSep = dropTrailingPathSeparator . toFilePath
     projectRoot = fromMaybeProjectRoot mprojectRoot
-    docker = configDocker config
 
 -- | Clean-up old docker images and containers.
-cleanup :: (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
-        => Config -> CleanupOpts -> m ()
-cleanup config opts =
-  do envOverride <- getEnvOverride (configPlatform config)
+cleanup :: M env m
+        => CleanupOpts -> m ()
+cleanup opts =
+  do config <- asks getConfig
+     envOverride <- getEnvOverride (configPlatform config)
      checkDockerVersion envOverride
      let runDocker = readDockerProcess envOverride
      imagesOut <- runDocker ["images","--no-trunc","-f","dangling=false"]
@@ -529,13 +535,13 @@ inspects envOverride images =
        Left e -> throwM e
 
 -- | Pull latest version of configured Docker image from registry.
-pull :: (MonadLogger m, MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
-     => Config -> m ()
-pull config =
-  do envOverride <- getEnvOverride (configPlatform config)
+pull :: M env m => m ()
+pull =
+  do config <- asks getConfig
+     let docker = configDocker config
+     envOverride <- getEnvOverride (configPlatform config)
      checkDockerVersion envOverride
      pullImage envOverride docker (dockerImage docker)
-  where docker = configDocker config
 
 -- | Pull Docker image from registry.
 pullImage :: (MonadLogger m,MonadIO m,MonadThrow m)
@@ -948,3 +954,6 @@ instance Show StackDockerException where
     "Cannot find 'docker' in PATH.  Is Docker installed?"
   show (InvalidDatabasePathException ex) =
     concat ["Invalid database path: ",show ex]
+
+type M env m = (MonadIO m,MonadReader env m,MonadLogger m,MonadBaseControl IO m,MonadCatch m
+               ,HasConfig env,HasTerminal env)
diff --git a/src/main/Main.hs b/src/main/Main.hs
@@ -366,9 +366,8 @@ setupParser = SetupCmdOpts
 setupCmd :: SetupCmdOpts -> GlobalOpts -> IO ()
 setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do
   (manager,lc) <- loadConfigWithOpts go
-  runStackLoggingT manager globalLogLevel globalTerminal $
+  runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
       Docker.rerunWithOptionalContainer
-          (lcConfig lc)
           (lcProjectRoot lc)
           (runStackLoggingT manager globalLogLevel globalTerminal $ do
               (ghc, mstack) <-
@@ -399,8 +398,8 @@ withBuildConfig :: GlobalOpts
                 -> IO ()
 withBuildConfig go@GlobalOpts{..} strat inner = do
     (manager, lc) <- loadConfigWithOpts go
-    runStackLoggingT manager globalLogLevel globalTerminal $
-        Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $ do
+    runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.rerunWithOptionalContainer (lcProjectRoot lc) $ do
             bconfig <- runStackLoggingT manager globalLogLevel globalTerminal $
                 lcLoadBuildConfig lc globalResolver strat
             envConfig <-
@@ -460,8 +459,8 @@ installCmd opts go@GlobalOpts{..} = withBuildConfig go ExecStrategy $
 unpackCmd :: [String] -> GlobalOpts -> IO ()
 unpackCmd names go@GlobalOpts{..} = do
     (manager,lc) <- loadConfigWithOpts go
-    runStackLoggingT manager globalLogLevel globalTerminal $
-        Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $
+    runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.rerunWithOptionalContainer (lcProjectRoot lc) $
             runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ do
                 menv <- getMinimalEnvOverride
                 Stack.Fetch.unpackPackages menv "." names
@@ -470,8 +469,8 @@ unpackCmd names go@GlobalOpts{..} = do
 updateCmd :: () -> GlobalOpts -> IO ()
 updateCmd () go@GlobalOpts{..} = do
     (manager,lc) <- loadConfigWithOpts go
-    runStackLoggingT manager globalLogLevel globalTerminal $
-        Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $
+    runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.rerunWithOptionalContainer (lcProjectRoot lc) $
             runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
                 getMinimalEnvOverride >>= Stack.PackageIndex.updateAllIndices
 
@@ -506,8 +505,8 @@ replCmd (targets,args,path) go@GlobalOpts{..} = withBuildConfig go ExecStrategy
 dockerPullCmd :: () -> GlobalOpts -> IO ()
 dockerPullCmd _ go@GlobalOpts{..} = do
     (manager,lc) <- liftIO $ loadConfigWithOpts go
-    runStackLoggingT manager globalLogLevel globalTerminal $ Docker.preventInContainer $
-        Docker.pull (lcConfig lc)
+    runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.preventInContainer Docker.pull
 
 -- | Reset the Docker sandbox.
 dockerResetCmd :: Bool -> GlobalOpts -> IO ()
@@ -520,17 +519,18 @@ dockerResetCmd keepHome go@GlobalOpts{..} = do
 dockerCleanupCmd :: Docker.CleanupOpts -> GlobalOpts -> IO ()
 dockerCleanupCmd cleanupOpts go@GlobalOpts{..} = do
     (manager,lc) <- liftIO $ loadConfigWithOpts go
-    runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $
-        Docker.cleanup (lcConfig lc) cleanupOpts
+    runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.preventInContainer $
+            Docker.cleanup cleanupOpts
 
 -- | Execute a command
 dockerExecCmd :: (String, [String]) -> GlobalOpts -> IO ()
 dockerExecCmd (cmd,args) go@GlobalOpts{..} = do
     (manager,lc) <- liftIO $ loadConfigWithOpts go
-    runStackLoggingT manager globalLogLevel globalTerminal$ Docker.preventInContainer $
-        Docker.rerunCmdWithRequiredContainer (lcConfig lc)
-                                             (lcProjectRoot lc)
-                                             (return (cmd,args,lcConfig lc))
+    runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.preventInContainer $
+            Docker.rerunCmdWithRequiredContainer (lcProjectRoot lc)
+                                                 (return (cmd,args,id))
 
 -- | Parser for build arguments.
 buildOpts :: Bool -> Parser BuildOpts
@@ -721,17 +721,17 @@ loadConfigWithOpts GlobalOpts{..} = do
 initCmd :: InitOpts -> GlobalOpts -> IO ()
 initCmd initOpts go@GlobalOpts{..} = do
   (manager,lc) <- loadConfigWithOpts go
-  runStackLoggingT manager globalLogLevel globalTerminal $
-        Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $
+  runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.rerunWithOptionalContainer (lcProjectRoot lc) $
             runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
                 initProject initOpts
 
 -- | Project creation
 newCmd :: InitOpts -> GlobalOpts -> IO ()
 newCmd initOpts go@GlobalOpts{..} = do
   (manager,lc) <- loadConfigWithOpts go
-  runStackLoggingT manager globalLogLevel globalTerminal $
-        Docker.rerunWithOptionalContainer (lcConfig lc) (lcProjectRoot lc) $
+  runStackT manager globalLogLevel (lcConfig lc) globalTerminal $
+        Docker.rerunWithOptionalContainer (lcProjectRoot lc) $
             runStackT manager globalLogLevel (lcConfig lc) globalTerminal $ do
                 newProject
                 initProject initOpts
