Merge pull request #1442 from mrkkrp/mrkkrp-configurable-stack-work

Addition of ‘--work-dir’ option to override working directory, #1178

Author: mgsloan

src/Stack/Build/Execute.hs

@@ -91,7 +91,7 @@ import           System.Process.Run
 import           System.Process.Internals (createProcess_)
 #endif
 
-type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env, HasConfig env)
 
 -- | Fetch the packages necessary for a build, for example in combination with a dry run.
 preFetch :: M env m => Plan -> m ()

src/Stack/Config.hs

@@ -99,8 +99,8 @@ configFromConfigMonoid
     -> Maybe (Project, Path Abs File)
     -> ConfigMonoid
     -> m Config
-configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject
-                       configMonoid@ConfigMonoid{..} = do
+configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject configMonoid@ConfigMonoid{..} = do
+     configWorkDir <- parseRelDir (fromMaybe ".stack-work" configMonoidWorkDir)
      let configConnectionCount = fromMaybe 8 configMonoidConnectionCount
          configHideTHLoading = fromMaybe True configMonoidHideTHLoading
          configLatestSnapshotUrl = fromMaybe
@@ -416,7 +416,7 @@ loadBuildConfig mproject config mresolver mcompiler = do
 -- necessary.
 resolvePackageEntry
     :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m
-       ,MonadBaseControl IO m)
+       ,MonadBaseControl IO m, HasConfig env)
     => EnvOverride
     -> Path Abs Dir -- ^ project root
     -> PackageEntry
@@ -436,19 +436,20 @@ resolvePackageEntry menv projRoot pe = do
 -- necessary.
 resolvePackageLocation
     :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m
-       ,MonadBaseControl IO m)
+       ,MonadBaseControl IO m, HasConfig env)
     => EnvOverride
     -> Path Abs Dir -- ^ project root
     -> PackageLocation
     -> m (Path Abs Dir)
 resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp
 resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
+    workDir <- getWorkDir
     let nameBeforeHashing = case remotePackageType of
             RPTHttpTarball -> url
             RPTGit commit  -> T.unwords [url, commit]
             RPTHg  commit  -> T.unwords [url, commit, "hg"]
         name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing
-        root = projRoot </> workDirRel </> $(mkRelDir "downloaded")
+        root = projRoot </> workDir </> $(mkRelDir "downloaded")
         fileExtension = case remotePackageType of
             RPTHttpTarball -> ".tar.gz"
             _              -> ".unused"

src/Stack/Constants.hs

@@ -122,8 +122,11 @@ userDocsDir :: Config -> Path Abs Dir
 userDocsDir config = configStackRoot config </> $(mkRelDir "doc/")
 
 -- | Output .o/.hi directory.
-objectInterfaceDir :: BuildConfig -> Path Abs Dir
-objectInterfaceDir bconfig = bcWorkDir bconfig </> $(mkRelDir "odir/")
+objectInterfaceDir :: (MonadReader env m, HasConfig env)
+  => BuildConfig -> m (Path Abs Dir)
+objectInterfaceDir bconfig = do
+  bcwd <- bcWorkDir bconfig
+  return (bcwd </> $(mkRelDir "odir/"))
 
 -- | The filename used for dirtiness check of source files.
 buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
@@ -218,8 +221,9 @@ distRelativeDir = do
         packageIdentifierString $
         PackageIdentifier cabalPackageName cabalPkgVer
     platformAndCabal <- useShaPathOnWindows (platform </> envDir)
+    workDir <- getWorkDir
     return $
-        workDirRel </>
+        workDir </>
         $(mkRelDir "dist") </>
         platformAndCabal
 
@@ -255,12 +259,20 @@ rawGithubUrl org repo branch file = T.concat
 -- haddockExtension = "haddock"
 
 -- | Docker sandbox from project root.
