Skip to content

Commit

Permalink
Merge pull request #2232 from cblp/ghc-from-file
Browse files Browse the repository at this point in the history 
Install GHC from file
  • Loading branch information
@mgsloan
mgsloan committed Aug 6, 2016
2 parents 2b34483 + 74d7cd9 commit d9626de
Show file tree
Hide file tree
Showing 5 changed files with 125 additions and 114 deletions.
1 change: 1 addition & 0 deletions ChangeLog.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@ Other enhancements:
See [#2259](https://github.com/commercialhaskell/stack/issues/2259)
* Perform some subprocesses during setup concurrently, slightly speeding up most
commands. [#2346](https://github.com/commercialhaskell/stack/pull/2346)
* Support for absolute file path in `url` field of `setup-info` or `--ghc-bindist`

Bug fixes:

Expand Down
2 changes: 2 additions & 0 deletions doc/yaml_configuration.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -453,6 +453,8 @@ setup-info:
url: "https://example.com/ghc-7.10.2-i386-unknown-mingw32-foo.tar.xz"
```

`url` may be either URL or (since UNRELEASED) absolute file path.

### pvp-bounds

(Since 0.1.5)
Expand Down
206 changes: 109 additions & 97 deletions src/Stack/Setup.hs
View file
Original file line number Diff line number Diff line change
@@ -1,16 +1,12 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-} -- ghc < 7.10
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module Stack.Setup
( setupEnv
Expand All @@ -22,82 +18,84 @@ module Stack.Setup
, removeHaskellEnvVars
) where

import Control.Applicative
import Control.Concurrent.Async.Lifted (Concurrently(..))
import Control.Exception.Enclosed (catchIO, tryAny)
import Control.Monad (liftM, when, join, void, unless)
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, ReaderT (..), asks)
import Control.Monad.State (get, put, modify)
import Control.Monad.Trans.Control
import Control.Applicative
import Control.Concurrent.Async.Lifted (Concurrently(..))
import Control.Exception.Enclosed (catchIO, tryAny)
import Control.Monad (liftM, when, join, void, unless)
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, ReaderT (..), asks)
import Control.Monad.State (get, put, modify)
import Control.Monad.Trans.Control
import "cryptohash" Crypto.Hash (SHA1(SHA1))
import Data.Aeson.Extended
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import Data.Char (isSpace)
import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)
import Data.Conduit.Lift (evalStateC)
import qualified Data.Conduit.List as CL
import Data.Either
import Data.Foldable hiding (concatMap, or, maximum)
import Data.IORef
import Data.IORef.RunOnce (runOnce)
import Data.List hiding (concat, elem, maximumBy, any)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import Data.Typeable (Typeable)
import qualified Data.Yaml as Yaml
import Distribution.System (OS, Arch (..), Platform (..))
import qualified Distribution.System as Cabal
import Distribution.Text (simpleParse)
import Lens.Micro (set)
import Network.HTTP.Client.Conduit
import Network.HTTP.Download.Verified
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO hiding (findExecutable)
import qualified Paths_stack as Meta
import Prelude hiding (concat, elem, any) -- Fix AMP warning
import Safe (readMay)
import Stack.Build (build)
import Stack.Config (resolvePackageEntry, loadConfig)
import Stack.Constants (distRelativeDir, stackProgName)
import Stack.Exec (defaultEnvSettings)
import Stack.Fetch
import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath)
import Stack.Setup.Installed
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel, envConfigBuildOpts, buildOptsInstallExes)
import Stack.Types.StackT
import qualified System.Directory as D
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath (searchPathSeparator)
import qualified System.FilePath as FP
import System.Process (rawSystem)
import System.Process.Log (withProcessTimeLog)
import System.Process.Read
import System.Process.Run (runCmd, Cmd(..))
import Text.Printf (printf)
import Data.Aeson.Extended
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import Data.Char (isSpace)
import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)
import Data.Conduit.Lift (evalStateC)
import qualified Data.Conduit.List as CL
import Data.Either
import Data.Foldable hiding (concatMap, or, maximum)
import Data.IORef
import Data.IORef.RunOnce (runOnce)
import Data.List hiding (concat, elem, maximumBy, any)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import Data.Typeable (Typeable)
import qualified Data.Yaml as Yaml
import Distribution.System (OS, Arch (..), Platform (..))
import qualified Distribution.System as Cabal
import Distribution.Text (simpleParse)
import Lens.Micro (set)
import Network.HTTP.Client.Conduit (HasHttpManager, Manager, getHttpManager, parseUrl,
responseBody, withResponse)
import Network.HTTP.Download (parseUrlThrow)
import Network.HTTP.Download.Verified
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO hiding (findExecutable)
import qualified Paths_stack as Meta
import Prelude hiding (concat, elem, any) -- Fix AMP warning
import Safe (readMay)
import Stack.Build (build)
import Stack.Config (resolvePackageEntry, loadConfig)
import Stack.Constants (distRelativeDir, stackProgName)
import Stack.Exec (defaultEnvSettings)
import Stack.Fetch
import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath)
import Stack.Setup.Installed
import Stack.Types.Build
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel, envConfigBuildOpts, buildOptsInstallExes)
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.StackT
import Stack.Types.Version
import qualified System.Directory as D
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath (searchPathSeparator)
import qualified System.FilePath as FP
import System.Process (rawSystem)
import System.Process.Log (withProcessTimeLog)
import System.Process.Read
import System.Process.Run (runCmd, Cmd(..))
import Text.Printf (printf)

-- | Default location of the stack-setup.yaml file
defaultStackSetupYaml :: String
Expand Down Expand Up @@ -556,7 +554,7 @@ upgradeCabal menv wc = do
, "dir="
, installRoot FP.</> name'
]
args = ( "configure": map dirArgument (words "lib bin data doc") )
args = "configure" : map dirArgument (words "lib bin data doc")
runCmd (Cmd (Just dir) setupExe menv args) Nothing
runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing
runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing
Expand Down Expand Up @@ -670,7 +668,7 @@ downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReade
-> VersionCheck
-> Maybe String
-> m Tool
downloadAndInstallCompiler si wanted@(GhcVersion{}) versionCheck mbindistURL = do
downloadAndInstallCompiler si wanted@GhcVersion{} versionCheck mbindistURL = do
ghcVariant <- asks getGHCVariant
(selectedVersion, downloadInfo) <- case mbindistURL of
Just bindistURL -> do
Expand Down Expand Up @@ -767,16 +765,30 @@ downloadFromInfo programsDir downloadInfo tool = do
".tar.bz2" -> return TarBz2
".tar.gz" -> return TarGz
".7z.exe" -> return SevenZ
_ -> error $ "Unknown extension for url: " ++ T.unpack url
_ -> fail $ "Unknown extension for url: " ++ url
relfile <- parseRelFile $ toolString tool ++ extension
let path = programsDir </> relfile
ensureDir programsDir
chattyDownload (T.pack (toolString tool)) downloadInfo path
path <- case url of
(parseUrl -> Just _) -> do
let path = programsDir </> relfile
ensureDir programsDir
chattyDownload (T.pack (toolString tool)) downloadInfo path
return path
(parseAbsFile -> Just path) -> do
let DownloadInfo{downloadInfoContentLength=contentLength, downloadInfoSha1=sha1} =
downloadInfo
when (isJust contentLength) $
$logWarn "`content-length` in not checked \n\
\and should not be specified when `url` is a file path"
when (isJust sha1) $
$logWarn "`sha1` is not checked and \n\
\should not be specified when `url` is a file path"
return path
_ ->
fail $ "`url` must be either an HTTP URL or absolute file path: " ++ url
return (path, at)
where
url = downloadInfoUrl downloadInfo
extension =
loop $ T.unpack url
url = T.unpack $ downloadInfoUrl downloadInfo
extension = loop url
where
loop fp
| ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext
Expand Down Expand Up @@ -905,8 +917,8 @@ installGHCJS si archiveFile archiveType destDir = do
_ -> return Nothing

$logSticky "Installing GHCJS (this will take a long time) ..."
runInnerStackT ((set (envConfigBuildOpts.buildOptsInstallExes) True envConfig')) $
(build (\_ -> return ()) Nothing defaultBuildOptsCLI)
runInnerStackT (set (envConfigBuildOpts.buildOptsInstallExes) True envConfig') $
build (\_ -> return ()) Nothing defaultBuildOptsCLI
-- Copy over *.options files needed on windows.
forM_ mwindowsInstallDir $ \dir -> do
(_, files) <- listDir (dir </> $(mkRelDir "bin"))
Expand Down Expand Up @@ -1370,7 +1382,7 @@ getUtf8EnvVars
:: forall m env.
(MonadReader env m, HasPlatform env, MonadLogger m, MonadCatch m, MonadBaseControl IO m, MonadIO m)
=> EnvOverride -> CompilerVersion -> m (Map Text Text)
getUtf8EnvVars menv compilerVer = do
getUtf8EnvVars menv compilerVer =
if getGhcVersion compilerVer >= $(mkVersion "7.10.3")
-- GHC_CHARENC supported by GHC >=7.10.3
then return $ Map.singleton "GHC_CHARENC" "UTF-8"
Expand Down
1 change: 0 additions & 1 deletion src/Stack/Types/Build.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,7 +35,6 @@ module Stack.Types.Build
,buildCacheVC
,ConfigCache(..)
,configCacheVC
,ConstructPlanException(..)
,configureOpts
,isStackOpt
,wantedLocalPackages
Expand Down
29 changes: 13 additions & 16 deletions src/Stack/Types/Config.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -532,11 +532,11 @@ instance FromJSON (WithJSONWarnings PackageEntry) where
parseJSON (String t) = do
WithJSONWarnings loc _ <- parseJSON $ String t
return $ noJSONWarnings
(PackageEntry
PackageEntry
{ peExtraDep = False
, peLocation = loc
, peSubdirs = []
})
}
parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry
<$> o ..:? "extra-dep" ..!= False
<*> jsonSubWarnings (o ..: "location")
Expand Down Expand Up @@ -604,14 +604,14 @@ data Project = Project

instance ToJSON Project where
toJSON p = object $
(maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p))
((maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p))
maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p) $
maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p)
[ "packages" .= projectPackages p
, "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p)
, "flags" .= projectFlags p
, "resolver" .= projectResolver p
, "extra-package-dbs" .= projectExtraPackageDBs p
])
]

data IsLoaded = Loaded | NotLoaded

Expand Down Expand Up @@ -663,7 +663,7 @@ instance FromJSON (WithJSONWarnings (ResolverThat's 'NotLoaded)) where

parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t)

parseJSON _ = fail $ "Invalid Resolver, must be Object or String"
parseJSON _ = fail "Invalid Resolver, must be Object or String"

-- | Convert a Resolver into its @Text@ representation, as will be used by
-- directory names
Expand Down Expand Up @@ -1093,7 +1093,7 @@ instance Show ConfigException where
,"version range specified in stack.yaml ("
, T.unpack (versionRangeText requiredRange)
, ")." ]
show (NoMatchingSnapshot whichCmd names) = concat $
show (NoMatchingSnapshot whichCmd names) = concat
[ "None of the following snapshots provides a compiler matching "
, "your package(s):\n"
, unlines $ map (\name -> " - " <> T.unpack (renderSnapName name))
Expand All @@ -1115,14 +1115,10 @@ instance Show ConfigException where
, unlines $ fmap (" " <>) (lines errDesc)
, showOptions whichCmd
]
show (NoSuchDirectory dir) = concat
["No directory could be located matching the supplied path: "
,dir
]
show (ParseGHCVariantException v) = concat
[ "Invalid ghc-variant value: "
, v
]
show (NoSuchDirectory dir) =
"No directory could be located matching the supplied path: " ++ dir
show (ParseGHCVariantException v) =
"Invalid ghc-variant value: " ++ v
show (BadStackRoot stackRoot) = concat
[ "Invalid stack root: '"
, toFilePath stackRoot
Expand All @@ -1146,7 +1142,7 @@ instance Show ConfigException where
instance Exception ConfigException

showOptions :: WhichSolverCmd -> String
showOptions whichCmd = unlines $ ["\nThis may be resolved by:"] ++ options
showOptions whichCmd = unlines $ "\nThis may be resolved by:" : options
where
options =
case whichCmd of
Expand Down Expand Up @@ -1536,6 +1532,7 @@ parseGHCVariant s =
-- | Information for a file to download.
data DownloadInfo = DownloadInfo
{ downloadInfoUrl :: Text
-- ^ URL or absolute file path
, downloadInfoContentLength :: Maybe Int
, downloadInfoSha1 :: Maybe ByteString
} deriving (Show)
Expand Down

0 comments on commit d9626de

Please sign in to comment.