Skip to content

Commit 18efc02

Browse files
borsboomborsboom
committed
Separate binaries/libs for Docker builds
- Adds extra text that idenfies Docker repo used for build to platformVariantRelDir (fixes commercialhaskell#911) - Adds platformVariantRelDir to `setup-exe-cache` (fixes commercialhaskell#1367) - Removes special sandboxing of ~/.cabal, ~/.ghc, and ~/.ghcjs (no longer relevant for Stack)
1 parent 4f0b714 commit 18efc02

9 files changed

Lines changed: 72 additions & 51 deletions

File tree

‎ChangeLog.md‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,9 @@ Bug fixes:
2222

2323
* Show absolute paths in error messages in multi-package builds
2424
[#1348](https://github.com/commercialhaskell/stack/issues/1348)
25+
* Docker-built binaries and libraries in different path
26+
[#911](https://github.com/commercialhaskell/stack/issues/911)
27+
[#1367](https://github.com/commercialhaskell/stack/issues/1367)
2528

2629
## 0.1.8.0
2730

‎doc/docker_integration.md‎

Lines changed: 0 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -395,9 +395,6 @@ There are also a few ways to set up images that tightens the integration:
395395
* Any packages in GHC's global package database will be available. This can be
396396
used to add private libraries to the image, or the make available a set of
397397
packages from an LTS release.
398-
* The `DOCKER_SANDBOX_ID` environment variable (set via `ENV` in the Dockerfile)
399-
introduces extra isolation between images, to ensure that parts of the home
400-
directory and stack root are kept separate.
401398

402399
Troubleshooting
403400
-------------------------------------------------------------------------------

‎src/Stack/Build/Execute.hs‎

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,6 @@ import Data.Traversable (forM)
5858
import Data.Word8 (_colon)
5959
import Distribution.System (OS (Windows),
6060
Platform (Platform))
61-
import qualified Distribution.Text
6261
import Language.Haskell.TH as TH (location)
6362
import Network.HTTP.Client.Conduit (HasHttpManager)
6463
import Path
@@ -222,13 +221,12 @@ getSetupExe :: M env m
222221
getSetupExe setupHs tmpdir = do
223222
wc <- getWhichCompiler
224223
econfig <- asks getEnvConfig
224+
platformDir <- platformVariantRelDir
225225
let config = getConfig econfig
226226
baseNameS = concat
227227
[ "setup-Simple-Cabal-"
228228
, versionString $ envConfigCabalVersion econfig
229229
, "-"
230-
, Distribution.Text.display $ configPlatform config
231-
, "-"
232230
, compilerVersionString $ envConfigCompilerVersion econfig
233231
]
234232
exeNameS = baseNameS ++
@@ -243,7 +241,8 @@ getSetupExe setupHs tmpdir = do
243241
baseNameS ++ ".jsexe"
244242
setupDir =
245243
configStackRoot config </>
246-
$(mkRelDir "setup-exe-cache")
244+
$(mkRelDir "setup-exe-cache") </>
245+
platformDir
247246

248247
exePath <- fmap (setupDir </>) $ parseRelFile exeNameS
249248
jsExePath <- fmap (setupDir </>) $ parseRelDir jsExeNameS

‎src/Stack/Config.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -143,6 +143,9 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi
143143

144144
configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck
145145

146+
configPlatformVariant <- liftIO $
147+
maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
148+
146149
configDocker <- dockerOptsFromMonoid (fmap fst mproject) configStackRoot configMonoidDockerOpts
147150

148151
rawEnv <- liftIO getEnvironment
@@ -152,7 +155,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoi
152155
$ map (T.pack *** T.pack) rawEnv
153156
let configEnvOverride _ = return origEnv
154157

155-
platformOnlyDir <- runReaderT platformOnlyRelDir configPlatform
158+
platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform,configPlatformVariant)
156159
configLocalProgramsBase <-
157160
case configPlatform of
158161
Platform _ Windows -> do

‎src/Stack/Constants.hs‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ module Stack.Constants
2525
,testBuiltFile
2626
,benchBuiltFile
2727
,stackProgName
28+
,stackProgNameUpper
2829
,wiredInPackages
2930
,ghcjsBootPackages
3031
,cabalPackageName
@@ -38,11 +39,13 @@ module Stack.Constants
3839
,defaultUserConfigPath
3940
,defaultGlobalConfigPathDeprecated
4041
,defaultGlobalConfigPath
42+
,platformVariantEnvVar
4143
)
4244
where
4345

4446
import Control.Monad.Catch (MonadThrow)
4547
import Control.Monad.Reader
48+
import Data.Char (toUpper)
4649
import Data.HashSet (HashSet)
4750
import qualified Data.HashSet as HashSet
4851
import Data.Text (Text)
@@ -259,6 +262,10 @@ projectDockerSandboxDir projectRoot = projectRoot </> workDirRel </> $(mkRelDir
259262
imageStagingDir :: Path Abs Dir -> Path Abs Dir
260263
imageStagingDir p = p </> workDirRel </> $(mkRelDir "image/")
261264

265+
-- | Name of the 'stack' program, uppercased
266+
stackProgNameUpper :: String
267+
stackProgNameUpper = map toUpper stackProgName
268+
262269
-- | Name of the 'stack' program.
263270
stackProgName :: String
264271
stackProgName = "stack"
@@ -380,3 +387,8 @@ defaultGlobalConfigPath = parseAbsFile "/etc/stack/config.yaml"
380387
buildPlanDir :: Path Abs Dir -- ^ Stack root
381388
-> Path Abs Dir
382389
buildPlanDir = (</> $(mkRelDir "build-plan"))
390+
391+
-- | Environment variable that stores a variant to append to platform-specific directory
392+
-- names. Used to ensure incompatible binaries aren't shared between Docker builds and host
393+
platformVariantEnvVar :: String
394+
platformVariantEnvVar = stackProgNameUpper ++ "_PLATFORM_VARIANT"

‎src/Stack/Docker.hs‎

Lines changed: 23 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
{-# LANGUAGE CPP, ConstraintKinds, DeriveDataTypeable, FlexibleContexts, MultiWayIf, NamedFieldPuns,
2-
OverloadedStrings, RankNTypes, RecordWildCards, ScopedTypeVariables, TemplateHaskell,
3-
TupleSections #-}
2+
OverloadedStrings, PackageImports, RankNTypes, RecordWildCards, ScopedTypeVariables,
3+
TemplateHaskell, TupleSections #-}
44

55
-- | Run commands in Docker containers
66
module Stack.Docker
@@ -28,6 +28,7 @@ import Control.Monad.Logger (MonadLogger,logError,logInfo,logWarn)
2828
import Control.Monad.Reader (MonadReader,asks,runReaderT)
2929
import Control.Monad.Writer (execWriter,runWriter,tell)
3030
import Control.Monad.Trans.Control (MonadBaseControl)
31+
import qualified "cryptohash" Crypto.Hash as Hash
3132
import Data.Aeson.Extended (FromJSON(..),(.:),(.:?),(.!=),eitherDecode)
3233
import Data.ByteString.Builder (stringUtf8,charUtf8,toLazyByteString)
3334
import qualified Data.ByteString.Char8 as BS
@@ -56,7 +57,7 @@ import Path.Extra (toFilePathNoTrailingSep)
5657
import Path.IO
5758
import qualified Paths_stack as Meta
5859
import Prelude -- Fix redundant import warnings
59-
import Stack.Constants (projectDockerSandboxDir,stackProgName,stackRootEnvVar,buildPlanDir)
60+
import Stack.Constants
6061
import Stack.Docker.GlobalDB
6162
import Stack.Types
6263
import Stack.Types.Internal
@@ -272,62 +273,49 @@ runContainerAndExit getCmdArgs
272273
| otherwise -> throwM (NotPulledException image)
273274
let ImageConfig {..} = iiConfig
274275
imageEnvVars = map (break (== '=')) icEnv
275-
msandboxID = lookupImageEnv sandboxIDEnvVar imageEnvVars
276-
sandboxID = fromMaybe "default" msandboxID
277-
sandboxIDDir <- parseRelDir (sandboxID ++ "/")
278-
let stackRoot = configStackRoot config
276+
platformVariant = BS.unpack $ Hash.digestToHexByteString $ hashRepoName image
277+
stackRoot = configStackRoot config
279278
sandboxDir = projectDockerSandboxDir projectRoot
280-
sandboxSandboxDir = sandboxDir </> $(mkRelDir "_sandbox/") </> sandboxIDDir
281279
sandboxHomeDir = sandboxDir </> homeDirName
282-
sandboxRepoDir = sandboxDir </> sandboxIDDir
283-
sandboxSubdirs = map (\d -> sandboxRepoDir </> d)
284-
sandboxedHomeSubdirectories
285280
isTerm = not (dockerDetach docker) &&
286281
isStdinTerminal &&
287282
isStdoutTerminal &&
288283
isStderrTerminal
289284
keepStdinOpen = not (dockerDetach docker) &&
290285
-- Workaround for https://github.com/docker/docker/issues/12319
291-
-- This seems be fixed in Docker 1.9.1, but will leave the workaround
286+
-- This is fixed in Docker 1.9.1, but will leave the workaround
292287
-- in place for now, for users who haven't upgraded yet.
293288
(isTerm || (isNothing bamboo && isNothing jenkins))
294289
newPathEnv = intercalate [Posix.searchPathSeparator] $
295290
nubOrd $
296-
[toFilePathNoTrailingSep $ sandboxRepoDir </> $(mkRelDir ".local/bin")
297-
,toFilePathNoTrailingSep $ sandboxRepoDir </> $(mkRelDir ".cabal/bin")
298-
,toFilePathNoTrailingSep $ sandboxRepoDir </> $(mkRelDir "bin")
299-
,hostBinDir] ++
291+
[hostBinDir
292+
,toFilePathNoTrailingSep $ sandboxHomeDir </> $(mkRelDir ".local/bin")] ++
300293
maybe [] Posix.splitSearchPath (lookupImageEnv "PATH" imageEnvVars)
301294
(cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker
302295
pwd <- getWorkingDir
303296
liftIO
304297
(do updateDockerImageLastUsed config iiId (toFilePath projectRoot)
305-
mapM_ createTree
306-
([sandboxHomeDir, sandboxSandboxDir, stackRoot] ++
307-
sandboxSubdirs))
298+
mapM_ createTree ([sandboxHomeDir, stackRoot]))
308299
containerID <- (trim . decodeUtf8) <$> readDockerProcess
309300
envOverride
310301
(concat
311302
[["create"
312303
,"--net=host"
313304
,"-e",inContainerEnvVar ++ "=1"
314305
,"-e",stackRootEnvVar ++ "=" ++ toFilePathNoTrailingSep stackRoot
315-
,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxRepoDir
306+
,"-e",platformVariantEnvVar ++ "=dk" ++ platformVariant
307+
,"-e","HOME=" ++ toFilePathNoTrailingSep sandboxHomeDir
316308
,"-e","PATH=" ++ newPathEnv
317309
,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++ toFilePathNoTrailingSep stackRoot
318310
,"-v",toFilePathNoTrailingSep projectRoot ++ ":" ++ toFilePathNoTrailingSep projectRoot
319-
,"-v",toFilePathNoTrailingSep sandboxSandboxDir ++ ":" ++ toFilePathNoTrailingSep sandboxDir
320-
,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxRepoDir
321-
,"-v",toFilePathNoTrailingSep stackRoot ++ ":" ++
322-
toFilePathNoTrailingSep (sandboxRepoDir </> $(mkRelDir ("." ++ stackProgName ++ "/")))
311+
,"-v",toFilePathNoTrailingSep sandboxHomeDir ++ ":" ++ toFilePathNoTrailingSep sandboxHomeDir
323312
,"-w",toFilePathNoTrailingSep pwd]
324313
-- Disable the deprecated entrypoint in FP Complete-generated images
325314
,["--entrypoint=/usr/bin/env"
326-
| isJust msandboxID &&
315+
| isJust (lookupImageEnv oldSandboxIdEnvVar imageEnvVars) &&
327316
(icEntrypoint == ["/usr/local/sbin/docker-entrypoint"] ||
328317
icEntrypoint == ["/root/entrypoint.sh"])]
329318
,concatMap (\(k,v) -> ["-e", k ++ "=" ++ v]) envVars
330-
,concatMap sandboxSubdirArg sandboxSubdirs
331319
,concatMap mountArg (extraMount ++ dockerMount docker)
332320
,concatMap (\nv -> ["-e", nv]) (dockerEnv docker)
333321
,case dockerContainerName docker of
@@ -369,12 +357,15 @@ runContainerAndExit getCmdArgs
369357
Right () -> do after
370358
liftIO exitSuccess
371359
where
360+
-- This is using a hash of the Docker repository (without tag or digest) to ensure
361+
-- binaries/libraries aren't shared between Docker and host (or incompatible Docker images)
362+
hashRepoName :: String -> Hash.Digest Hash.MD5
363+
hashRepoName = Hash.hash . BS.pack . takeWhile (\c -> c /= ':' && c /= '@')
372364
lookupImageEnv name vars =
373365
case lookup name vars of
374366
Just ('=':val) -> Just val
375367
_ -> Nothing
376368
mountArg (Mount host container) = ["-v",host ++ ":" ++ container]
377-
sandboxSubdirArg subdir = ["-v",toFilePathNoTrailingSep subdir++ ":" ++ toFilePathNoTrailingSep subdir]
378369
projectRoot = fromMaybeProjectRoot mprojectRoot
379370

380371
-- | Clean-up old docker images and containers.
@@ -808,13 +799,6 @@ readDockerProcess
808799
=> EnvOverride -> [String] -> m BS.ByteString
809800
readDockerProcess envOverride = readProcessStdout Nothing envOverride "docker"
810801

811-
-- | Subdirectories of the home directory to sandbox between GHC/Stackage versions.
812-
sandboxedHomeSubdirectories :: [Path Rel Dir]
813-
sandboxedHomeSubdirectories =
814-
[$(mkRelDir ".ghc/")
815-
,$(mkRelDir ".cabal/")
816-
,$(mkRelDir ".ghcjs/")]
817-
818802
-- | Name of home directory within docker sandbox.
819803
homeDirName :: Path Rel Dir
820804
homeDirName = $(mkRelDir "_home/")
@@ -835,13 +819,14 @@ concatT = T.pack . concat
835819
fromMaybeProjectRoot :: Maybe (Path Abs Dir) -> Path Abs Dir
836820
fromMaybeProjectRoot = fromMaybe (throw CannotDetermineProjectRootException)
837821

838-
-- | Environment variable that contains the sandbox ID.
839-
sandboxIDEnvVar :: String
840-
sandboxIDEnvVar = "DOCKER_SANDBOX_ID"
822+
-- | Environment variable that contained the old sandbox ID.
823+
-- | Use of this variable is deprecated, and only used to detect old images.
824+
oldSandboxIdEnvVar :: String
825+
oldSandboxIdEnvVar = "DOCKER_SANDBOX_ID"
841826

842827
-- | Environment variable used to indicate stack is running in container.
843828
inContainerEnvVar :: String
844-
inContainerEnvVar = fmap toUpper stackProgName ++ "_IN_CONTAINER"
829+
inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"
845830

846831
-- | Command-line argument for "docker"
847832
dockerCmdName :: String

‎src/Stack/Setup.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -440,7 +440,7 @@ ensureDockerStackExe
440440
=> Platform -> m (Path Abs File)
441441
ensureDockerStackExe containerPlatform = do
442442
config <- asks getConfig
443-
containerPlatformDir <- runReaderT platformOnlyRelDir containerPlatform
443+
containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)
444444
let programsPath = configLocalProgramsBase config </> containerPlatformDir
445445
stackVersion = fromCabalVersion Meta.version
446446
tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)

‎src/Stack/Types/Config.hs‎

Lines changed: 25 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,7 @@ module Stack.Types.Config
1919
-- ** HasPlatform & HasStackRoot
2020
HasPlatform(..)
2121
,HasStackRoot(..)
22+
,PlatformVariant(..)
2223
-- ** Config & HasConfig
2324
,Config(..)
2425
,HasConfig(..)
@@ -194,6 +195,8 @@ data Config =
194195
-- console
195196
,configPlatform :: !Platform
196197
-- ^ The platform we're building for, used in many directory names
198+
,configPlatformVariant :: !PlatformVariant
199+
-- ^ Variant of the platform, also used in directory names
197200
,configGHCVariant0 :: !(Maybe GHCVariant)
198201
-- ^ The variant of GHC requested by the user.
199202
-- In most cases, use 'BuildConfig' or 'MiniConfig's version instead,
@@ -673,8 +676,13 @@ class HasPlatform env where
673676
default getPlatform :: HasConfig env => env -> Platform
674677
getPlatform = configPlatform . getConfig
675678
{-# INLINE getPlatform #-}
676-
instance HasPlatform Platform where
677-
getPlatform = id
679+
getPlatformVariant :: env -> PlatformVariant
680+
default getPlatformVariant :: HasConfig env => env -> PlatformVariant
681+
getPlatformVariant = configPlatformVariant . getConfig
682+
{-# INLINE getPlatformVariant #-}
683+
instance HasPlatform (Platform,PlatformVariant) where
684+
getPlatform (p,_) = p
685+
getPlatformVariant (_,v) = v
678686

679687
-- | Class for environment values which have a GHCVariant
680688
class HasGHCVariant env where
@@ -1148,7 +1156,8 @@ platformOnlyRelDir
11481156
=> m (Path Rel Dir)
11491157
platformOnlyRelDir = do
11501158
platform <- asks getPlatform
1151-
parseRelDir (Distribution.Text.display platform)
1159+
platformVariant <- asks getPlatformVariant
1160+
parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)
11521161

11531162
-- | Directory containing snapshots
11541163
snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir)
@@ -1190,8 +1199,11 @@ platformVariantRelDir
11901199
=> m (Path Rel Dir)
11911200
platformVariantRelDir = do
11921201
platform <- asks getPlatform
1202+
platformVariant <- asks getPlatformVariant
11931203
ghcVariant <- asks getGHCVariant
1194-
parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant)
1204+
parseRelDir (mconcat [ Distribution.Text.display platform
1205+
, platformVariantSuffix platformVariant
1206+
, ghcVariantSuffix ghcVariant ])
11951207

11961208
-- | This is an attempt to shorten stack paths on Windows to decrease our
11971209
-- chances of hitting 260 symbol path limit. The idea is to calculate
@@ -1360,6 +1372,15 @@ instance FromJSON SCM where
13601372
instance ToJSON SCM where
13611373
toJSON Git = toJSON ("git" :: Text)
13621374

1375+
-- | A variant of the platform, used to differentiate Docker builds from host
1376+
data PlatformVariant = PlatformVariantNone
1377+
| PlatformVariant String
1378+
1379+
-- | Render a platform variant to a String suffix.
1380+
platformVariantSuffix :: PlatformVariant -> String
1381+
platformVariantSuffix PlatformVariantNone = ""
1382+
platformVariantSuffix (PlatformVariant v) = "-" ++ v
1383+
13631384
-- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple)
13641385
data GHCVariant
13651386
= GHCStandard -- ^ Standard bindist

‎src/Stack/Types/Internal.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ instance HasStackRoot config => HasStackRoot (Env config) where
2222
getStackRoot = getStackRoot . envConfig
2323
instance HasPlatform config => HasPlatform (Env config) where
2424
getPlatform = getPlatform . envConfig
25+
getPlatformVariant = getPlatformVariant . envConfig
2526
instance HasGHCVariant config => HasGHCVariant (Env config) where
2627
getGHCVariant = getGHCVariant . envConfig
2728
instance HasConfig config => HasConfig (Env config) where

0 commit comments

Comments
 (0)