-projectDockerSandboxDir :: Path Abs Dir -> Path Abs Dir
-projectDockerSandboxDir projectRoot = projectRoot </> workDirRel </> $(mkRelDir "docker/")
+projectDockerSandboxDir :: (MonadReader env m, HasConfig env)
+  => Path Abs Dir      -- ^ Project root
+  -> m (Path Abs Dir)  -- ^ Docker sandbox
+projectDockerSandboxDir projectRoot = do
+  workDir <- getWorkDir
+  return $ projectRoot </> workDir </> $(mkRelDir "docker/")
 
 -- | Image staging dir from project root.
-imageStagingDir :: Path Abs Dir -> Path Abs Dir
-imageStagingDir p = p </> workDirRel </> $(mkRelDir "image/")
+imageStagingDir :: (MonadReader env m, HasConfig env)
+  => Path Abs Dir      -- ^ Project root
+  -> m (Path Abs Dir)  -- ^ Docker sandbox
+imageStagingDir projectRoot = do
+  workDir <- getWorkDir
+  return $ projectRoot </> workDir </> $(mkRelDir "image/")
 
 -- | Name of the 'stack' program, uppercased
 stackProgNameUpper :: String

src/Stack/Docker.hs

@@ -234,11 +234,11 @@ getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
 
 -- | Run a command in a new Docker container, then exit the process.
 runContainerAndExit :: M env m
-                    => GetCmdArgs env m
-                    -> Maybe (Path Abs Dir)
-                    -> m ()
-                    -> m ()
-                    -> m ()
+  => GetCmdArgs env m
+  -> Maybe (Path Abs Dir) -- ^ Project root (maybe)
+  -> m ()              -- ^ Action to run before
+  -> m ()              -- ^ Action to run after
+  -> m ()
 runContainerAndExit getCmdArgs
                     mprojectRoot
                     before
@@ -272,11 +272,11 @@ runContainerAndExit getCmdArgs
                   Just ii2 -> return ii2
                   Nothing -> throwM (InspectFailedException image)
          | otherwise -> throwM (NotPulledException image)
+     sandboxDir <- projectDockerSandboxDir projectRoot
      let ImageConfig {..} = iiConfig
          imageEnvVars = map (break (== '=')) icEnv
          platformVariant = BS.unpack $ Hash.digestToHexByteString $ hashRepoName image
          stackRoot = configStackRoot config
-         sandboxDir = projectDockerSandboxDir projectRoot
          sandboxHomeDir = sandboxDir </> homeDirName
          isTerm = not (dockerDetach docker) &&
                   isStdinTerminal &&
@@ -687,10 +687,12 @@ checkDockerVersion envOverride docker =
         prohibitedDockerVersions = []
 
 -- | Remove the project's Docker sandbox.
-reset :: (MonadIO m) => Maybe (Path Abs Dir) -> Bool -> m ()
-reset maybeProjectRoot keepHome =
+reset :: (MonadIO m, MonadReader env m, HasConfig env)
+  => Maybe (Path Abs Dir) -> Bool -> m ()
+reset maybeProjectRoot keepHome = do
+  dockerSandboxDir <- projectDockerSandboxDir projectRoot
   liftIO (removeDirectoryContents
-            (projectDockerSandboxDir projectRoot)
+            dockerSandboxDir
             [homeDirName | keepHome]
             [])
   where projectRoot = fromMaybeProjectRoot maybeProjectRoot
@@ -699,7 +701,7 @@ reset maybeProjectRoot keepHome =
 -- a container, such as switching the UID/GID to the "outside-Docker" user's.
 entrypoint :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
            => Config -> DockerEntrypoint -> m ()
-entrypoint config@Config{..} DockerEntrypoint{..} = do
+entrypoint config@Config{..} DockerEntrypoint{..} =
   modifyMVar_ entrypointMVar $ \alreadyRan -> do
     -- Only run the entrypoint once
     unless alreadyRan $ do

src/Stack/Ghci.hs

@@ -106,13 +106,14 @@ ghci GhciOpts{..} = do
         $logWarn
             ("The following GHC options are incompatible with GHCi and have not been passed to it: " <>
              T.unwords (map T.pack (nubOrd omittedOpts)))
+    oiDir <- objectInterfaceDir bconfig
     let modulesToLoad = nubOrd $
             concatMap (map display . S.toList . ghciPkgModules) pkgs
         thingsToLoad =
             maybe [] (return . toFilePath) mainFile <> modulesToLoad
         odir =
