Skip to content

Commit a2d664f

Browse files
snoybergsnoyberg
committed
Basic implementation of Stack.Setup
This only supports GHC 7.8.4/Linux-64 with a hard-coded URL for now, but extending is easy. There was a lot of accidental work necessary here, such as: * Changing when the HTTP manager is acquired * Doing path lookups inside System.Process.Read (modifying the PATH environment variable is not sufficient)
1 parent 8f37563 commit a2d664f

8 files changed

Lines changed: 246 additions & 148 deletions

File tree

‎src/Stack/Build.hs‎

Lines changed: 8 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -65,12 +65,13 @@ import Stack.GhcPkg
6565
import Stack.Package
6666
import Stack.Types
6767
import Stack.Types.Internal
68-
import System.Directory hiding (findFiles)
68+
import System.Directory hiding (findFiles, findExecutable)
6969
import System.Environment
7070
import qualified System.FilePath as FilePath
7171
import System.IO
7272
import System.IO.Temp (withSystemTempDirectory)
7373
import System.Posix.Files (createSymbolicLink,removeLink)
74+
import System.Process.Read (readProcessStdout, findExecutable)
7475

7576
-- | Build using Shake.
7677
build :: (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env)
@@ -655,9 +656,10 @@ runhaskell cabalPkgVer pinfo setuphs config' buildType args =
655656
let withSink inner =
656657
withBinaryFile (FL.toFilePath (buildLogPath pinfo)) AppendMode
657658
$ \h -> inner (sinkHandle h)
659+
exeName <- liftIO $ join $ findExecutable menv "runhaskell"
658660
join (liftIO (catch (do withSink $ \sink -> withCheckedProcess
659-
cp {cwd =
660-
Just (FL.toFilePath dir)
661+
(cp exeName)
662+
{cwd = Just (FL.toFilePath dir)
661663
,Process.env = envHelper menv
662664
,std_err = Inherit}
663665
(\ClosedStream stdout' stderr' -> runConcurrently $
@@ -688,8 +690,9 @@ runhaskell cabalPkgVer pinfo setuphs config' buildType args =
688690
(cname:_) -> cname
689691
_ -> mempty
690692
dir = packageDir pinfo
691-
cp =
692-
proc "runhaskell" (("-package=" ++ packageIdentifierString cabalPkgVer)
693+
cp exeName =
694+
proc (toFilePath exeName)
695+
(("-package=" ++ packageIdentifierString cabalPkgVer)
693696
: toFilePath setuphs : args)
694697

695698
menv = configEnvOverride (getConfig config') EnvSettings

‎src/Stack/Config.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -218,6 +218,7 @@ configFromConfigMonoid configStackRoot Project{..} ConfigMonoid{..} = do
218218
case configMonoidDockerOpts of
219219
DockerOpts Nothing -> True
220220
DockerOpts (Just _) -> False
221+
configLocalGHCs = configStackRoot </> $(mkRelDir "ghc") -- On Windows, use APPLOCALDATA\Programs?
221222

222223
configPackages' <- mapM (resolveDir projectRoot) projectPackages
223224
let configPackages = S.fromList configPackages'

‎src/Stack/PackageIndex.hs‎

Lines changed: 8 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -43,7 +43,7 @@ import Data.Conduit.Zlib (ungzip)
4343
import qualified Data.Foldable as F
4444
import Data.Map (Map)
4545
import qualified Data.Map as Map
46-
import Data.Maybe (fromMaybe, isJust, mapMaybe)
46+
import Data.Maybe (fromMaybe, mapMaybe)
4747
import Data.Monoid (mempty, (<>))
4848
import Data.Set (Set)
4949
import qualified Data.Set as Set
@@ -64,15 +64,14 @@ import Distribution.ParseUtils (PError)
6464
import qualified Distribution.Text as DT
6565
import Network.HTTP.Download
6666
import Path (mkRelDir, parent,
67-
parseAbsFile,
6867
parseRelDir, toFilePath,
6968
(</>))
7069
import Stack.Types
7170
import System.Directory
7271
import System.FilePath (takeBaseName, (<.>))
7372
import System.IO (IOMode (ReadMode, WriteMode),
7473
withBinaryFile)
75-
import System.Process.Read (runIn, EnvOverride)
74+
import System.Process.Read (runIn, EnvOverride, doesExecutableExist)
7675

7776
-- | A cabal file with name and version parsed from the filepath, and the
7877
-- package description itself ready to be parsed. It's left in unparsed form
@@ -275,12 +274,7 @@ updateIndexGit menv = do
275274
let tarFile = configPackageIndex config
276275
idxPath = parent tarFile
277276
liftIO (createDirectoryIfMissing True (toFilePath idxPath))
278-
path <- liftIO (findExecutable "git")
279-
case path of
280-
Nothing ->
281-
error "Please install git and provide the executable on your PATH"
282-
Just fp ->
283-
do gitPath <- parseAbsFile fp
277+
do
284278
gitUrl <- askPackageIndexGitUrl
285279
repoName <- parseRelDir $ takeBaseName $ T.unpack gitUrl
286280
let cloneArgs =
@@ -300,13 +294,13 @@ updateIndexGit menv = do
300294
liftIO (doesDirectoryExist (toFilePath acfDir))
301295
unless repoExists
302296
(do $logInfo ("Cloning repository for first from " <> gitUrl)
303-
runIn suDir gitPath menv cloneArgs Nothing)
304-
runIn acfDir gitPath menv ["fetch","--tags","--depth=1"] Nothing
297+
runIn suDir "git" menv cloneArgs Nothing)
298+
runIn acfDir "git" menv ["fetch","--tags","--depth=1"] Nothing
305299
_ <-
306300
(liftIO . tryIO) (removeFile (toFilePath tarFile))
307301
when (configGpgVerifyIndex config)
308302
(do runIn acfDir
309-
gitPath
303+
"git"
310304
menv
311305
["tag","-v","current-hackage"]
312306
(Just (unlines ["Signature verification failed. "
@@ -318,7 +312,7 @@ updateIndexGit menv = do
318312
(T.pack . toFilePath) tarFile)
319313
deleteCache
320314
runIn acfDir
321-
gitPath
315+
"git"
322316
menv
323317
["archive"
324318
,"--format=tar"
@@ -377,9 +371,7 @@ getPkgVersions menv pkg = do
377371
isGitInstalled :: MonadIO m -- FIXME use the EnvOverride for finding git
378372
=> EnvOverride
379373
-> m Bool
380-
isGitInstalled _FIXMEunused =
381-
return . isJust =<<
382-
liftIO (findExecutable "git")
374+
isGitInstalled = flip doesExecutableExist "git"
383375

384376
-- | Delete the package index cache
385377
deleteCache :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m) => m ()

0 commit comments

Comments
 (0)