Skip to content

Commit 2230f34

Browse files
mgsloanmgsloan
committed
Merge pull request commercialhaskell#1442 from mrkkrp/mrkkrp-configurable-stack-work
Addition of ‘--work-dir’ option to override working directory, commercialhaskell#1178
2 parents 52944d2 + a9185c8 commit 2230f34

12 files changed

Lines changed: 123 additions & 88 deletions

File tree

‎src/Stack/Build/Execute.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -91,7 +91,7 @@ import System.Process.Run
9191
import System.Process.Internals (createProcess_)
9292
#endif
9393

94-
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)
94+
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)
9595

9696
-- | Fetch the packages necessary for a build, for example in combination with a dry run.
9797
preFetch :: M env m => Plan -> m ()

‎src/Stack/Config.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -99,8 +99,8 @@ configFromConfigMonoid
9999
-> Maybe (Project, Path Abs File)
100100
-> ConfigMonoid
101101
-> m Config
102-
configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject
103-
configMonoid@ConfigMonoid{..} = do
102+
configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject configMonoid@ConfigMonoid{..} = do
103+
configWorkDir <- parseRelDir (fromMaybe ".stack-work" configMonoidWorkDir)
104104
let configConnectionCount = fromMaybe 8 configMonoidConnectionCount
105105
configHideTHLoading = fromMaybe True configMonoidHideTHLoading
106106
configLatestSnapshotUrl = fromMaybe
@@ -416,7 +416,7 @@ loadBuildConfig mproject config mresolver mcompiler = do
416416
-- necessary.
417417
resolvePackageEntry
418418
:: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m
419-
,MonadBaseControl IO m)
419+
,MonadBaseControl IO m, HasConfig env)
420420
=> EnvOverride
421421
-> Path Abs Dir -- ^ project root
422422
-> PackageEntry
@@ -436,19 +436,20 @@ resolvePackageEntry menv projRoot pe = do
436436
-- necessary.
437437
resolvePackageLocation
438438
:: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m
439-
,MonadBaseControl IO m)
439+
,MonadBaseControl IO m, HasConfig env)
440440
=> EnvOverride
441441
-> Path Abs Dir -- ^ project root
442442
-> PackageLocation
443443
-> m (Path Abs Dir)
444444
resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp
445445
resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
446+
workDir <- getWorkDir
446447
let nameBeforeHashing = case remotePackageType of
447448
RPTHttpTarball -> url
448449
RPTGit commit -> T.unwords [url, commit]
449450
RPTHg commit -> T.unwords [url, commit, "hg"]
450451
name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 nameBeforeHashing
451-
root = projRoot </> workDirRel </> $(mkRelDir "downloaded")
452+
root = projRoot </> workDir </> $(mkRelDir "downloaded")
452453
fileExtension = case remotePackageType of
453454
RPTHttpTarball -> ".tar.gz"
454455
_ -> ".unused"

‎src/Stack/Constants.hs‎

Lines changed: 19 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -122,8 +122,11 @@ userDocsDir :: Config -> Path Abs Dir
122122
userDocsDir config = configStackRoot config </> $(mkRelDir "doc/")
123123

124124
-- | Output .o/.hi directory.
125-
objectInterfaceDir :: BuildConfig -> Path Abs Dir
126-
objectInterfaceDir bconfig = bcWorkDir bconfig </> $(mkRelDir "odir/")
125+
objectInterfaceDir :: (MonadReader env m, HasConfig env)
126+
=> BuildConfig -> m (Path Abs Dir)
127+
objectInterfaceDir bconfig = do
128+
bcwd <- bcWorkDir bconfig
129+
return (bcwd </> $(mkRelDir "odir/"))
127130

128131
-- | The filename used for dirtiness check of source files.
129132
buildCacheFile :: (MonadThrow m, MonadReader env m, HasPlatform env,HasEnvConfig env)
@@ -218,8 +221,9 @@ distRelativeDir = do
218221
packageIdentifierString $
219222
PackageIdentifier cabalPackageName cabalPkgVer
220223
platformAndCabal <- useShaPathOnWindows (platform </> envDir)
224+
workDir <- getWorkDir
221225
return $
222-
workDirRel </>
226+
workDir </>
223227
$(mkRelDir "dist") </>
224228
platformAndCabal
225229

@@ -255,12 +259,20 @@ rawGithubUrl org repo branch file = T.concat
255259
-- haddockExtension = "haddock"
256260

