Separate binaries/libs for Docker builds

- Adds extra text that idenfies Docker repo used for build to
  platformVariantRelDir (fixes #911)
- Adds platformVariantRelDir to `setup-exe-cache` (fixes #1367)
- Removes special sandboxing of ~/.cabal, ~/.ghc, and ~/.ghcjs (no
  longer relevant for Stack)

ChangeLog.md

@@ -22,6 +22,9 @@ Bug fixes:
 
 * Show absolute paths in error messages in multi-package builds
   [#1348](https://github.com/commercialhaskell/stack/issues/1348)
+* Docker-built binaries and libraries in different path
+  [#911](https://github.com/commercialhaskell/stack/issues/911)
+  [#1367](https://github.com/commercialhaskell/stack/issues/1367)
 
 ## 0.1.8.0
 

doc/docker_integration.md

@@ -395,9 +395,6 @@ There are also a few ways to set up images that tightens the integration:
 * Any packages in GHC's global package database will be available. This can be
   used to add private libraries to the image, or the make available a set of
   packages from an LTS release.
-* The `DOCKER_SANDBOX_ID` environment variable (set via `ENV` in the Dockerfile)
-  introduces extra isolation between images, to ensure that parts of the home
-  directory and stack root are kept separate.
 
 Troubleshooting
 -------------------------------------------------------------------------------

src/Stack/Build/Execute.hs

@@ -58,7 +58,6 @@ import           Data.Traversable (forM)
 import           Data.Word8 (_colon)
 import           Distribution.System            (OS (Windows),
                                                  Platform (Platform))
-import qualified Distribution.Text
 import           Language.Haskell.TH as TH (location)
 import           Network.HTTP.Client.Conduit (HasHttpManager)
 import           Path
@@ -222,13 +221,12 @@ getSetupExe :: M env m
 getSetupExe setupHs tmpdir = do
     wc <- getWhichCompiler
     econfig <- asks getEnvConfig
+    platformDir <- platformVariantRelDir
     let config = getConfig econfig
         baseNameS = concat
             [ "setup-Simple-Cabal-"
             , versionString $ envConfigCabalVersion econfig
             , "-"
-            , Distribution.Text.display $ configPlatform config
-            , "-"
             , compilerVersionString $ envConfigCompilerVersion econfig
             ]
         exeNameS = baseNameS ++
@@ -243,7 +241,8 @@ getSetupExe setupHs tmpdir = do
             baseNameS ++ ".jsexe"
         setupDir =
             configStackRoot config </>
-            $(mkRelDir "setup-exe-cache")
+            $(mkRelDir "setup-exe-cache") </>
+            platformDir
 
     exePath <- fmap (setupDir </>) $ parseRelFile exeNameS
     jsExePath <- fmap (setupDir </>) $ parseRelDir jsExeNameS

src/Stack/Config.hs

@@ -143,6 +143,9 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi
 
          configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck
 
+     configPlatformVariant <- liftIO $
+         maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
+
      configDocker <- dockerOptsFromMonoid (fmap fst mproject) configStackRoot configMonoidDockerOpts
 
      rawEnv <- liftIO getEnvironment
@@ -152,7 +155,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi
               $ map (T.pack *** T.pack) rawEnv
      let configEnvOverride _ = return origEnv
 
-     platformOnlyDir <- runReaderT platformOnlyRelDir configPlatform
+     platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform,configPlatformVariant)
      configLocalProgramsBase <-
          case configPlatform of
              Platform _ Windows -> do

src/Stack/Constants.hs

@@ -25,6 +25,7 @@ module Stack.Constants
     ,testBuiltFile
     ,benchBuiltFile
     ,stackProgName
+    ,stackProgNameUpper
     ,wiredInPackages
     ,ghcjsBootPackages
     ,cabalPackageName
@@ -38,11 +39,13 @@ module Stack.Constants
     ,defaultUserConfigPath
     ,defaultGlobalConfigPathDeprecated
     ,defaultGlobalConfigPath
+    ,platformVariantEnvVar
     )
     where
 
 import           Control.Monad.Catch (MonadThrow)
 import           Control.Monad.Reader
+import           Data.Char (toUpper)
 import           Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import           Data.Text (Text)
@@ -259,6 +262,10 @@ projectDockerSandboxDir projectRoot = projectRoot </> workDirRel </> $(mkRelDir
 imageStagingDir :: Path Abs Dir -> Path Abs Dir
 imageStagingDir p = p </> workDirRel </> $(mkRelDir "image/")
 
+-- | Name of the 'stack' program, uppercased
+stackProgNameUpper :: String
+stackProgNameUpper = map toUpper stackProgName
+
 -- | Name of the 'stack' program.
 stackProgName :: String
 stackProgName = "stack"
@@ -380,3 +387,8 @@ defaultGlobalConfigPath = parseAbsFile "/etc/stack/config.yaml"
 buildPlanDir :: Path Abs Dir -- ^ Stack root
              -> Path Abs Dir
 buildPlanDir = (</> $(mkRelDir "build-plan"))
+
+-- | Environment variable that stores a variant to append to platform-specific directory
+-- names.  Used to ensure incompatible binaries aren't shared between Docker builds and host
+platformVariantEnvVar :: String
+platformVariantEnvVar = stackProgNameUpper ++ "_PLATFORM_VARIANT"

src/Stack/Docker.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns,
-             OverloadedStrings, RankNTypes, RecordWildCards, ScopedTypeVariables, TemplateHaskell,
-             TupleSections #-}
+             OverloadedStrings, PackageImports, RankNTypes, RecordWildCards, ScopedTypeVariables,
+             TemplateHaskell, TupleSections #-}
 
 -- | Run commands in Docker containers
 module Stack.Docker
@@ -28,6 +28,7 @@ import           Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn)
 import           Control.Monad.Reader (MonadReader,asks,runReaderT)
 import           Control.Monad.Writer (execWriter,runWriter,tell)
 import           Control.Monad.Trans.Control (MonadBaseControl)
+import qualified "cryptohash" Crypto.Hash as Hash
 import           Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
 import           Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)
 import qualified Data.ByteString.Char8 as BS
@@ -56,7 +57,7 @@ import           Path.Extra (toFilePathNoTrailingSep)
 import           Path.IO
 import qualified Paths_stack as Meta
 import           Prelude -- Fix redundant import warnings
-import           Stack.Constants (projectDockerSandboxDir,stackProgName,stackRootEnvVar,buildPlanDir)
+import           Stack.Constants
 import           Stack.Docker.GlobalDB
 import           Stack.Types
 import           Stack.Types.Internal
@@ -272,62 +273,49 @@ runContainerAndExit getCmdArgs
          | otherwise -> throwM (NotPulledException image)
      let ImageConfig {..} = iiConfig
          imageEnvVars = map (break (== '=')) icEnv
-         msandboxID = lookupImageEnv sandboxIDEnvVar imageEnvVars
-         sandboxID = fromMaybe "default" msandboxID
-     sandboxIDDir <- parseRelDir (sandboxID ++ "/")
-     let stackRoot = configStackRoot config
+         platformVariant = BS.unpack $ Hash.digestToHexByteString $ hashRepoName image
+         stackRoot = configStackRoot config
          sandboxDir = projectDockerSandboxDir projectRoot
-         sandboxSandboxDir = sandboxDir </> $(mkRelDir "_sandbox/") </> sandboxIDDir
          sandboxHomeDir = sandboxDir </> homeDirName
-         sandboxRepoDir = sandboxDir </> sandboxIDDir
-         sandboxSubdirs = map (\d -> sandboxRepoDir </> d)
-                              sandboxedHomeSubdirectories
          isTerm = not (dockerDetach docker) &&
                   isStdinTerminal &&
                   isStdoutTerminal &&
                   isStderrTerminal
          keepStdinOpen = not (dockerDetach docker) &&
                          -- Workaround for https://github.com/docker/docker/issues/12319
-                         -- This seems be fixed in Docker 1.9.1, but will leave the workaround
+                         -- This is fixed in Docker 1.9.1, but will leave the workaround
                          -- in place for now, for users who haven't upgraded yet.
                          (isTerm || (isNothing bamboo && isNothing jenkins))
          newPathEnv = intercalate [Posix.searchPathSeparator] $
                       nubOrd $
-                      [toFilePathNoTrailingSep $ sandboxRepoDir </> $(mkRelDir ".local/bin")
-                      ,toFilePathNoTrailingSep $ sandboxRepoDir </> $(mkRelDir ".cabal/bin")
-                      ,toFilePathNoTrailingSep $ sandboxRepoDir </> $(mkRelDir "bin")
-                      ,hostBinDir] ++
+                      [hostBinDir
+                      ,toFilePathNoTrailingSep $ sandboxHomeDir </> $(mkRelDir ".local/bin")] ++
                       maybe [] Posix.splitSearchPath (lookupImageEnv "PATH" imageEnvVars)
      (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker
      pwd <- getWorkingDir
      liftIO
        (do updateDockerImageLastUsed config iiId (toFilePath projectRoot)
-           mapM_ createTree
-                 ([sandboxHomeDir, sandboxSandboxDir, stackRoot] ++
-                          sandboxSubdirs))
+           mapM_ createTree ([sandboxHomeDir, stackRoot]))
      containerID <- (trim . decodeUtf8) <$> readDockerProcess
        envOverride
        (concat
          [["create"
           ,"--net=host"
           ,"-e",inContainerEnvVar ++ "=1"
           ,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot
-          ,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxRepoDir
+          ,"-e",platformVariantEnvVar ++ "=dk" ++ platformVariant
+          ,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir
           ,"-e","PATH=" ++ newPathEnv
           ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot
           ,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot
-          ,"-v",toFilePathNoTrailingSep sandboxSandboxDir ++ ":" ++ toFilePathNoTrailingSep sandboxDir
-          ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxRepoDir
-          ,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++
-                toFilePathNoTrailingSep (sandboxRepoDir </> $(mkRelDir ("." ++ stackProgName ++ "/")))
+          ,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir
           ,"-w",toFilePathNoTrailingSep pwd]
            -- Disable the deprecated entrypoint in FP Complete-generated images
          ,["--entrypoint=/usr/bin/env"
-             | isJust msandboxID &&
+             | isJust (lookupImageEnv oldSandboxIdEnvVar imageEnvVars) &&
                (icEntrypoint == ["/usr/local/sbin/docker-entrypoint"] ||
                  icEntrypoint == ["/root/entrypoint.sh"])]
          ,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars
-         ,concatMap sandboxSubdirArg sandboxSubdirs
          ,concatMap mountArg (extraMount ++ dockerMount docker)
          ,concatMap (\nv -> ["-e", nv]) (dockerEnv docker)
          ,case dockerContainerName docker of
@@ -369,12 +357,15 @@ runContainerAndExit getCmdArgs
        Right () -> do after
                       liftIO exitSuccess
   where
+    -- This is using a hash of the Docker repository (without tag or digest) to ensure
+    -- binaries/libraries aren't shared between Docker and host (or incompatible Docker images)
+    hashRepoName :: String -> Hash.Digest Hash.MD5
+    hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@')
     lookupImageEnv name vars =
       case lookup name vars of
         Just ('=':val) -> Just val
         _ -> Nothing
     mountArg (Mount host container) = ["-v",host ++ ":" ++ container]
-    sandboxSubdirArg subdir = ["-v",toFilePathNoTrailingSep subdir++ ":" ++ toFilePathNoTrailingSep subdir]
     projectRoot = fromMaybeProjectRoot mprojectRoot
 
 -- | Clean-up old docker images and containers.
@@ -808,13 +799,6 @@ readDockerProcess
     => EnvOverride -> [String] -> m BS.ByteString
 readDockerProcess envOverride = readProcessStdout Nothing envOverride "docker"
 
--- | Subdirectories of the home directory to sandbox between GHC/Stackage versions.
-sandboxedHomeSubdirectories :: [Path Rel Dir]
-sandboxedHomeSubdirectories =
-  [$(mkRelDir ".ghc/")
-  ,$(mkRelDir ".cabal/")
-  ,$(mkRelDir ".ghcjs/")]
-
 -- | Name of home directory within docker sandbox.
 homeDirName :: Path Rel Dir
 homeDirName = $(mkRelDir "_home/")
@@ -835,13 +819,14 @@ concatT = T.pack . concat
 fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir
 fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)
 
--- | Environment variable that contains the sandbox ID.
-sandboxIDEnvVar :: String
-sandboxIDEnvVar = "DOCKER_SANDBOX_ID"
+-- | Environment variable that contained the old sandbox ID.
+-- | Use of this variable is deprecated, and only used to detect old images.
+oldSandboxIdEnvVar :: String
+oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"
 
 -- | Environment variable used to indicate stack is running in container.
 inContainerEnvVar :: String
-inContainerEnvVar = fmap toUpper stackProgName ++ "_IN_CONTAINER"
+inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"
 
 -- | Command-line argument for "docker"
 dockerCmdName :: String

src/Stack/Setup.hs

@@ -440,7 +440,7 @@ ensureDockerStackExe
     => Platform -> m (Path Abs File)
 ensureDockerStackExe containerPlatform = do
     config <- asks getConfig
-    containerPlatformDir <- runReaderT platformOnlyRelDir containerPlatform
+    containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)
     let programsPath = configLocalProgramsBase config </> containerPlatformDir
         stackVersion = fromCabalVersion Meta.version
         tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)

src/Stack/Types/Config.hs

@@ -19,6 +19,7 @@ module Stack.Types.Config
   -- ** HasPlatform & HasStackRoot
    HasPlatform(..)
   ,HasStackRoot(..)
+  ,PlatformVariant(..)
   -- ** Config & HasConfig
   ,Config(..)
   ,HasConfig(..)
@@ -194,6 +195,8 @@ data Config =
          -- console
          ,configPlatform            :: !Platform
          -- ^ The platform we're building for, used in many directory names
+         ,configPlatformVariant     :: !PlatformVariant
+         -- ^ Variant of the platform, also used in directory names
          ,configGHCVariant0         :: !(Maybe GHCVariant)
          -- ^ The variant of GHC requested by the user.
          -- In most cases, use 'BuildConfig' or 'MiniConfig's version instead,
@@ -673,8 +676,13 @@ class HasPlatform env where
     default getPlatform :: HasConfig env => env -> Platform
     getPlatform = configPlatform . getConfig
     {-# INLINE getPlatform #-}
-instance HasPlatform Platform where
-    getPlatform = id
+    getPlatformVariant :: env -> PlatformVariant
+    default getPlatformVariant :: HasConfig env => env -> PlatformVariant
+    getPlatformVariant = configPlatformVariant . getConfig
+    {-# INLINE getPlatformVariant #-}
+instance HasPlatform (Platform,PlatformVariant) where
+    getPlatform (p,_) = p
+    getPlatformVariant (_,v) = v
 
 -- | Class for environment values which have a GHCVariant
 class HasGHCVariant env where
@@ -1148,7 +1156,8 @@ platformOnlyRelDir
     => m (Path Rel Dir)
 platformOnlyRelDir = do
     platform <- asks getPlatform
-    parseRelDir (Distribution.Text.display platform)
+    platformVariant <- asks getPlatformVariant
+    parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)
 
 -- | Directory containing snapshots
 snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir)
@@ -1190,8 +1199,11 @@ platformVariantRelDir
     => m (Path Rel Dir)
 platformVariantRelDir = do
     platform <- asks getPlatform
+    platformVariant <- asks getPlatformVariant
     ghcVariant <- asks getGHCVariant
-    parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant)
+    parseRelDir (mconcat [ Distribution.Text.display platform
+                         , platformVariantSuffix platformVariant
+                         , ghcVariantSuffix ghcVariant ])
 
 -- | This is an attempt to shorten stack paths on Windows to decrease our
 -- chances of hitting 260 symbol path limit. The idea is to calculate
@@ -1360,6 +1372,15 @@ instance FromJSON SCM where
 instance ToJSON SCM where
     toJSON Git = toJSON ("git" :: Text)
 
+-- | A variant of the platform, used to differentiate Docker builds from host
+data PlatformVariant = PlatformVariantNone
+                     | PlatformVariant String
+
+-- | Render a platform variant to a String suffix.
+platformVariantSuffix :: PlatformVariant -> String
+platformVariantSuffix PlatformVariantNone = ""
+platformVariantSuffix (PlatformVariant v) = "-" ++ v
+
 -- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple)
 data GHCVariant
     = GHCStandard -- ^ Standard bindist

src/Stack/Types/Internal.hs

@@ -22,6 +22,7 @@ instance HasStackRoot config => HasStackRoot (Env config) where
     getStackRoot = getStackRoot . envConfig
 instance HasPlatform config => HasPlatform (Env config) where
     getPlatform = getPlatform . envConfig
+    getPlatformVariant = getPlatformVariant . envConfig
 instance HasGHCVariant config => HasGHCVariant (Env config) where
     getGHCVariant = getGHCVariant . envConfig
 instance HasConfig config => HasConfig (Env config) where