-            [ "-odir=" <> toFilePathNoTrailingSep (objectInterfaceDir bconfig)
-            , "-hidir=" <> toFilePathNoTrailingSep (objectInterfaceDir bconfig)]
+            [ "-odir=" <> toFilePathNoTrailingSep oiDir
+            , "-hidir=" <> toFilePathNoTrailingSep oiDir ]
     $logInfo
         ("Configuring GHCi with the following packages: " <>
          T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs))
@@ -125,21 +126,21 @@ ghci GhciOpts{..} = do
                  -- include CWD.
                   "-i" :
                   odir <> pkgopts <> ghciArgs <> extras)
-    case ghciNoLoadModules of
-        True -> execGhci []
-        False -> do
-            tmp <- liftIO getTemporaryDirectory
-            withCanonicalizedTempDirectory
-                tmp
-                "ghci-script"
-                (\tmpDir ->
-                      do let scriptPath = tmpDir </> $(mkRelFile "ghci-script")
-                             fp = toFilePath scriptPath
-                             loadModules = ":load " <> unwords (map show thingsToLoad)
-                             bringIntoScope = ":module + " <> unwords modulesToLoad
-                         liftIO (writeFile fp (unlines [loadModules,bringIntoScope]))
-                         finally (execGhci ["-ghci-script=" <> fp])
-                                 (removeFile scriptPath))
+    if ghciNoLoadModules
+    then execGhci []
+    else do
+      tmp <- liftIO getTemporaryDirectory
+      withCanonicalizedTempDirectory
+          tmp
+          "ghci-script"
+          (\tmpDir ->
+                do let scriptPath = tmpDir </> $(mkRelFile "ghci-script")
+                       fp = toFilePath scriptPath
+                       loadModules = ":load " <> unwords (map show thingsToLoad)
+                       bringIntoScope = ":module + " <> unwords modulesToLoad
+                   liftIO (writeFile fp (unlines [loadModules,bringIntoScope]))
+                   finally (execGhci ["-ghci-script=" <> fp])
+                           (removeFile scriptPath))
 
 -- | Figure out the main-is file to load based on the targets. Sometimes there
 -- is none, sometimes it's unambiguous, sometimes it's

src/Stack/Image.hs

@@ -43,10 +43,9 @@ type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadCat
 
 -- | Stages the executables & additional content in a staging
 -- directory under '.stack-work'
-stageContainerImageArtifacts :: Build e m
-                             => m ()
+stageContainerImageArtifacts :: Build e m => m ()
 stageContainerImageArtifacts = do
-    imageDir <- imageStagingDir <$> getWorkingDir
+    imageDir <- getWorkingDir >>= imageStagingDir
     removeTreeIfExists imageDir
     createTree imageDir
     stageExesInDir imageDir
@@ -56,10 +55,9 @@ stageContainerImageArtifacts = do
 -- specified in the project's stack.yaml.  Then new image will be
 -- extended with an ENTRYPOINT specified for each `entrypoint` listed
 -- in the config file.
-createContainerImageFromStage :: Assemble e m
-                              => m ()
+createContainerImageFromStage :: Assemble e m => m ()
 createContainerImageFromStage = do
-    imageDir <- imageStagingDir <$> getWorkingDir
+    imageDir <- getWorkingDir >>= imageStagingDir
     createDockerImage imageDir
     extendDockerImageWithEntrypoint imageDir
 

src/Stack/Options.hs

@@ -232,8 +232,9 @@ cleanOptsParser = CleanOpts <$> packages
 -- | Command-line arguments parser for configuration.
 configOptsParser :: Bool -> Parser ConfigMonoid
 configOptsParser hide0 =