257261
-- | Docker sandbox from project root.
258-
projectDockerSandboxDir :: Path Abs Dir -> Path Abs Dir
259-
projectDockerSandboxDir projectRoot = projectRoot </> workDirRel </> $(mkRelDir "docker/")
262+
projectDockerSandboxDir :: (MonadReader env m, HasConfig env)
263+
=> Path Abs Dir -- ^ Project root
264+
-> m (Path Abs Dir) -- ^ Docker sandbox
265+
projectDockerSandboxDir projectRoot = do
266+
workDir <- getWorkDir
267+
return $ projectRoot </> workDir </> $(mkRelDir "docker/")
260268

261269
-- | Image staging dir from project root.
262-
imageStagingDir :: Path Abs Dir -> Path Abs Dir
263-
imageStagingDir p = p </> workDirRel </> $(mkRelDir "image/")
270+
imageStagingDir :: (MonadReader env m, HasConfig env)
271+
=> Path Abs Dir -- ^ Project root
272+
-> m (Path Abs Dir) -- ^ Docker sandbox
273+
imageStagingDir projectRoot = do
274+
workDir <- getWorkDir
275+
return $ projectRoot </> workDir </> $(mkRelDir "image/")
264276

265277
-- | Name of the 'stack' program, uppercased
266278
stackProgNameUpper :: String

‎src/Stack/Docker.hs‎

Lines changed: 12 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -234,11 +234,11 @@ getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
234234

235235
-- | Run a command in a new Docker container, then exit the process.
236236
runContainerAndExit :: M env m
237-
=> GetCmdArgs env m
238-
-> Maybe (Path Abs Dir)
239-
-> m ()
240-
-> m ()
241-
-> m ()
237+
=> GetCmdArgs env m
238+
-> Maybe (Path Abs Dir) -- ^ Project root (maybe)
239+
-> m () -- ^ Action to run before
240+
-> m () -- ^ Action to run after
241+
-> m ()
242242
runContainerAndExit getCmdArgs
243243
mprojectRoot
244244
before
@@ -272,11 +272,11 @@ runContainerAndExit getCmdArgs
272272
Just ii2 -> return ii2
273273
Nothing -> throwM (InspectFailedException image)
274274
| otherwise -> throwM (NotPulledException image)
275+
sandboxDir <- projectDockerSandboxDir projectRoot
275276
let ImageConfig {..} = iiConfig
276277
imageEnvVars = map (break (== '=')) icEnv
277278
platformVariant = BS.unpack $ Hash.digestToHexByteString $ hashRepoName image
278279
stackRoot = configStackRoot config
279-
sandboxDir = projectDockerSandboxDir projectRoot
280280
sandboxHomeDir = sandboxDir </> homeDirName
281281
isTerm = not (dockerDetach docker) &&
282282
isStdinTerminal &&
@@ -687,10 +687,12 @@ checkDockerVersion envOverride docker =
687687
prohibitedDockerVersions = []
688688

689689
-- | Remove the project's Docker sandbox.
690-
reset :: (MonadIO m) => Maybe (Path Abs Dir) -> Bool -> m ()
691-
reset maybeProjectRoot keepHome =
690+
reset :: (MonadIO m, MonadReader env m, HasConfig env)
691+
=> Maybe (Path Abs Dir) -> Bool -> m ()
692+
reset maybeProjectRoot keepHome = do
693+
dockerSandboxDir <- projectDockerSandboxDir projectRoot
692694
liftIO (removeDirectoryContents
693-
(projectDockerSandboxDir projectRoot)
695+
dockerSandboxDir
694696
[homeDirName | keepHome]
695697
[])
696698
where projectRoot = fromMaybeProjectRoot maybeProjectRoot
@@ -699,7 +701,7 @@ reset maybeProjectRoot keepHome =
699701
-- a container, such as switching the UID/GID to the "outside-Docker" user's.
700702
entrypoint :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m)
701703
=> Config -> DockerEntrypoint -> m ()
702-
entrypoint config@Config{..} DockerEntrypoint{..} = do
704+
entrypoint config@Config{..} DockerEntrypoint{..} =
703705
modifyMVar_ entrypointMVar $ \alreadyRan -> do
704706
-- Only run the entrypoint once
705707
unless alreadyRan $ do

‎src/Stack/Ghci.hs‎

