diff --git a/ChangeLog.md b/ChangeLog.md index 7ca9ce4a4a..5f51336e25 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -3,6 +3,14 @@ Major changes: * On Windows, we now use a full MSYS2 installation in place of the previous PortableGit. This gives you access to the pacman package manager for more easily installing libraries. +* Support for custom GHC binary distributions [#530](https://github.com/commercialhaskell/stack/issues/530) + * `ghc-variant` option in stack.yaml to specify the variant (also + `--ghc-variant` command-line option) + * `setup-info` in stack.yaml, to specify where to download custom binary + distributions (also `--ghc-bindist` command-line option) + * Note: On systems with libgmp4 (aka `libgmp.so.3`), such as CentOS 6, you + may need to re-run `stack setup` due to the centos6 GHC bindist being + treated like a variant Other enhancements: diff --git a/src/Data/Aeson/Extended.hs b/src/Data/Aeson/Extended.hs index 6b7a938ab6..343fb7f57f 100644 --- a/src/Data/Aeson/Extended.hs +++ b/src/Data/Aeson/Extended.hs @@ -10,13 +10,15 @@ module Data.Aeson.Extended ( , WarningParser , JSONWarning (..) , withObjectWarnings - , (..:) - , (..:?) - , (..!=) , jsonSubWarnings , jsonSubWarningsT - , jsonSubWarningsMT + , jsonSubWarningsTT , logJSONWarnings + , tellJSONField + , unWarningParser + , (..:) + , (..:?) + , (..!=) ) where import Control.Monad.Logger (MonadLogger, logWarn) @@ -49,13 +51,13 @@ import Prelude -- Fix redundant import warnings (..:) :: FromJSON a => Object -> Text -> WarningParser a -o ..: k = tellField k >> lift (o .: k) +o ..: k = tellJSONField k >> lift (o .: k) -- | 'WarningParser' version of @.:?@. (..:?) :: FromJSON a => Object -> Text -> WarningParser (Maybe a) -o ..:? k = tellField k >> lift (o .:? k) +o ..:? k = tellJSONField k >> lift (o .:? k) -- | 'WarningParser' version of @.!=@. (..!=) :: WarningParser (Maybe a) -> a -> WarningParser a @@ -65,11 +67,11 @@ wp ..!= d = do a <- fmap snd p fmap (, a) (fmap fst p .!= d) --- | Tell warning parser about about an expected field. -tellField :: Text -> WarningParser () -tellField key = tell (mempty { wpmExpectedFields = Set.singleton key}) +-- | Tell warning parser about about an expected field, so it doesn't warn about it. +tellJSONField :: Text -> WarningParser () +tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key}) --- | 'MonadParser' version of 'withObject'. +-- | 'WarningParser' version of 'withObject'. withObjectWarnings :: String -> (Object -> WarningParser a) -> Value @@ -90,6 +92,12 @@ withObjectWarnings expected f = [] -> [] _ -> [JSONUnrecognizedFields expected unrecognizedFields]) +-- | Convert a 'WarningParser' to a 'Parser'. +unWarningParser :: WarningParser a -> Parser a +unWarningParser wp = do + (a,_) <- runWriterT wp + return a + -- | Log JSON warnings. logJSONWarnings :: MonadLogger m @@ -115,20 +123,17 @@ jsonSubWarningsT f = Traversable.mapM (jsonSubWarnings . return) =<< f -- | Handle warnings in a @Maybe Traversable@ of sub-objects. -jsonSubWarningsMT - :: (Traversable t) - => WarningParser (Maybe (t (a, [JSONWarning]))) - -> WarningParser (Maybe (t a)) -jsonSubWarningsMT f = do - ml <- f - case ml of - Nothing -> return Nothing - Just l -> fmap Just (jsonSubWarningsT (return l)) +jsonSubWarningsTT + :: (Traversable t, Traversable u) + => WarningParser (u (t (a, [JSONWarning]))) + -> WarningParser (u (t a)) +jsonSubWarningsTT f = + Traversable.mapM (jsonSubWarningsT . return) =<< f -- | JSON parser that warns about unexpected fields in objects. type WarningParser a = WriterT WarningParserMonoid Parser a --- | Monoid used by 'MonadParser' to track expected fields and warnings. +-- | Monoid used by 'WarningParser' to track expected fields and warnings. data WarningParserMonoid = WarningParserMonoid { wpmExpectedFields :: !(Set Text) , wpmWarnings :: [JSONWarning] diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 5c82662ac9..c2c095223f 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -108,6 +108,7 @@ data Ctx = Ctx instance HasStackRoot Ctx instance HasPlatform Ctx +instance HasGHCVariant Ctx instance HasConfig Ctx instance HasBuildConfig Ctx where getBuildConfig = getBuildConfig . getEnvConfig diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 18b18e43a5..f194f77bea 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -429,7 +429,7 @@ instance FromJSON Snapshots where -- | Load up a 'MiniBuildPlan', preferably from cache loadMiniBuildPlan - :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadCatch m) + :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m) => SnapName -> m MiniBuildPlan loadMiniBuildPlan name = do @@ -587,7 +587,7 @@ instance Monoid DepError where -- | Find a snapshot and set of flags that is compatible with the given -- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found. -findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m) +findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m) => [GenericPackageDescription] -> [SnapName] -> m (Maybe (SnapName, Map PackageName (Map FlagName Bool))) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index bc52ca714e..aaff5c5a4b 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -21,7 +21,9 @@ -- probably default to behaving like cabal, possibly with spitting out -- a warning that "you should run `stk init` to make things better". module Stack.Config - (loadConfig + (MiniConfig + ,loadConfig + ,loadMiniConfig ,packagesParser ,resolvePackageEntry ) where @@ -35,7 +37,7 @@ import Control.Monad import Control.Monad.Catch (Handler(..), MonadCatch, MonadThrow, catches, throwM) import Control.Monad.IO.Class import Control.Monad.Logger hiding (Loc) -import Control.Monad.Reader (MonadReader, ask, asks, runReaderT) +import Control.Monad.Reader (MonadReader, ask, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson.Extended @@ -46,7 +48,8 @@ import qualified Data.Map as Map import Data.Maybe import Data.Monoid import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Text.Encoding (encodeUtf8, decodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Yaml as Yaml import Distribution.System (OS (..), Platform (..), buildPlatform) import qualified Distribution.Text @@ -58,6 +61,7 @@ import Options.Applicative (Parser, strOption, long, help) import Path import Path.IO import qualified Paths_stack as Meta +import Safe (headMay) import Stack.BuildPlan import Stack.Constants import qualified Stack.Docker as Docker @@ -115,7 +119,9 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = }] configMonoidPackageIndices - configSystemGHC = fromMaybe True configMonoidSystemGHC + configGHCVariant0 = configMonoidGHCVariant + + configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC configInstallGHC = fromMaybe False configMonoidInstallGHC configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck configSkipMsys = fromMaybe False configMonoidSkipMsys @@ -147,14 +153,16 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = $ map (T.pack *** T.pack) rawEnv let configEnvOverride _ = return origEnv - platform <- runReaderT platformRelDir configPlatform - + platformOnlyDir <- runReaderT platformOnlyRelDir configPlatform configLocalPrograms <- - case configPlatform of - Platform _ Windows -> do - progsDir <- getWindowsProgsDir configStackRoot origEnv - return $ progsDir $(mkRelDir stackProgName) platform - _ -> return $ configStackRoot $(mkRelDir "programs") platform + case configPlatform of + Platform _ Windows -> do + progsDir <- getWindowsProgsDir configStackRoot origEnv + return $ progsDir $(mkRelDir stackProgName) platformOnlyDir + _ -> + return $ + configStackRoot $(mkRelDir "programs") + platformOnlyDir configLocalBin <- case configMonoidLocalBinPath of @@ -176,9 +184,30 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} = let configTemplateParams = configMonoidTemplateParameters configScmInit = configMonoidScmInit configGhcOptions = configMonoidGhcOptions + configSetupInfoLocations = configMonoidSetupInfoLocations return Config {..} +-- | Get the default 'GHCVariant'. On older Linux systems with libgmp4, returns 'GHCGMP4'. +getDefaultGHCVariant + :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) + => EnvOverride -> Platform -> m GHCVariant +getDefaultGHCVariant menv (Platform _ Linux) = do + executablePath <- liftIO getExecutablePath + elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath] + return $ + case elddOut of + Left _ -> GHCStandard + Right lddOut -> + if hasLineWithFirstWord "libgmp.so.3" lddOut + then GHCGMP4 + else GHCStandard + where + hasLineWithFirstWord w = + elem (Just w) . + map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode +getDefaultGHCVariant _ _ = return GHCStandard + -- | Get the directory on Windows where we should install extra programs. For -- more information, see discussion at: -- https://github.com/fpco/minghc/issues/43#issuecomment-99737383 @@ -193,13 +222,29 @@ getWindowsProgsDir stackRoot m = return $ lad $(mkRelDir "Programs") Nothing -> return $ stackRoot $(mkRelDir "Programs") -data MiniConfig = MiniConfig Manager Config +-- | An environment with a subset of BuildConfig used for setup. +data MiniConfig = MiniConfig Manager GHCVariant Config instance HasConfig MiniConfig where - getConfig (MiniConfig _ c) = c + getConfig (MiniConfig _ _ c) = c instance HasStackRoot MiniConfig instance HasHttpManager MiniConfig where - getHttpManager (MiniConfig man _) = man + getHttpManager (MiniConfig man _ _) = man instance HasPlatform MiniConfig +instance HasGHCVariant MiniConfig where + getGHCVariant (MiniConfig _ v _) = v + +-- | Load the 'MiniConfig'. +loadMiniConfig + :: (MonadIO m, HasHttpManager a, MonadReader a m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) + => Config -> m MiniConfig +loadMiniConfig config = do + menv <- liftIO $ (configEnvOverride config) minimalEnvSettings + manager <- getHttpManager <$> ask + ghcVariant <- + case configGHCVariant0 config of + Just ghcVariant -> return ghcVariant + Nothing -> getDefaultGHCVariant menv (configPlatform config) + return (MiniConfig manager ghcVariant config) -- | Load the configuration, using current directory, environment variables, -- and defaults as necessary. @@ -235,7 +280,8 @@ loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, H -> m BuildConfig loadBuildConfig mproject config stackRoot mresolver = do env <- ask - let miniConfig = MiniConfig (getHttpManager env) config + miniConfig <- loadMiniConfig config + (project', stackYamlFP) <- case mproject of Just (project, fp, _) -> return (project, fp) Nothing -> do @@ -283,10 +329,7 @@ loadBuildConfig mproject config stackRoot mresolver = do case mresolver of Nothing -> return $ projectResolver project' Just aresolver -> do - manager <- asks getHttpManager - runReaderT - (makeConcreteResolver aresolver) - (MiniConfig manager config) + runReaderT (makeConcreteResolver aresolver) miniConfig let project = project' { projectResolver = resolver } wantedCompiler <- @@ -308,6 +351,7 @@ loadBuildConfig mproject config stackRoot mresolver = do , bcStackYaml = stackYamlFP , bcFlags = projectFlags project , bcImplicitGlobal = isNothing mproject + , bcGHCVariant = getGHCVariant miniConfig } -- | Resolve a PackageEntry into a list of paths, downloading and cloning as diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 4a9f9ee033..df277ca733 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -200,7 +200,7 @@ distRelativeDir :: (MonadThrow m, MonadReader env m, HasPlatform env, HasEnvConf => m (Path Rel Dir) distRelativeDir = do cabalPkgVer <- asks (envConfigCabalVersion . getEnvConfig) - platform <- platformRelDir + platform <- platformVariantRelDir cabal <- parseRelDir $ packageIdentifierString diff --git a/src/Stack/Init.hs b/src/Stack/Init.hs index 9e6031dea4..d0b17a7509 100644 --- a/src/Stack/Init.hs +++ b/src/Stack/Init.hs @@ -59,7 +59,7 @@ ignoredDirs = Set.fromList ] -- | Generate stack.yaml -initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m) +initProject :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) => Path Abs Dir -> InitOpts -> m () @@ -126,7 +126,7 @@ getSnapshots' = return Nothing -- | Get the default resolver value -getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m) +getDefaultResolver :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) => [Path Abs File] -- ^ cabal files -> [C.GenericPackageDescription] -- ^ cabal descriptions -> InitOpts @@ -163,7 +163,7 @@ getDefaultResolver cabalfps gpds initOpts = , fmap fst extraDeps ) -getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m) +getRecommendedSnapshots :: (MonadIO m, MonadMask m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadLogger m, MonadBaseControl IO m) => Snapshots -> SnapPref -> m [SnapName] diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index ad225c9eb7..8aab07ba6d 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -216,13 +216,14 @@ readFlag = do -- | Command-line arguments parser for configuration. configOptsParser :: Bool -> Parser ConfigMonoid configOptsParser docker = - (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys localBin -> mempty + (\opts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin -> mempty { configMonoidDockerOpts = opts , configMonoidSystemGHC = systemGHC , configMonoidInstallGHC = installGHC , configMonoidSkipGHCCheck = skipGHCCheck , configMonoidArch = arch , configMonoidOS = os + , configMonoidGHCVariant = ghcVariant , configMonoidJobs = jobs , configMonoidExtraIncludeDirs = includes , configMonoidExtraLibDirs = libs @@ -248,6 +249,7 @@ configOptsParser docker = <> metavar "OS" <> help "Operating system, e.g. linux, windows" )) + <*> optional ghcVariantParser <*> optional (option auto ( long "jobs" <> short 'j' @@ -595,6 +597,21 @@ readAbstractResolver = do Left e -> readerError $ show e Right x -> return $ ARResolver x +-- | GHC variant parser +ghcVariantParser :: Parser GHCVariant +ghcVariantParser = + option + readGHCVariant + (long "ghc-variant" <> metavar "VARIANT" <> + help + "Specialized GHC variant, e.g. integersimple (implies --no-system-ghc)") + where + readGHCVariant = do + s <- readerAsk + case parseGHCVariant s of + Left e -> readerError (show e) + Right v -> return v + -- | Parser for @solverCmd@ solverOptsParser :: Parser Bool solverOptsParser = boolFlags False diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 14cfe4c85e..eb1a9f4c64 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -727,7 +727,7 @@ mkResolveConditions :: CompilerVersion -- ^ Compiler version mkResolveConditions compilerVersion (Platform arch os) flags = ResolveConditions { rcFlags = flags , rcCompilerVersion = compilerVersion - , rcOS = if isWindows os then Windows else os + , rcOS = os , rcArch = arch } diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 27b150952c..4b9c94ca38 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TupleSections #-} @@ -28,7 +29,6 @@ import Control.Monad.State (get, put, modify) import Control.Monad.Trans.Control import Crypto.Hash (SHA1(SHA1)) import Data.Aeson.Extended -import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever) @@ -61,7 +61,7 @@ import Network.HTTP.Download.Verified import Path import Path.IO import Prelude hiding (concat, elem) -- Fix AMP warning -import Safe (headMay, readMay) +import Safe (readMay) import Stack.Types.Build import Stack.Config (resolvePackageEntry) import Stack.Constants (distRelativeDir) @@ -79,6 +79,7 @@ import System.IO.Temp (withSystemTempDirectory) import System.Process (rawSystem) import System.Process.Read import System.Process.Run (runIn) +import System.IO.Temp (withTempDirectory) import Text.Printf (printf) -- | Default location of the stack-setup.yaml file @@ -106,6 +107,9 @@ data SetupOpts = SetupOpts , soptsResolveMissingGHC :: !(Maybe Text) -- ^ Message shown to user for how to resolve the missing GHC , soptsStackSetupYaml :: !String + -- ^ Location of the main stack-setup.yaml file + , soptsGHCBindistURL :: !(Maybe String) + -- ^ Alternate GHC binary distribution (requires custom GHCVariant) } deriving Show data SetupException = UnsupportedSetupCombo OS Arch @@ -113,6 +117,10 @@ data SetupException = UnsupportedSetupCombo OS Arch | UnknownCompilerVersion Text CompilerVersion (Set Version) | UnknownOSKey Text | GHCSanityCheckCompileFailed ReadProcessException (Path Abs File) + | WantedMustBeGHC + | RequireCustomGHCVariant + | ProblemWhileDecompressing (Path Abs File) + | SetupInfoMissingSevenz deriving Typeable instance Exception SetupException instance Show SetupException where @@ -141,9 +149,17 @@ instance Show SetupException where , "for more information. Exception was:\n" , show e ] + show WantedMustBeGHC = + "The wanted compiler must be GHC" + show RequireCustomGHCVariant = + "A custom --ghc-variant must be specified to use --ghc-bindist" + show (ProblemWhileDecompressing archive) = + "Problem while decompressing " ++ toFilePath archive + show SetupInfoMissingSevenz = + "SetupInfo missing Sevenz EXE/DLL" -- | Modify the environment variables (like PATH) appropriately, possibly doing installation too -setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, MonadBaseControl IO m) +setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m) => Maybe Text -- ^ Message to give user when necessary GHC is not available -> m EnvConfig setupEnv mResolveMissingGHC = do @@ -163,6 +179,7 @@ setupEnv mResolveMissingGHC = do , soptsUpgradeCabal = False , soptsResolveMissingGHC = mResolveMissingGHC , soptsStackSetupYaml = defaultStackSetupYaml + , soptsGHCBindistURL = Nothing } mghcBin <- ensureGHC sopts @@ -283,7 +300,7 @@ instance Monoid ExtraDirs where (c ++ z) -- | Ensure GHC is installed and provide the PATHs to add if necessary -ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) +ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasGHCVariant env, MonadBaseControl IO m) => SetupOpts -> m (Maybe ExtraDirs) ensureGHC sopts = do @@ -320,21 +337,27 @@ ensureGHC sopts = do then do getSetupInfo' <- runOnce (getSetupInfo sopts =<< asks getHttpManager) - config <- asks getConfig - installed <- runReaderT listInstalled config + installed <- listInstalled -- Install GHC - ghcIdent <- case getInstalledTool installed $(mkPackageName "ghc") (isWanted . GhcVersion) of + ghcVariant <- asks getGHCVariant + ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant) + ghcIdent <- case getInstalledTool installed ghcPkgName (isWanted . GhcVersion) of Just ident -> return ident Nothing | soptsInstallIfMissing sopts -> do si <- getSetupInfo' - downloadAndInstallGHC menv0 si (soptsWantedCompiler sopts) (soptsCompilerCheck sopts) + downloadAndInstallGHC + si + (soptsWantedCompiler sopts) + (soptsCompilerCheck sopts) + (soptsGHCBindistURL sopts) | otherwise -> do Platform arch _ <- asks getPlatform throwM $ CompilerVersionMismatch msystem (soptsWantedCompiler sopts, arch) + ghcVariant (soptsCompilerCheck sopts) (soptsStackYaml sopts) (fromMaybe @@ -342,14 +365,15 @@ ensureGHC sopts = do $ soptsResolveMissingGHC sopts) -- Install msys2 on windows, if necessary - mmsys2Ident <- case configPlatform config of - Platform _ os | isWindows os && not (soptsSkipMsys sopts) -> + platform <- asks getPlatform + mmsys2Ident <- case platform of + Platform _ Cabal.Windows | not (soptsSkipMsys sopts) -> case getInstalledTool installed $(mkPackageName "msys2") (const True) of Just ident -> return (Just ident) Nothing | soptsInstallIfMissing sopts -> do si <- getSetupInfo' - osKey <- getOSKey menv0 + osKey <- getOSKey VersionedDownloadInfo version info <- case Map.lookup osKey $ siMsys2 si of Just x -> return x @@ -361,7 +385,7 @@ ensureGHC sopts = do _ -> return Nothing let idents = catMaybes [Just ghcIdent, mmsys2Ident] - paths <- runReaderT (mapM extraDirs idents) config + paths <- mapM extraDirs idents return $ Just $ mconcat paths else return Nothing @@ -475,66 +499,36 @@ getSystemCompiler menv wc = do (_, Nothing) -> return Nothing else return Nothing -data DownloadInfo = DownloadInfo - { downloadInfoUrl :: Text - , downloadInfoContentLength :: Int - , downloadInfoSha1 :: Maybe ByteString - } - deriving Show - -data VersionedDownloadInfo = VersionedDownloadInfo - { vdiVersion :: Version - , vdiDownloadInfo :: DownloadInfo - } - deriving Show - -parseDownloadInfoFromObject :: Yaml.Object -> Yaml.Parser DownloadInfo -parseDownloadInfoFromObject o = do - url <- o .: "url" - contentLength <- o .: "content-length" - sha1TextMay <- o .:? "sha1" - return DownloadInfo - { downloadInfoUrl = url - , downloadInfoContentLength = contentLength - , downloadInfoSha1 = fmap T.encodeUtf8 sha1TextMay - } - -instance FromJSON DownloadInfo where - parseJSON = withObject "DownloadInfo" parseDownloadInfoFromObject -instance FromJSON VersionedDownloadInfo where - parseJSON = withObject "VersionedDownloadInfo" $ \o -> do - version <- o .: "version" - downloadInfo <- parseDownloadInfoFromObject o - return VersionedDownloadInfo - { vdiVersion = version - , vdiDownloadInfo = downloadInfo - } - -data SetupInfo = SetupInfo - { siSevenzExe :: DownloadInfo - , siSevenzDll :: DownloadInfo - , siMsys2 :: Map Text VersionedDownloadInfo - , siGHCs :: Map Text (Map Version DownloadInfo) - } - deriving Show -instance FromJSON SetupInfo where - parseJSON = withObject "SetupInfo" $ \o -> SetupInfo - <$> o .: "sevenzexe-info" - <*> o .: "sevenzdll-info" - <*> o .: "msys2" - <*> o .: "ghc" - -- | Download the most recent SetupInfo -getSetupInfo :: (MonadIO m, MonadThrow m) => SetupOpts -> Manager -> m SetupInfo +getSetupInfo + :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env) + => SetupOpts -> Manager -> m SetupInfo getSetupInfo sopts manager = do - bs <- - case parseUrl $ soptsStackSetupYaml sopts of - Just req -> do - bss <- liftIO $ flip runReaderT manager - $ withResponse req $ \res -> responseBody res $$ CL.consume - return $ S8.concat bss - Nothing -> liftIO $ S.readFile $ soptsStackSetupYaml sopts - either throwM return $ Yaml.decodeEither' bs + config <- asks getConfig + setupInfos <- + mapM + loadSetupInfo + (SetupInfoFileOrURL (soptsStackSetupYaml sopts) : + configSetupInfoLocations config) + return + (mconcat setupInfos) + where + loadSetupInfo (SetupInfoInline si) = return si + loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do + bs <- + case parseUrl urlOrFile of + Just req -> do + bss <- + liftIO $ + flip runReaderT manager $ + withResponse req $ + \res -> + responseBody res $$ CL.consume + return $ S8.concat bss + Nothing -> liftIO $ S.readFile urlOrFile + (si,warnings) <- either throwM return (Yaml.decodeEither' bs) + logJSONWarnings urlOrFile warnings + return si markInstalled :: (MonadIO m, MonadReader env m, HasConfig env, MonadThrow m) => PackageIdentifier -- ^ e.g., ghc-7.8.4, msys2-20150512 @@ -577,16 +571,16 @@ extraDirs :: (MonadReader env m, HasConfig env, MonadThrow m, MonadLogger m) => PackageIdentifier -> m ExtraDirs extraDirs ident = do - config <- asks getConfig + platform <- asks getPlatform dir <- installDir ident - case (configPlatform config, packageNameString $ packageIdentifierName ident) of - (Platform _ (isWindows -> True), "ghc") -> return mempty + case (platform, packageNameString $ packageIdentifierName ident) of + (Platform _ Cabal.Windows, isGHC -> True) -> return mempty { edBins = goList [ dir $(mkRelDir "bin") , dir $(mkRelDir "mingw") $(mkRelDir "bin") ] } - (Platform _ (isWindows -> True), "msys2") -> return mempty + (Platform _ Cabal.Windows, "msys2") -> return mempty { edBins = goList [ dir $(mkRelDir "usr") $(mkRelDir "bin") ] @@ -599,7 +593,7 @@ extraDirs ident = do , dir $(mkRelDir "mingw32") $(mkRelDir "lib") ] } - (_, "ghc") -> return mempty + (_, isGHC -> True) -> return mempty { edBins = goList [ dir $(mkRelDir "bin") ] @@ -609,6 +603,7 @@ extraDirs ident = do return mempty where goList = map toFilePathNoTrailingSlash + isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n getInstalledTool :: [PackageIdentifier] -- ^ already installed -> PackageName -- ^ package to find @@ -640,64 +635,75 @@ downloadAndInstallTool si downloadInfo name version installer = do markInstalled ident return ident -downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) - => EnvOverride - -> SetupInfo +downloadAndInstallGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, MonadBaseControl IO m) + => SetupInfo -> CompilerVersion -> VersionCheck + -> (Maybe String) -> m PackageIdentifier -downloadAndInstallGHC menv si wanted versionCheck = do - osKey <- getOSKey menv - pairs <- - case Map.lookup osKey $ siGHCs si of - Nothing -> throwM $ UnknownOSKey osKey - Just pairs -> return pairs - let mpair = - listToMaybe $ - sortBy (flip (comparing fst)) $ - filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs) - (selectedVersion, downloadInfo) <- - case mpair of - Just pair -> return pair - Nothing -> throwM $ UnknownCompilerVersion osKey wanted (Map.keysSet pairs) - platform <- asks $ configPlatform . getConfig +downloadAndInstallGHC si wanted versionCheck mbindistURL = do + ghcVariant <- asks getGHCVariant + (selectedVersion, downloadInfo) <- case mbindistURL of + Just bindistURL -> do + case ghcVariant of + GHCCustom _ -> return () + _ -> throwM RequireCustomGHCVariant + case wanted of + GhcVersion version -> + return (version, DownloadInfo (T.pack bindistURL) Nothing Nothing) + _ -> + throwM WantedMustBeGHC + _ -> do + ghcKey <- getGhcKey + pairs <- + case Map.lookup ghcKey $ siGHCs si of + Nothing -> throwM $ UnknownOSKey ghcKey + Just pairs -> return pairs + let mpair = + listToMaybe $ + sortBy (flip (comparing fst)) $ + filter (\(v, _) -> isWantedCompiler versionCheck wanted (GhcVersion v)) (Map.toList pairs) + case mpair of + Just pair -> return pair + Nothing -> throwM $ UnknownCompilerVersion ghcKey wanted (Map.keysSet pairs) + platform <- asks getPlatform let installer = case platform of - Platform _ os | isWindows os -> installGHCWindows + Platform _ Cabal.Windows -> installGHCWindows _ -> installGHCPosix - $logInfo "Preparing to install GHC to an isolated location." + $logInfo $ + "Preparing to install GHC" <> + (case ghcVariant of + GHCStandard -> "" + v -> " (" <> T.pack (ghcVariantName v) <> ")") <> + " to an isolated location." $logInfo "This will not interfere with any system-level installation." - downloadAndInstallTool si downloadInfo $(mkPackageName "ghc") selectedVersion installer - -getOSKey :: (MonadReader env m, MonadThrow m, HasConfig env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) - => EnvOverride -> m Text -getOSKey menv = do - platform <- asks $ configPlatform . getConfig + ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant) + downloadAndInstallTool si downloadInfo ghcPkgName selectedVersion installer + +getGhcKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) + => m Text +getGhcKey = do + ghcVariant <- asks getGHCVariant + osKey <- getOSKey + return $ osKey <> T.pack (ghcVariantSuffix ghcVariant) + +getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m) + => m Text +getOSKey = do + platform <- asks getPlatform case platform of - Platform I386 Cabal.Linux -> ("linux32" <>) <$> getLinuxSuffix - Platform X86_64 Cabal.Linux -> ("linux64" <>) <$> getLinuxSuffix - Platform I386 Cabal.OSX -> return "macosx" - Platform X86_64 Cabal.OSX -> return "macosx" + Platform I386 Cabal.Linux -> return "linux32" + Platform X86_64 Cabal.Linux -> return "linux64" + Platform I386 Cabal.OSX -> return "macosx" + Platform X86_64 Cabal.OSX -> return "macosx" Platform I386 Cabal.FreeBSD -> return "freebsd32" Platform X86_64 Cabal.FreeBSD -> return "freebsd64" Platform I386 Cabal.OpenBSD -> return "openbsd32" Platform X86_64 Cabal.OpenBSD -> return "openbsd64" Platform I386 Cabal.Windows -> return "windows32" Platform X86_64 Cabal.Windows -> return "windows64" - - Platform I386 (Cabal.OtherOS "windowsintegersimple") -> return "windowsintegersimple32" - Platform X86_64 (Cabal.OtherOS "windowsintegersimple") -> return "windowsintegersimple64" - Platform arch os -> throwM $ UnsupportedSetupCombo os arch - where - getLinuxSuffix = do - executablePath <- liftIO getExecutablePath - elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath] - return $ case elddOut of - Left _ -> "" - Right lddOut -> if hasLineWithFirstWord "libgmp.so.3" lddOut then "-gmp4" else "" - hasLineWithFirstWord w = - elem (Just w) . map (headMay . T.words) . T.lines . T.decodeUtf8With T.lenientDecode downloadFromInfo :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m) => DownloadInfo @@ -759,7 +765,10 @@ installGHCPosix _ archiveFile archiveType destDir ident = do withSystemTempDirectory "stack-setup" $ \root' -> do root <- parseAbsDir root' - dir <- liftM (root Path.) $ parseRelDir $ packageIdentifierString ident + dir <- + liftM (root Path.) $ + parseRelDir $ + "ghc-" ++ versionString (packageIdentifierVersion ident) $logSticky $ T.concat ["Unpacking GHC into ", (T.pack . toFilePath $ root), " ..."] $logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile) @@ -816,7 +825,7 @@ installGHCWindows :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, -> Path Abs Dir -> PackageIdentifier -> m () -installGHCWindows si archiveFile archiveType destDir _ = do +installGHCWindows si archiveFile archiveType destDir ident = do suffix <- case archiveType of TarXz -> return ".xz" @@ -827,18 +836,22 @@ installGHCWindows si archiveFile archiveType destDir _ = do Nothing -> error $ "Invalid GHC filename: " ++ show archiveFile Just x -> parseAbsFile $ T.unpack x - config <- asks getConfig - run7z <- setup7z si config - - run7z (parent archiveFile) archiveFile - run7z (parent archiveFile) tarFile - removeFile tarFile `catchIO` \e -> - $logWarn (T.concat - [ "Exception when removing " - , T.pack $ toFilePath tarFile - , ": " - , T.pack $ show e - ]) + run7z <- setup7z si + + withTempDirectory (toFilePath $ parent destDir) + ((FP.dropTrailingPathSeparator $ toFilePath $ dirname destDir) ++ "-tmp") $ \tmpDir0 -> do + tmpDir <- parseAbsDir tmpDir0 + run7z (parent archiveFile) archiveFile + run7z tmpDir tarFile + removeFile tarFile `catchIO` \e -> + $logWarn (T.concat + [ "Exception when removing " + , T.pack $ toFilePath tarFile + , ": " + , T.pack $ show e + ]) + tarComponent <- parseRelDir $ "ghc-" ++ versionString (packageIdentifierVersion ident) + renameDir (tmpDir tarComponent) destDir $logInfo $ "GHC installed to " <> T.pack (toFilePath destDir) @@ -861,8 +874,7 @@ installMsys2Windows osKey si archiveFile archiveType destDir _ = do Nothing -> error $ "Invalid MSYS2 filename: " ++ show archiveFile Just x -> parseAbsFile $ T.unpack x - config <- asks getConfig - run7z <- setup7z si config + run7z <- setup7z si exists <- liftIO $ D.doesDirectoryExist $ toFilePath destDir when exists $ liftIO (D.removeDirectoryRecursive $ toFilePath destDir) `catchIO` \e -> do @@ -905,26 +917,27 @@ installMsys2Windows osKey si archiveFile archiveType destDir _ = do -- | Download 7z as necessary, and get a function for unpacking things. -- -- Returned function takes an unpack directory and archive. -setup7z :: (MonadReader env m, HasHttpManager env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) +setup7z :: (MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadIO m, MonadIO n, MonadLogger m, MonadBaseControl IO m) => SetupInfo - -> Config -> m (Path Abs Dir -> Path Abs File -> n ()) -setup7z si config = do - chattyDownload "7z.dll" (siSevenzDll si) dll - chattyDownload "7z.exe" (siSevenzExe si) exe - return $ \outdir archive -> liftIO $ do - ec <- rawSystem (toFilePath exe) - [ "x" - , "-o" ++ toFilePath outdir - , "-y" - , toFilePath archive - ] - when (ec /= ExitSuccess) - $ error $ "Problem while decompressing " ++ toFilePath archive - where - dir = configLocalPrograms config $(mkRelDir "7z") - exe = dir $(mkRelFile "7z.exe") - dll = dir $(mkRelFile "7z.dll") +setup7z si = do + dir <- asks $ configLocalPrograms . getConfig + let exe = dir $(mkRelFile "7z.exe") + dll = dir $(mkRelFile "7z.dll") + case (siSevenzDll si, siSevenzExe si) of + (Just sevenzDll, Just sevenzExe) -> do + chattyDownload "7z.dll" sevenzDll dll + chattyDownload "7z.exe" sevenzExe exe + return $ \outdir archive -> liftIO $ do + ec <- rawSystem (toFilePath exe) + [ "x" + , "-o" ++ toFilePath outdir + , "-y" + , toFilePath archive + ] + when (ec /= ExitSuccess) + $ throwM (ProblemWhileDecompressing archive) + _ -> throwM SetupInfoMissingSevenz chattyDownload :: (MonadReader env m, HasHttpManager env, MonadIO m, MonadLogger m, MonadThrow m, MonadBaseControl IO m) => Text -- ^ label @@ -963,7 +976,7 @@ chattyDownload label downloadInfo path = do let dReq = DownloadRequest { drRequest = req , drHashChecks = hashChecks - , drLengthCheck = Just totalSize + , drLengthCheck = mtotalSize , drRetryPolicy = drRetryPolicyDefault } runInBase <- liftBaseWith $ \run -> return (void . run) @@ -972,7 +985,7 @@ chattyDownload label downloadInfo path = do then $logStickyDone ("Downloaded " <> label <> ".") else $logStickyDone "Already downloaded." where - totalSize = downloadInfoContentLength downloadInfo + mtotalSize = downloadInfoContentLength downloadInfo chattyDownloadProgress runInBase _ = do _ <- liftIO $ runInBase $ $logSticky $ label <> ": download has begun" @@ -984,21 +997,15 @@ chattyDownload label downloadInfo path = do modify (+ size) totalSoFar <- get liftIO $ runInBase $ $logSticky $ T.pack $ - chattyProgressWithTotal totalSoFar totalSize - - -- Note(DanBurton): Total size is now always known in this file. - -- However, printing in the case where it isn't known may still be - -- useful in other parts of the codebase. - -- So I'm just commenting out the code rather than deleting it. - - -- case mcontentLength of - -- Nothing -> chattyProgressNoTotal totalSoFar - -- Just 0 -> chattyProgressNoTotal totalSoFar - -- Just total -> chattyProgressWithTotal totalSoFar total - ---- Example: ghc: 42.13 KiB downloaded... - --chattyProgressNoTotal totalSoFar = - -- printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...") - -- (T.unpack label) + case mtotalSize of + Nothing -> chattyProgressNoTotal totalSoFar + Just 0 -> chattyProgressNoTotal totalSoFar + Just totalSize -> chattyProgressWithTotal totalSoFar totalSize + + -- Example: ghc: 42.13 KiB downloaded... + chattyProgressNoTotal totalSoFar = + printf ("%s: " <> bytesfmt "%7.2f" totalSoFar <> " downloaded...") + (T.unpack label) -- Example: ghc: 50.00 MiB / 100.00 MiB (50.00%) downloaded... chattyProgressWithTotal totalSoFar total = @@ -1095,7 +1102,7 @@ getUtf8LocaleVars => EnvOverride -> m (Map Text Text) getUtf8LocaleVars menv = do Platform _ os <- asks getPlatform - if isWindows os + if os == Cabal.Windows then -- On Windows, locale is controlled by the code page, so we don't set any environment -- variables. diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 185dde2c26..a8b0d206fe 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -86,6 +86,7 @@ data StackBuildException | CompilerVersionMismatch (Maybe (CompilerVersion, Arch)) (CompilerVersion, Arch) + GHCVariant VersionCheck (Maybe (Path Abs File)) Text -- recommended resolution @@ -131,7 +132,7 @@ instance Show StackBuildException where ", the package id couldn't be found " <> "(via ghc-pkg describe " <> packageNameString name <> "). This shouldn't happen, " <> "please report as a bug") - show (CompilerVersionMismatch mactual (expected, earch) check mstack resolution) = concat + show (CompilerVersionMismatch mactual (expected, earch) ghcVariant check mstack resolution) = concat [ case mactual of Nothing -> "No compiler found, expected " Just (actual, arch) -> concat @@ -149,6 +150,7 @@ instance Show StackBuildException where , T.unpack (compilerVersionName expected) , " (" , display earch + , ghcVariantSuffix ghcVariant , ") (based on " , case mstack of Nothing -> "command line arguments" diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index 197349c2b1..2701f53d77 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -22,7 +22,6 @@ module Stack.Types.BuildPlan , MiniPackageInfo (..) , renderSnapName , parseSnapName - , isWindows ) where import Control.Applicative @@ -398,9 +397,3 @@ data MiniPackageInfo = MiniPackageInfo instance Binary MiniPackageInfo instance HasStructuralInfo MiniPackageInfo instance NFData MiniPackageInfo - - -isWindows :: OS -> Bool -isWindows Windows = True -isWindows (OtherOS "windowsintegersimple") = True -isWindows _ = False diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index cc370bbbf5..685d329efe 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -20,15 +21,16 @@ import Control.Monad.Catch (MonadThrow, throwM) import Control.Monad.Logger (LogLevel(..)) import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO) import Data.Aeson.Extended - (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object, - (.=), (.:), (..:), (..:?), (..!=), Value(String, Object), + (ToJSON, toJSON, FromJSON, parseJSON, withText, object, + (.=), (..:), (..:?), (..!=), Value(String, Object), withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning, - jsonSubWarningsMT) + jsonSubWarningsT, jsonSubWarningsTT, tellJSONField) import Data.Attoparsec.Args import Data.Binary (Binary) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Either (partitionEithers) +import Data.List (stripPrefix) import Data.Hashable (Hashable) import Data.Map (Map) import qualified Data.Map as Map @@ -75,6 +77,10 @@ data Config = -- console ,configPlatform :: !Platform -- ^ The platform we're building for, used in many directory names + ,configGHCVariant0 :: !(Maybe GHCVariant) + -- ^ The variant of GHC requested by the user. + -- In most cases, use 'BuildConfig' or 'MiniConfig's version instead, + -- which will have an auto-detected default. ,configLatestSnapshotUrl :: !Text -- ^ URL for a JSON file containing information on the latest -- snapshots available. @@ -127,6 +133,8 @@ data Config = ,configGhcOptions :: !(Map (Maybe PackageName) [Text]) -- ^ Additional GHC options to apply to either all packages (Nothing) -- or a specific package (Just). + ,configSetupInfoLocations :: ![SetupInfoLocation] + -- ^ Additional SetupInfo (inline or remote) to use to find tools. } -- | Information on a single package index @@ -265,6 +273,8 @@ data BuildConfig = BuildConfig , bcImplicitGlobal :: !Bool -- ^ Are we loading from the implicit global stack.yaml? This is useful -- for providing better error messages. + , bcGHCVariant :: !GHCVariant + -- ^ The variant of GHC used to select a GHC bindist. } -- | Directory containing the project's stack.yaml file @@ -285,8 +295,9 @@ instance HasBuildConfig EnvConfig where getBuildConfig = envConfigBuildConfig instance HasConfig EnvConfig instance HasPlatform EnvConfig +instance HasGHCVariant EnvConfig instance HasStackRoot EnvConfig -class HasBuildConfig r => HasEnvConfig r where +class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where getEnvConfig :: r -> EnvConfig instance HasEnvConfig EnvConfig where getEnvConfig = id @@ -364,7 +375,7 @@ instance ToJSON PackageLocation where toJSON (PLHttpTarball t) = toJSON t toJSON (PLGit x y) = toJSON $ T.unwords ["git", x, y] instance FromJSON (PackageLocation, [JSONWarning]) where - parseJSON v = git v <|> ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v) + parseJSON v = ((,[]) <$> withText "PackageLocation" (\t -> http t <|> file t) v) <|> git v where file t = pure $ PLFilePath $ T.unpack t http t = @@ -420,13 +431,13 @@ instance ToJSON Resolver where , "location" .= location ] toJSON x = toJSON $ resolverName x -instance FromJSON Resolver where +instance FromJSON (Resolver,[JSONWarning]) where -- Strange structuring is to give consistent error messages - parseJSON v@(Object _) = withObject "Resolver" (\o -> ResolverCustom - <$> o .: "name" - <*> o .: "location") v + parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom + <$> o ..: "name" + <*> o ..: "location") v - parseJSON (String t) = either (fail . show) return (parseResolverText t) + parseJSON (String t) = either (fail . show) return ((,[]) <$> parseResolverText t) parseJSON _ = fail $ "Invalid Resolver, must be Object or String" @@ -460,6 +471,15 @@ class HasPlatform env where instance HasPlatform Platform where getPlatform = id +-- | Class for environment values which have a GHCVariant +class HasGHCVariant env where + getGHCVariant :: env -> GHCVariant + default getGHCVariant :: HasBuildConfig env => env -> GHCVariant + getGHCVariant = bcGHCVariant . getBuildConfig + {-# INLINE getGHCVariant #-} +instance HasGHCVariant GHCVariant where + getGHCVariant = id + -- | Class for environment values that can provide a 'Config'. class (HasStackRoot env, HasPlatform env) => HasConfig env where getConfig :: env -> Config @@ -477,6 +497,7 @@ class HasConfig env => HasBuildConfig env where getBuildConfig :: env -> BuildConfig instance HasStackRoot BuildConfig instance HasPlatform BuildConfig +instance HasGHCVariant BuildConfig instance HasConfig BuildConfig instance HasBuildConfig BuildConfig where getBuildConfig = id @@ -512,6 +533,8 @@ data ConfigMonoid = -- ^ Used for overriding the platform ,configMonoidArch :: !(Maybe String) -- ^ Used for overriding the platform + ,configMonoidGHCVariant :: !(Maybe GHCVariant) + -- ^ Used for overriding the GHC variant ,configMonoidJobs :: !(Maybe Int) -- ^ See: 'configJobs' ,configMonoidExtraIncludeDirs :: !(Set Text) @@ -532,6 +555,8 @@ data ConfigMonoid = -- ^ See 'configGhcOptions' ,configMonoidExtraPath :: ![Path Abs Dir] -- ^ Additional paths to search for executables in + ,configMonoidSetupInfoLocations :: ![SetupInfoLocation] + -- ^ Additional setup info (inline or remote) to use for installing tools } deriving Show @@ -549,6 +574,7 @@ instance Monoid ConfigMonoid where , configMonoidRequireStackVersion = anyVersion , configMonoidOS = Nothing , configMonoidArch = Nothing + , configMonoidGHCVariant = Nothing , configMonoidJobs = Nothing , configMonoidExtraIncludeDirs = Set.empty , configMonoidExtraLibDirs = Set.empty @@ -560,6 +586,7 @@ instance Monoid ConfigMonoid where , configMonoidCompilerCheck = Nothing , configMonoidGhcOptions = mempty , configMonoidExtraPath = [] + , configMonoidSetupInfoLocations = mempty } mappend l r = ConfigMonoid { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r @@ -575,6 +602,7 @@ instance Monoid ConfigMonoid where (configMonoidRequireStackVersion r) , configMonoidOS = configMonoidOS l <|> configMonoidOS r , configMonoidArch = configMonoidArch l <|> configMonoidArch r + , configMonoidGHCVariant = configMonoidGHCVariant l <|> configMonoidGHCVariant r , configMonoidJobs = configMonoidJobs l <|> configMonoidJobs r , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r) , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r) @@ -586,6 +614,7 @@ instance Monoid ConfigMonoid where , configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r , configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r) , configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r + , configMonoidSetupInfoLocations = configMonoidSetupInfoLocations l ++ configMonoidSetupInfoLocations r } instance FromJSON (ConfigMonoid, [JSONWarning]) where @@ -600,7 +629,7 @@ parseConfigMonoidJSON obj = do configMonoidConnectionCount <- obj ..:? "connection-count" configMonoidHideTHLoading <- obj ..:? "hide-th-loading" configMonoidLatestSnapshotUrl <- obj ..:? "latest-snapshot-url" - configMonoidPackageIndices <- jsonSubWarningsMT (obj ..:? "package-indices") + configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? "package-indices") configMonoidSystemGHC <- obj ..:? "system-ghc" configMonoidInstallGHC <- obj ..:? "install-ghc" configMonoidSkipGHCCheck <- obj ..:? "skip-ghc-check" @@ -610,6 +639,7 @@ parseConfigMonoidJSON obj = do ..!= VersionRangeJSON anyVersion configMonoidOS <- obj ..:? "os" configMonoidArch <- obj ..:? "arch" + configMonoidGHCVariant <- obj ..:? "ghc-variant" configMonoidJobs <- obj ..:? "jobs" configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty @@ -636,6 +666,9 @@ parseConfigMonoidJSON obj = do configMonoidExtraPath <- forM extraPath $ either (fail . show) return . parseAbsDir . T.unpack + configMonoidSetupInfoLocations <- + maybeToList <$> jsonSubWarningsT (obj ..:? "setup-info") + return ConfigMonoid {..} where handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text]) @@ -669,6 +702,7 @@ data ConfigException | BadStackVersionException VersionRange | NoMatchingSnapshot [SnapName] | NoSuchDirectory FilePath + | ParseGHCVariantException String deriving Typeable instance Show ConfigException where show (ParseConfigFileException configFile exception) = concat @@ -722,6 +756,10 @@ instance Show ConfigException where ["No directory could be located matching the supplied path: " ,dir ] + show (ParseGHCVariantException v) = concat + [ "Invalid ghc-variant value: " + , v + ] instance Exception ConfigException -- | Helper function to ask the environment and apply getConfig @@ -774,8 +812,21 @@ configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs F configInstalledCache = liftM ( $(mkRelFile "installed-cache.bin")) configProjectWorkDir -- | Relative directory for the platform identifier -platformRelDir :: (MonadReader env m, HasPlatform env, MonadThrow m) => m (Path Rel Dir) -platformRelDir = asks getPlatform >>= parseRelDir . Distribution.Text.display +platformOnlyRelDir + :: (MonadReader env m, HasPlatform env, MonadThrow m) + => m (Path Rel Dir) +platformOnlyRelDir = do + platform <- asks getPlatform + parseRelDir (Distribution.Text.display platform) + +-- | Relative directory for the platform identifier +platformVariantRelDir + :: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m) + => m (Path Rel Dir) +platformVariantRelDir = do + platform <- asks getPlatform + ghcVariant <- asks getGHCVariant + parseRelDir (Distribution.Text.display platform <> ghcVariantSuffix ghcVariant) -- | Path to .shake files. configShakeFilesDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs Dir) @@ -786,10 +837,10 @@ configLocalUnpackDir :: (MonadReader env m, HasBuildConfig env) => m (Path Abs D configLocalUnpackDir = liftM ( $(mkRelDir "unpacked")) configProjectWorkDir -- | Directory containing snapshots -snapshotsDir :: (MonadReader env m, HasConfig env, MonadThrow m) => m (Path Abs Dir) +snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir) snapshotsDir = do config <- asks getConfig - platform <- platformRelDir + platform <- platformVariantRelDir return $ configStackRoot config $(mkRelDir "snapshots") platform -- | Installation root for dependencies @@ -807,7 +858,7 @@ installationRootLocal = do bc <- asks getBuildConfig name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc ghc <- compilerVersionDir - platform <- platformRelDir + platform <- platformVariantRelDir return $ configProjectWorkDir bc $(mkRelDir "install") platform name ghc compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir) @@ -836,12 +887,12 @@ flagCacheLocal = do return $ root $(mkRelDir "flag-cache") -- | Where to store mini build plan caches -configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasStackRoot env, HasPlatform env) +configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env) => SnapName -> m (Path Abs File) configMiniBuildPlanCache name = do root <- asks getStackRoot - platform <- platformRelDir + platform <- platformVariantRelDir file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache" -- Yes, cached plans differ based on platform return (root $(mkRelDir "build-plan-cache") platform file) @@ -875,12 +926,16 @@ extraBinDirs = do getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride getMinimalEnvOverride = do config <- asks getConfig - liftIO $ configEnvOverride config EnvSettings - { esIncludeLocals = False - , esIncludeGhcPackagePath = False - , esStackExe = False - , esLocaleUtf8 = False - } + liftIO $ configEnvOverride config minimalEnvSettings + +minimalEnvSettings :: EnvSettings +minimalEnvSettings = + EnvSettings + { esIncludeLocals = False + , esIncludeGhcPackagePath = False + , esStackExe = False + , esLocaleUtf8 = False + } getWhichCompiler :: (MonadReader env m, HasEnvConfig env) => m WhichCompiler getWhichCompiler = asks (whichCompiler . envConfigCompilerVersion . getEnvConfig) @@ -890,7 +945,7 @@ data ProjectAndConfigMonoid instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warnings) where parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do - dirs <- jsonSubWarningsMT (o ..:? "packages") ..!= [packageEntryCurrDir] + dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir] extraDeps' <- o ..:? "extra-deps" ..!= [] extraDeps <- case partitionEithers $ goDeps extraDeps' of @@ -898,7 +953,7 @@ instance (warnings ~ [JSONWarning]) => FromJSON (ProjectAndConfigMonoid, warning (errs, _) -> fail $ unlines errs flags <- o ..:? "flags" ..!= mempty - resolver <- o ..: "resolver" + resolver <- jsonSubWarnings (o ..: "resolver") config <- parseConfigMonoidJSON o let project = Project { projectPackages = dirs @@ -947,3 +1002,131 @@ instance FromJSON SCM where instance ToJSON SCM where toJSON Git = toJSON ("git" :: Text) + +-- | Specialized bariant of GHC (e.g. libgmp4 or integer-simple) +data GHCVariant + = GHCStandard -- ^ Standard bindist + | GHCGMP4 -- ^ Bindist that supports libgmp4 (centos66) + | GHCIntegerSimple -- ^ Bindist that uses integer-simple + | GHCCustom String -- ^ Other bindists + deriving (Show) + +instance FromJSON GHCVariant where + -- Strange structuring is to give consistent error messages + parseJSON = + withText + "GHCVariant" + (either (fail . show) return . parseGHCVariant . T.unpack) + +-- | Render a GHC variant to a String. +ghcVariantName :: GHCVariant -> String +ghcVariantName GHCStandard = "standard" +ghcVariantName GHCGMP4 = "gmp4" +ghcVariantName GHCIntegerSimple = "integersimple" +ghcVariantName (GHCCustom name) = "custom-" ++ name + +-- | Render a GHC variant to a String suffix. +ghcVariantSuffix :: GHCVariant -> String +ghcVariantSuffix GHCStandard = "" +ghcVariantSuffix v = "-" ++ ghcVariantName v + +-- | Parse GHC variant from a String. +parseGHCVariant :: (MonadThrow m) => String -> m GHCVariant +parseGHCVariant s = + case stripPrefix "custom-" s of + Just name -> return (GHCCustom name) + Nothing + | s == "" -> return GHCStandard + | s == "standard" -> return GHCStandard + | s == "gmp4" -> return GHCGMP4 + | s == "integersimple" -> return GHCIntegerSimple + | otherwise -> return (GHCCustom s) + +-- | Information for a file to download. +data DownloadInfo = DownloadInfo + { downloadInfoUrl :: Text + , downloadInfoContentLength :: Maybe Int + , downloadInfoSha1 :: Maybe ByteString + } deriving (Show) + +instance FromJSON (DownloadInfo, [JSONWarning]) where + parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject + +-- | Parse JSON in existing object for 'DownloadInfo' +parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo +parseDownloadInfoFromObject o = do + url <- o ..: "url" + contentLength <- o ..:? "content-length" + sha1TextMay <- o ..:? "sha1" + -- Don't warn about 'version' field that is sometimes included + tellJSONField "version" + return + DownloadInfo + { downloadInfoUrl = url + , downloadInfoContentLength = contentLength + , downloadInfoSha1 = fmap encodeUtf8 sha1TextMay + } + +data VersionedDownloadInfo = VersionedDownloadInfo + { vdiVersion :: Version + , vdiDownloadInfo :: DownloadInfo + } + deriving Show + +instance FromJSON (VersionedDownloadInfo, [JSONWarning]) where + parseJSON = withObjectWarnings "VersionedDownloadInfo" $ \o -> do + version <- o ..: "version" + downloadInfo <- parseDownloadInfoFromObject o + return VersionedDownloadInfo + { vdiVersion = version + , vdiDownloadInfo = downloadInfo + } + +data SetupInfo = SetupInfo + { siSevenzExe :: Maybe DownloadInfo + , siSevenzDll :: Maybe DownloadInfo + , siMsys2 :: Map Text VersionedDownloadInfo + , siGHCs :: Map Text (Map Version DownloadInfo) + } + deriving Show + +instance FromJSON (SetupInfo, [JSONWarning]) where + parseJSON = withObjectWarnings "SetupInfo" $ \o -> do + siSevenzExe <- jsonSubWarningsT (o ..:? "sevenzexe-info") + siSevenzDll <- jsonSubWarningsT (o ..:? "sevenzdll-info") + siMsys2 <- jsonSubWarningsT (o ..:? "msys2" ..!= mempty) + siGHCs <- jsonSubWarningsTT (o ..:? "ghc" ..!= mempty) + -- Don't warn about 'portable-git' that is no-longer used + tellJSONField "portable-git" + return SetupInfo {..} + +instance Monoid SetupInfo where + mempty = + SetupInfo + { siSevenzExe = Nothing + , siSevenzDll = Nothing + , siMsys2 = Map.empty + , siGHCs = Map.empty + } + mappend l r = + SetupInfo + { siSevenzExe = siSevenzExe l <|> siSevenzExe r + , siSevenzDll = siSevenzDll l <|> siSevenzDll r + , siMsys2 = siMsys2 l <> siMsys2 r + , siGHCs = siGHCs l <> siGHCs r } + +-- | Remote or inline 'SetupInfo' +data SetupInfoLocation + = SetupInfoFileOrURL String + | SetupInfoInline SetupInfo + deriving (Show) + +instance FromJSON (SetupInfoLocation, [JSONWarning]) where + parseJSON v = + ((, []) <$> + withText "SetupInfoFileOrURL" (pure . SetupInfoFileOrURL . T.unpack) v) <|> + inline + where + inline = do + (si,w) <- parseJSON v + return (SetupInfoInline si, w) diff --git a/src/Stack/Types/Internal.hs b/src/Stack/Types/Internal.hs index 3ccdc868c2..e25b2657f5 100644 --- a/src/Stack/Types/Internal.hs +++ b/src/Stack/Types/Internal.hs @@ -22,6 +22,8 @@ instance HasStackRoot config => HasStackRoot (Env config) where getStackRoot = getStackRoot . envConfig instance HasPlatform config => HasPlatform (Env config) where getPlatform = getPlatform . envConfig +instance HasGHCVariant config => HasGHCVariant (Env config) where + getGHCVariant = getGHCVariant . envConfig instance HasConfig config => HasConfig (Env config) where getConfig = getConfig . envConfig instance HasBuildConfig config => HasBuildConfig (Env config) where diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index 6813722f72..e40a46f399 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -59,7 +59,7 @@ import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy.Encoding as LT import qualified Data.Text.Lazy as LT import Data.Typeable (Typeable) -import Distribution.System (OS (Windows, OtherOS), Platform (Platform)) +import Distribution.System (OS (Windows), Platform (Platform)) import Path (Path, Abs, Dir, toFilePath, File, parseAbsFile) import Path.IO (createTree, parseRelAsAbsFile) import Prelude -- Fix AMP warning @@ -111,7 +111,6 @@ mkEnvOverride platform tm' = do isWindows = case platform of Platform _ Windows -> True - Platform _ (OtherOS "windowsintegersimple") -> True _ -> False -- | Helper conversion function diff --git a/src/main/Main.hs b/src/main/Main.hs index 8d23ac7bdf..a0a3b48065 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -16,7 +16,7 @@ import Control.Monad hiding (mapM, forM) import qualified Control.Monad.Catch as Catch import Control.Monad.IO.Class import Control.Monad.Logger -import Control.Monad.Reader (ask, asks) +import Control.Monad.Reader (ask, asks, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Attoparsec.Args (withInterpreterArgs) import qualified Data.ByteString.Lazy as L @@ -497,6 +497,7 @@ data SetupCmdOpts = SetupCmdOpts , scoForceReinstall :: !Bool , scoUpgradeCabal :: !Bool , scoStackSetupYaml :: !String + , scoGHCBindistURL :: !(Maybe String) } setupParser :: Parser SetupCmdOpts @@ -515,10 +516,15 @@ setupParser = SetupCmdOpts idm <*> strOption ( long "stack-setup-yaml" - <> help "Location of the stack-setup.yaml file" + <> help "Location of the main stack-setup.yaml file" <> value defaultStackSetupYaml <> showDefault ) + <*> (optional $ strOption + (long "ghc-bindist" + <> metavar "URL" + <> help "Alternate GHC binary distribution (requires custom --ghc-variant)" + )) where readVersion = do s <- readerAsk @@ -544,7 +550,8 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do , configCompilerCheck (lcConfig lc) , Just $ bcStackYaml bc ) - mpaths <- runStackTGlobal manager (lcConfig lc) go $ + miniConfig <- loadMiniConfig (lcConfig lc) + mpaths <- runStackTGlobal manager miniConfig go $ ensureGHC SetupOpts { soptsInstallIfMissing = True , soptsUseSystem = @@ -560,6 +567,7 @@ setupCmd SetupCmdOpts{..} go@GlobalOpts{..} = do , soptsUpgradeCabal = scoUpgradeCabal , soptsResolveMissingGHC = Nothing , soptsStackSetupYaml = scoStackSetupYaml + , soptsGHCBindistURL = scoGHCBindistURL } case mpaths of Nothing -> $logInfo "stack will use the GHC on your PATH" @@ -906,14 +914,18 @@ initCmd :: InitOpts -> GlobalOpts -> IO () initCmd initOpts go = withConfigAndLock go $ do pwd <- getWorkingDir - initProject pwd initOpts + config <- asks getConfig + miniConfig <- loadMiniConfig config + runReaderT (initProject pwd initOpts) miniConfig -- | Create a project directory structure and initialize the stack config. newCmd :: (NewOpts,InitOpts) -> GlobalOpts -> IO () newCmd (newOpts,initOpts) go@GlobalOpts{..} = withConfigAndLock go $ do dir <- new newOpts - initProject dir initOpts + config <- asks getConfig + miniConfig <- loadMiniConfig config + runReaderT (initProject dir initOpts) miniConfig -- | List the available templates. templatesCmd :: () -> GlobalOpts -> IO ()