From 75199945e8d8a69e13e72297f5b51cab0158500d Mon Sep 17 00:00:00 2001
From: Tim Dysinger <tim@dysinger.net>
Date: Wed, 6 Apr 2016 12:25:30 -0700
Subject: [PATCH] don't drop .stack-work dirs all over the place

resolves #1975
---
 src/Stack/Image.hs | 34 +++++++++++++++++++++++-----------
 src/main/Main.hs   |  7 ++++---
 2 files changed, 27 insertions(+), 14 deletions(-)

diff --git a/src/Stack/Image.hs b/src/Stack/Image.hs
index 7ae390ae72..3e184ca733 100644
--- a/src/Stack/Image.hs
+++ b/src/Stack/Image.hs
@@ -40,14 +40,14 @@ type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadIO
 -- directory under '.stack-work'
 stageContainerImageArtifacts
     :: Build e m
-    => m ()
-stageContainerImageArtifacts = do
+    => Maybe (Path Abs Dir) -> m ()
+stageContainerImageArtifacts mProjectRoot = do
     config <- asks getConfig
-    workingDir <- getCurrentDir
     forM_
         (zip [0 ..] (imgDockers $ configImage config))
         (\(idx,opts) ->
-              do imageDir <- imageStagingDir workingDir idx
+              do imageDir <-
+                     imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx
                  ignoringAbsence (removeDirRecur imageDir)
                  ensureDir imageDir
                  stageExesInDir opts imageDir
@@ -59,10 +59,9 @@ stageContainerImageArtifacts = do
 -- in the config file.
 createContainerImageFromStage
     :: Assemble e m
-    => [Text] -> m ()
-createContainerImageFromStage imageNames = do
+    => Maybe (Path Abs Dir) -> [Text] -> m ()
+createContainerImageFromStage mProjectRoot imageNames = do
     config <- asks getConfig
-    workingDir <- getCurrentDir
     forM_
         (zip
              [0 ..]
@@ -70,7 +69,8 @@ createContainerImageFromStage imageNames = do
                   (map T.unpack imageNames)
                   (imgDockers $ configImage config)))
         (\(idx,opts) ->
-              do imageDir <- imageStagingDir workingDir idx
+              do imageDir <-
+                     imageStagingDir (fromMaybeProjectRoot mProjectRoot) idx
                  createDockerImage opts imageDir
                  extendDockerImageWithEntrypoint opts imageDir)
   where
@@ -180,6 +180,11 @@ extendDockerImageWithEntrypoint dockerConfig dir = do
                                   , dockerImageName ++ "-" ++ ep
                                   , toFilePathNoTrailingSep dir]))
 
+-- | Fail with friendly error if project root not set.
+fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir
+fromMaybeProjectRoot =
+    fromMaybe (throw StackImageCannotDetermineProjectRootException)
+
 -- | The command name for dealing with images.
 imgCmdName
     :: String
@@ -199,12 +204,19 @@ imgOptsFromMonoid ImageOptsMonoid{..} =
     }
 
 -- | Stack image exceptions.
-data StackImageException =
-    StackImageDockerBaseUnspecifiedException
-    deriving ((Typeable))
+data StackImageException
+    = StackImageDockerBaseUnspecifiedException  -- ^ Unspecified parent docker
+                                                -- container makes building
+                                                -- impossible
+    | StackImageCannotDetermineProjectRootException  -- ^ Can't determine the
+                                                     -- project root (where to
+                                                     -- put image sandbox).
+    deriving (Typeable)
 
 instance Exception StackImageException
 
 instance Show StackImageException where
     show StackImageDockerBaseUnspecifiedException =
         "You must specify a base docker image on which to place your haskell executables."
+    show StackImageCannotDetermineProjectRootException =
+        "Stack was unable to determine the project root in order to build a container."
diff --git a/src/main/Main.hs b/src/main/Main.hs
index 1d09559d90..70f5eb7309 100644
--- a/src/main/Main.hs
+++ b/src/main/Main.hs
@@ -1144,7 +1144,8 @@ cfgSetCmd co go@GlobalOpts{..} =
                       env)
 
 imgDockerCmd :: (Bool, [Text]) -> GlobalOpts -> IO ()
-imgDockerCmd (rebuild,images) go@GlobalOpts{..} =
+imgDockerCmd (rebuild,images) go@GlobalOpts{..} = do
+    mProjectRoot <- lcProjectRoot . snd <$> loadConfigWithOpts go
     withBuildConfigExt
         go
         Nothing
@@ -1154,8 +1155,8 @@ imgDockerCmd (rebuild,images) go@GlobalOpts{..} =
                          (const (return ()))
                          lk
                          defaultBuildOptsCLI
-                 Image.stageContainerImageArtifacts)
-        (Just $ Image.createContainerImageFromStage images)
+                 Image.stageContainerImageArtifacts mProjectRoot)
+        (Just $ Image.createContainerImageFromStage mProjectRoot images)
 
 sigSignSdistCmd :: (String, String) -> GlobalOpts -> IO ()
 sigSignSdistCmd (url,path) go =