Lines changed: 18 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -106,13 +106,14 @@ ghci GhciOpts{..} = do
106106
$logWarn
107107
("The following GHC options are incompatible with GHCi and have not been passed to it: " <>
108108
T.unwords (map T.pack (nubOrd omittedOpts)))
109+
oiDir <- objectInterfaceDir bconfig
109110
let modulesToLoad = nubOrd $
110111
concatMap (map display . S.toList . ghciPkgModules) pkgs
111112
thingsToLoad =
112113
maybe [] (return . toFilePath) mainFile <> modulesToLoad
113114
odir =
114-
[ "-odir=" <> toFilePathNoTrailingSep (objectInterfaceDir bconfig)
115-
, "-hidir=" <> toFilePathNoTrailingSep (objectInterfaceDir bconfig)]
115+
[ "-odir=" <> toFilePathNoTrailingSep oiDir
116+
, "-hidir=" <> toFilePathNoTrailingSep oiDir ]
116117
$logInfo
117118
("Configuring GHCi with the following packages: " <>
118119
T.intercalate ", " (map (packageNameText . ghciPkgName) pkgs))
@@ -125,21 +126,21 @@ ghci GhciOpts{..} = do
125126
-- include CWD.
126127
"-i" :
127128
odir <> pkgopts <> ghciArgs <> extras)
128-
case ghciNoLoadModules of
129-
True -> execGhci []
130-
False -> do
131-
tmp <- liftIO getTemporaryDirectory
132-
withCanonicalizedTempDirectory
133-
tmp
134-
"ghci-script"
135-
(\tmpDir ->
136-
do let scriptPath = tmpDir </> $(mkRelFile "ghci-script")
137-
fp = toFilePath scriptPath
138-
loadModules = ":load " <> unwords (map show thingsToLoad)
139-
bringIntoScope = ":module + " <> unwords modulesToLoad
140-
liftIO (writeFile fp (unlines [loadModules,bringIntoScope]))
141-
finally (execGhci ["-ghci-script=" <> fp])
142-
(removeFile scriptPath))
129+
if ghciNoLoadModules
130+
then execGhci []
131+
else do
132+
tmp <- liftIO getTemporaryDirectory
133+
withCanonicalizedTempDirectory
134+
tmp
135+
"ghci-script"
136+
(\tmpDir ->
137+
do let scriptPath = tmpDir </> $(mkRelFile "ghci-script")
138+
fp = toFilePath scriptPath
139+
loadModules = ":load " <> unwords (map show thingsToLoad)
140+
bringIntoScope = ":module + " <> unwords modulesToLoad
141+
liftIO (writeFile fp (unlines [loadModules,bringIntoScope]))
142+
finally (execGhci ["-ghci-script=" <> fp])
143+
(removeFile scriptPath))
143144

144145
-- | Figure out the main-is file to load based on the targets. Sometimes there
145146
-- is none, sometimes it's unambiguous, sometimes it's

‎src/Stack/Image.hs‎