-    (\opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty
-        { configMonoidDockerOpts = opts
+    (\workDir opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty
+        { configMonoidWorkDir = workDir
+        , configMonoidDockerOpts = opts
         , configMonoidSystemGHC = systemGHC
         , configMonoidInstallGHC = installGHC
         , configMonoidSkipGHCCheck = skipGHCCheck
@@ -247,7 +248,13 @@ configOptsParser hide0 =
         , configMonoidLocalBinPath = localBin
         , configMonoidModifyCodePage = modifyCodePage
         })
-    <$> dockerOptsParser True
+    <$> optional (strOption
+            ( long "work-dir"
+            <> metavar "WORK-DIR"
+            <> help "Override work directory (default: .stack-work)"
+            <> hide
+            ))
+    <*> dockerOptsParser True
     <*> maybeBoolFlags
             "system-ghc"
             "using the system installed GHC (on the PATH) if available and a matching version"
@@ -561,11 +568,11 @@ globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts
 globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts
     { globalReExecVersion = globalMonoidReExecVersion
     , globalDockerEntrypoint = globalMonoidDockerEntrypoint
-    , globalLogLevel = fromMaybe defaultLogLevel (globalMonoidLogLevel)
+    , globalLogLevel = fromMaybe defaultLogLevel globalMonoidLogLevel
     , globalConfigMonoid = globalMonoidConfigMonoid
     , globalResolver = globalMonoidResolver
     , globalCompiler = globalMonoidCompiler
-    , globalTerminal = fromMaybe defaultTerminal (globalMonoidTerminal)
+    , globalTerminal = fromMaybe defaultTerminal globalMonoidTerminal
     , globalStackYaml = globalMonoidStackYaml }
 
 initOptsParser :: Parser InitOpts
@@ -599,7 +606,7 @@ initOptsParser =
          metavar "RESOLVER" <>
          help "Use the given resolver, even if not all dependencies are met")
 
--- | Parse for a logging level.
+-- | Parser for a logging level.
 logLevelOptsParser :: Bool -> Parser (Maybe LogLevel)
 logLevelOptsParser hide =
   fmap (Just . parse)

src/Stack/Setup.hs

@@ -114,7 +114,7 @@ data SetupOpts = SetupOpts
     -- version. Only works reliably with a stack-managed installation.
     , soptsResolveMissingGHC :: !(Maybe Text)
     -- ^ Message shown to user for how to resolve the missing GHC
-    , soptsStackSetupYaml :: !String
+    , soptsStackSetupYaml :: !FilePath
     -- ^ Location of the main stack-setup.yaml file
     , soptsGHCBindistURL :: !(Maybe String)
     -- ^ Alternate GHC binary distribution (requires custom GHCVariant)

src/Stack/Sig/Sign.hs

@@ -43,7 +43,7 @@ import qualified System.FilePath as FP
 -- | Sign a haskell package with the given url of the signature
 -- service and a path to a tarball.
 sign
-    :: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
+    :: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)
     => Maybe (Path Abs Dir) -> String -> Path Abs File -> m ()
 sign Nothing _ _ = throwM SigNoProjectRootException
 sign (Just projectRoot) url filePath = do
@@ -85,7 +85,7 @@ sign (Just projectRoot) url filePath = do
 -- function will write the bytes to the path in a temp dir and sign
 -- the tarball with GPG.
 signTarBytes
-    :: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
+    :: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)
     => Maybe (Path Abs Dir) -> String -> Path Rel File -> L.ByteString -> m ()
 signTarBytes Nothing _ _ _ = throwM SigNoProjectRootException
 signTarBytes (Just projectRoot) url tarPath bs =
@@ -125,12 +125,13 @@ signPackage url pkg filePath = do
         (throwM (GPGSignException "unable to sign & upload package"))
 
 withStackWorkTempDir
-    :: (MonadCatch m, MonadIO m, MonadMask m, MonadLogger m)
+    :: (MonadCatch m, MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env)
     => Path Abs Dir -> (Path Abs Dir -> m ()) -> m ()
 withStackWorkTempDir projectRoot f = do
     uuid <- liftIO nextRandom
     uuidPath <- parseRelDir (toString uuid)
-    let tempDir = projectRoot </> workDirRel </> $(mkRelDir "tmp") </> uuidPath
+    workDir <- getWorkDir
+    let tempDir = projectRoot </> workDir </> $(mkRelDir "tmp") </> uuidPath
     bracket
         (createTree tempDir)
         (const (removeTree tempDir))