Lines changed: 4 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -43,10 +43,9 @@ type Assemble e m = (HasConfig e, HasTerminal e, MonadBaseControl IO m, MonadCat
4343

4444
-- | Stages the executables & additional content in a staging
4545
-- directory under '.stack-work'
46-
stageContainerImageArtifacts :: Build e m
47-
=> m ()
46+
stageContainerImageArtifacts :: Build e m => m ()
4847
stageContainerImageArtifacts = do
49-
imageDir <- imageStagingDir <$> getWorkingDir
48+
imageDir <- getWorkingDir >>= imageStagingDir
5049
removeTreeIfExists imageDir
5150
createTree imageDir
5251
stageExesInDir imageDir
@@ -56,10 +55,9 @@ stageContainerImageArtifacts = do
5655
-- specified in the project's stack.yaml. Then new image will be
5756
-- extended with an ENTRYPOINT specified for each `entrypoint` listed
5857
-- in the config file.
59-
createContainerImageFromStage :: Assemble e m
60-
=> m ()
58+
createContainerImageFromStage :: Assemble e m => m ()
6159
createContainerImageFromStage = do
62-
imageDir <- imageStagingDir <$> getWorkingDir
60+
imageDir <- getWorkingDir >>= imageStagingDir
6361
createDockerImage imageDir
6462
extendDockerImageWithEntrypoint imageDir
6563

‎src/Stack/Options.hs‎

Lines changed: 13 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -232,8 +232,9 @@ cleanOptsParser = CleanOpts <$> packages
232232
-- | Command-line arguments parser for configuration.
233233
configOptsParser :: Bool -> Parser ConfigMonoid
234234
configOptsParser hide0 =
235-
(\opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty
236-
{ configMonoidDockerOpts = opts
235+
(\workDir opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage -> mempty
236+
{ configMonoidWorkDir = workDir
237+
, configMonoidDockerOpts = opts
237238
, configMonoidSystemGHC = systemGHC
238239
, configMonoidInstallGHC = installGHC
239240
, configMonoidSkipGHCCheck = skipGHCCheck
@@ -247,7 +248,13 @@ configOptsParser hide0 =
247248
, configMonoidLocalBinPath = localBin
248249
, configMonoidModifyCodePage = modifyCodePage
249250
})
250-
<$> dockerOptsParser True
251+
<$> optional (strOption
252+
( long "work-dir"
253+
<> metavar "WORK-DIR"
254+
<> help "Override work directory (default: .stack-work)"
255+
<> hide
256+
))
257+
<*> dockerOptsParser True
251258
<*> maybeBoolFlags
252259
"system-ghc"
253260
"using the system installed GHC (on the PATH) if available and a matching version"
@@ -561,11 +568,11 @@ globalOptsFromMonoid :: Bool -> GlobalOptsMonoid -> GlobalOpts
561568
globalOptsFromMonoid defaultTerminal GlobalOptsMonoid{..} = GlobalOpts
562569
{ globalReExecVersion = globalMonoidReExecVersion
563570
, globalDockerEntrypoint = globalMonoidDockerEntrypoint
564-
, globalLogLevel = fromMaybe defaultLogLevel (globalMonoidLogLevel)
571+
, globalLogLevel = fromMaybe defaultLogLevel globalMonoidLogLevel
565572
, globalConfigMonoid = globalMonoidConfigMonoid
566573
, globalResolver = globalMonoidResolver
567574
, globalCompiler = globalMonoidCompiler
568-
, globalTerminal = fromMaybe defaultTerminal (globalMonoidTerminal)
575+
, globalTerminal = fromMaybe defaultTerminal globalMonoidTerminal
569576
, globalStackYaml = globalMonoidStackYaml }
570577

571578
initOptsParser :: Parser InitOpts
@@ -599,7 +606,7 @@ initOptsParser =
599606
metavar "RESOLVER" <>
600607
help "Use the given resolver, even if not all dependencies are met")
601608

602-
-- | Parse for a logging level.
609+
-- | Parser for a logging level.
603610
logLevelOptsParser :: Bool -> Parser (Maybe LogLevel)
604611
logLevelOptsParser hide =
605612
fmap (Just . parse)

‎src/Stack/Setup.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -114,7 +114,7 @@ data SetupOpts = SetupOpts
114114
-- version. Only works reliably with a stack-managed installation.
115115
, soptsResolveMissingGHC :: !(Maybe Text)
116116
-- ^ Message shown to user for how to resolve the missing GHC
117-
, soptsStackSetupYaml :: !String
117+
, soptsStackSetupYaml :: !FilePath
118118
-- ^ Location of the main stack-setup.yaml file
119119
, soptsGHCBindistURL :: !(Maybe String)
120120
-- ^ Alternate GHC binary distribution (requires custom GHCVariant)

‎src/Stack/Sig/Sign.hs‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ import qualified System.FilePath as FP
4343
-- | Sign a haskell package with the given url of the signature
4444
-- service and a path to a tarball.
4545
sign
46-
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
46+
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)
4747
=> Maybe (Path Abs Dir) -> String -> Path Abs File -> m ()
4848
sign Nothing _ _ = throwM SigNoProjectRootException
4949
sign (Just projectRoot) url filePath = do
@@ -85,7 +85,7 @@ sign (Just projectRoot) url filePath = do
8585
-- function will write the bytes to the path in a temp dir and sign
8686
-- the tarball with GPG.
8787
signTarBytes
88-
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m)
88+
:: (MonadCatch m, MonadBaseControl IO m, MonadIO m, MonadMask m, MonadLogger m, MonadThrow m, MonadReader env m, HasConfig env)
8989
=> Maybe (Path Abs Dir) -> String -> Path Rel File -> L.ByteString -> m ()
9090
signTarBytes Nothing _ _ _ = throwM SigNoProjectRootException
9191
signTarBytes (Just projectRoot) url tarPath bs =
@@ -125,12 +125,13 @@ signPackage url pkg filePath = do
125125
(throwM (GPGSignException "unable to sign & upload package"))
126126

127127
withStackWorkTempDir
128-
:: (MonadCatch m, MonadIO m, MonadMask m, MonadLogger m)
128+
:: (MonadCatch m, MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env)
129129
=> Path Abs Dir -> (Path Abs Dir -> m ()) -> m ()
130130
withStackWorkTempDir projectRoot f = do
131131
uuid <- liftIO nextRandom
132132
uuidPath <- parseRelDir (toString uuid)
133-
let tempDir = projectRoot </> workDirRel </> $(mkRelDir "tmp") </> uuidPath
133+
workDir <- getWorkDir
134+
let tempDir = projectRoot </> workDir </> $(mkRelDir "tmp") </> uuidPath
134135
bracket
135136
(createTree tempDir)
136137
(const (removeTree tempDir))

0 commit comments

Comments
 (0)