{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} -- | The general Stack configuration that starts everything off. This should -- be smart to falback if there is no stack.yaml, instead relying on -- whatever files are available. -- -- If there is no stack.yaml, and there is a cabal.config, we -- read in those constraints, and if there's a cabal.sandbox.config, -- we read any constraints from there and also find the package -- database from there, etc. And if there's nothing, we should -- 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 (MiniConfig ,loadConfig ,loadMiniConfig ,packagesParser ,resolvePackageEntry ,getImplicitGlobalProjectDir ,getIsGMP4 ) where import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Arrow ((***)) import Control.Exception (IOException) 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, runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson.Extended import qualified Data.ByteString as S import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Lazy as L import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Maybe import Data.Monoid import qualified Data.Text as T 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 import Distribution.Version (simplifyVersionRange) import GHC.Conc (getNumProcessors) import Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager, parseUrl) import Network.HTTP.Download (download) 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 Stack.Config.Docker import qualified Stack.Image as Image import Stack.Init import Stack.Types import Stack.Types.Internal import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath) import System.Environment import System.IO import System.Process.Read -- | Get the latest snapshot resolver available. getLatestResolver :: (MonadIO m, MonadThrow m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m) => m Resolver getLatestResolver = do snapshots <- getSnapshots let mlts = do (x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots))) return (LTS x y) snap = case mlts of Nothing -> Nightly (snapshotsNightly snapshots) Just lts -> lts return (ResolverSnapshot snap) -- Interprets ConfigMonoid options. configFromConfigMonoid :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env) => Path Abs Dir -- ^ stack root, e.g. ~/.stack -> Path Abs File -- ^ user config file path, e.g. ~/.stack/config.yaml -> Maybe Project -> ConfigMonoid -> m Config configFromConfigMonoid configStackRoot configUserConfigPath mproject configMonoid@ConfigMonoid{..} = do let configConnectionCount = fromMaybe 8 configMonoidConnectionCount configHideTHLoading = fromMaybe True configMonoidHideTHLoading configLatestSnapshotUrl = fromMaybe "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json" configMonoidLatestSnapshotUrl configPackageIndices = fromMaybe [PackageIndex { indexName = IndexName "Hackage" , indexLocation = ILGitHttp "https://github.com/commercialhaskell/all-cabal-hashes.git" "https://s3.amazonaws.com/hackage.fpcomplete.com/00-index.tar.gz" , indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/" , indexGpgVerify = False , indexRequireHashes = False }] configMonoidPackageIndices configGHCVariant0 = configMonoidGHCVariant configSystemGHC = fromMaybe (isNothing configGHCVariant0) configMonoidSystemGHC configInstallGHC = fromMaybe False configMonoidInstallGHC configSkipGHCCheck = fromMaybe False configMonoidSkipGHCCheck configSkipMsys = fromMaybe False configMonoidSkipMsys configExtraIncludeDirs = configMonoidExtraIncludeDirs configExtraLibDirs = configMonoidExtraLibDirs -- Only place in the codebase where platform is hard-coded. In theory -- in the future, allow it to be configured. (Platform defArch defOS) = buildPlatform arch = fromMaybe defArch $ configMonoidArch >>= Distribution.Text.simpleParse os = fromMaybe defOS $ configMonoidOS >>= Distribution.Text.simpleParse configPlatform = Platform arch os configRequireStackVersion = simplifyVersionRange configMonoidRequireStackVersion configConfigMonoid = configMonoid configImage = Image.imgOptsFromMonoid configMonoidImageOpts configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck configDocker <- dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts rawEnv <- liftIO getEnvironment origEnv <- mkEnvOverride configPlatform $ augmentPathMap (map toFilePath configMonoidExtraPath) $ Map.fromList $ map (T.pack *** T.pack) rawEnv let configEnvOverride _ = return origEnv platformOnlyDir <- runReaderT platformOnlyRelDir configPlatform configLocalProgramsBase <- case configPlatform of Platform _ Windows -> do progsDir <- getWindowsProgsDir configStackRoot origEnv return $ progsDir $(mkRelDir stackProgName) _ -> return $ configStackRoot $(mkRelDir "programs") let configLocalPrograms = configLocalProgramsBase platformOnlyDir configLocalBin <- case configMonoidLocalBinPath of Nothing -> do localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir return $ localDir $(mkRelDir "bin") Just userPath -> (liftIO $ canonicalizePath userPath >>= parseAbsDir) `catches` [Handler (\(_ :: IOException) -> throwM $ NoSuchDirectory userPath) ,Handler (\(_ :: PathParseException) -> throwM $ NoSuchDirectory userPath) ] configJobs <- case configMonoidJobs of Nothing -> liftIO getNumProcessors Just i -> return i let configConcurrentTests = fromMaybe True configMonoidConcurrentTests let configTemplateParams = configMonoidTemplateParameters configScmInit = configMonoidScmInit configGhcOptions = configMonoidGhcOptions configSetupInfoLocations = configMonoidSetupInfoLocations configPvpBounds = fromMaybe PvpBoundsNone configMonoidPvpBounds configModifyCodePage = fromMaybe True configMonoidModifyCodePage configExplicitSetupDeps = configMonoidExplicitSetupDeps configRebuildGhcOptions = fromMaybe False configMonoidRebuildGhcOptions configApplyGhcOptions = fromMaybe AGOLocals configMonoidApplyGhcOptions 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 isGMP4 <- getIsGMP4 menv return (if isGMP4 then GHCGMP4 else GHCStandard) getDefaultGHCVariant _ _ = return GHCStandard -- Determine whether 'stack' is linked with libgmp4 (libgmp.so.3) getIsGMP4 :: (MonadIO m, MonadBaseControl IO m, MonadCatch m, MonadLogger m) => EnvOverride -> m Bool getIsGMP4 menv = do executablePath <- liftIO getExecutablePath elddOut <- tryProcessStdout Nothing menv "ldd" [executablePath] return $ case elddOut of Left _ -> False Right lddOut -> hasLineWithFirstWord "libgmp.so.3" lddOut where hasLineWithFirstWord w = elem (Just w) . map (headMay . T.words) . T.lines . decodeUtf8With lenientDecode -- | 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 getWindowsProgsDir :: MonadThrow m => Path Abs Dir -> EnvOverride -> m (Path Abs Dir) getWindowsProgsDir stackRoot m = case Map.lookup "LOCALAPPDATA" $ unEnvOverride m of Just t -> do lad <- parseAbsDir $ T.unpack t return $ lad $(mkRelDir "Programs") Nothing -> return $ stackRoot $(mkRelDir "Programs") -- | An environment with a subset of BuildConfig used for setup. data MiniConfig = MiniConfig Manager GHCVariant Config instance HasConfig MiniConfig where getConfig (MiniConfig _ _ c) = c instance HasStackRoot MiniConfig instance HasHttpManager MiniConfig where 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. loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env) => ConfigMonoid -- ^ Config monoid from parsed command-line arguments -> Maybe (Path Abs File) -- ^ Override stack.yaml -> m (LoadConfig m) loadConfig configArgs mstackYaml = do stackRoot <- determineStackRoot userConfigPath <- getDefaultUserConfigPath stackRoot extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadYaml let extraConfigs = -- non-project config files' existence of a docker section should never default docker -- to enabled, so make it look like they didn't exist map (\c -> c {configMonoidDockerOpts = (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}}) extraConfigs0 mproject <- loadProjectConfig mstackYaml config <- configFromConfigMonoid stackRoot userConfigPath (fmap (\(proj, _, _) -> proj) mproject) $ mconcat $ case mproject of Nothing -> configArgs : extraConfigs Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config) (throwM (BadStackVersionException (configRequireStackVersion config))) return $ LoadConfig { lcConfig = config , lcLoadBuildConfig = loadBuildConfig mproject config , lcProjectRoot = fmap (\(_, fp, _) -> parent fp) mproject } -- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@. -- values. loadBuildConfig :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, HasTerminal env) => Maybe (Project, Path Abs File, ConfigMonoid) -> Config -> Maybe AbstractResolver -- override resolver -> m BuildConfig loadBuildConfig mproject config mresolver = do env <- ask miniConfig <- loadMiniConfig config (project', stackYamlFP) <- case mproject of Just (project, fp, _) -> return (project, fp) Nothing -> do $logInfo "Run from outside a project, using implicit global project config" destDir <- getImplicitGlobalProjectDir config let dest :: Path Abs File dest = destDir stackDotYaml dest' :: FilePath dest' = toFilePath dest createTree destDir exists <- fileExists dest if exists then do ProjectAndConfigMonoid project _ <- loadYaml dest when (getTerminal env) $ case mresolver of Nothing -> $logInfo ("Using resolver: " <> resolverName (projectResolver project) <> " from implicit global project's config file: " <> T.pack dest') Just aresolver -> do let name = case aresolver of ARResolver resolver -> resolverName resolver ARLatestNightly -> "nightly" ARLatestLTS -> "lts" ARLatestLTSMajor x -> T.pack $ "lts-" ++ show x ARGlobal -> "global" $logInfo ("Using resolver: " <> name <> " specified on command line") return (project, dest) else do r <- runReaderT getLatestResolver miniConfig $logInfo ("Using latest snapshot resolver: " <> resolverName r) $logInfo ("Writing implicit global project config file to: " <> T.pack dest') $logInfo "Note: You can change the snapshot via the resolver field there." let p = Project { projectPackages = mempty , projectExtraDeps = mempty , projectFlags = mempty , projectResolver = r , projectExtraPackageDBs = [] } liftIO $ do S.writeFile dest' $ S.concat [ "# This is the implicit global project's config file, which is only used when\n" , "# 'stack' is run outside of a real project. Settings here do _not_ act as\n" , "# defaults for all projects. To change stack's default settings, edit\n" , "# '", encodeUtf8 (T.pack $ toFilePath $ configUserConfigPath config), "' instead.\n" , "#\n" , "# For more information about stack's configuration, see\n" , "# https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md\n" , "#\n" , Yaml.encode p] S.writeFile (toFilePath $ parent dest $(mkRelFile "README.txt")) $ S.concat [ "This is the implicit global project, which is used only when 'stack' is run\n" , "outside of a real project.\n" ] return (p, dest) resolver <- case mresolver of Nothing -> return $ projectResolver project' Just aresolver -> do runReaderT (makeConcreteResolver aresolver) miniConfig let project = project' { projectResolver = resolver } wantedCompiler <- case projectResolver project of ResolverSnapshot snapName -> do mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig return $ mbpCompilerVersion mbp ResolverCustom _name url -> do mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig return $ mbpCompilerVersion mbp ResolverCompiler wantedCompiler -> return wantedCompiler extraPackageDBs <- mapM parseRelAsAbsDir (projectExtraPackageDBs project) return BuildConfig { bcConfig = config , bcResolver = projectResolver project , bcWantedCompiler = wantedCompiler , bcPackageEntries = projectPackages project , bcExtraDeps = projectExtraDeps project , bcExtraPackageDBs = extraPackageDBs , bcStackYaml = stackYamlFP , bcFlags = projectFlags project , bcImplicitGlobal = isNothing mproject , bcGHCVariant = getGHCVariant miniConfig } -- | Resolve a PackageEntry into a list of paths, downloading and cloning as -- necessary. resolvePackageEntry :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m ,MonadBaseControl IO m) => EnvOverride -> Path Abs Dir -- ^ project root -> PackageEntry -> m [(Path Abs Dir, Bool)] resolvePackageEntry menv projRoot pe = do entryRoot <- resolvePackageLocation menv projRoot (peLocation pe) paths <- case peSubdirs pe of [] -> return [entryRoot] subs -> mapM (resolveDir entryRoot) subs case peValidWanted pe of Nothing -> return () Just _ -> $logWarn "Warning: you are using the deprecated valid-wanted field. You should instead use extra-dep. See: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md#packages" return $ map (, not $ peExtraDep pe) paths -- | Resolve a PackageLocation into a path, downloading and cloning as -- necessary. resolvePackageLocation :: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m ,MonadBaseControl IO m) => EnvOverride -> Path Abs Dir -- ^ project root -> PackageLocation -> m (Path Abs Dir) resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp resolvePackageLocation _ projRoot (PLHttpTarball url) = do let name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 url root = projRoot workDirRel $(mkRelDir "downloaded") fileRel <- parseRelFile $ name ++ ".tar.gz" dirRel <- parseRelDir name dirRelTmp <- parseRelDir $ name ++ ".tmp" let file = root fileRel dir = root dirRel dirTmp = root dirRelTmp exists <- dirExists dir unless exists $ do req <- parseUrl $ T.unpack url _ <- download req file removeTreeIfExists dirTmp liftIO $ withBinaryFile (toFilePath file) ReadMode $ \h -> do lbs <- L.hGetContents h let entries = Tar.read $ GZip.decompress lbs Tar.unpack (toFilePath dirTmp) entries renameDir dirTmp dir x <- listDirectory dir case x of ([dir'], []) -> return dir' (dirs, files) -> do removeFileIfExists file removeTreeIfExists dir throwM $ UnexpectedTarballContents dirs files resolvePackageLocation menv projRoot (PLGit url commit) = do let name = T.unpack $ decodeUtf8 $ B16.encode $ SHA256.hash $ encodeUtf8 $ T.unwords [url, commit] root = projRoot workDirRel $(mkRelDir "downloaded") dirRel <- parseRelDir $ name ++ ".git" dirRelTmp <- parseRelDir $ name ++ ".git.tmp" let dir = root dirRel dirTmp = root dirRelTmp exists <- dirExists dir unless exists $ do removeTreeIfExists dirTmp createTree (parent dirTmp) readInNull (parent dirTmp) "git" menv [ "clone" , T.unpack url , toFilePath dirTmp ] Nothing readInNull dirTmp "git" menv [ "reset" , "--hard" , T.unpack commit ] Nothing renameDir dirTmp dir return dir -- | Get the stack root, e.g. ~/.stack determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir) determineStackRoot = do env <- liftIO getEnvironment case lookup stackRootEnvVar env of Nothing -> do x <- liftIO $ getAppUserDataDirectory stackProgName parseAbsDir x Just x -> do y <- liftIO $ do createDirectoryIfMissing True x canonicalizePath x parseAbsDir y -- | Determine the extra config file locations which exist. -- -- Returns most local first getExtraConfigs :: (MonadIO m, MonadLogger m) => Path Abs File -- ^ use config path -> m [Path Abs File] getExtraConfigs userConfigPath = do defaultStackGlobalConfigPath <- getDefaultGlobalConfigPath liftIO $ do env <- getEnvironment mstackConfig <- maybe (return Nothing) (fmap Just . parseAbsFile) $ lookup "STACK_CONFIG" env mstackGlobalConfig <- maybe (return Nothing) (fmap Just . parseAbsFile) $ lookup "STACK_GLOBAL_CONFIG" env filterM fileExists $ fromMaybe userConfigPath mstackConfig : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfigPath) -- | Load and parse YAML from the given file. loadYaml :: (FromJSON (a, [JSONWarning]), MonadIO m, MonadLogger m) => Path Abs File -> m a loadYaml path = do (result,warnings) <- liftIO $ Yaml.decodeFileEither (toFilePath path) >>= either (throwM . ParseConfigFileException path) return logJSONWarnings (toFilePath path) warnings return result -- | Get the location of the project config file, if it exists. getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) => Maybe (Path Abs File) -- ^ Override stack.yaml -> m (Maybe (Path Abs File)) getProjectConfig (Just stackYaml) = return $ Just stackYaml getProjectConfig Nothing = do env <- liftIO getEnvironment case lookup "STACK_YAML" env of Just fp -> do $logInfo "Getting project config file from STACK_YAML environment" liftM Just $ case parseAbsFile fp of Left _ -> do currDir <- getWorkingDir resolveFile currDir fp Right path -> return path Nothing -> do currDir <- getWorkingDir search currDir where search dir = do let fp = dir stackDotYaml fp' = toFilePath fp $logDebug $ "Checking for project config at: " <> T.pack fp' exists <- fileExists fp if exists then return $ Just fp else do let dir' = parent dir if dir == dir' -- fully traversed, give up then return Nothing else search dir' -- | Find the project config file location, respecting environment variables -- and otherwise traversing parents. If no config is found, we supply a default -- based on current directory. loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m) => Maybe (Path Abs File) -- ^ Override stack.yaml -> m (Maybe (Project, Path Abs File, ConfigMonoid)) loadProjectConfig mstackYaml = do mfp <- getProjectConfig mstackYaml case mfp of Just fp -> do currDir <- getWorkingDir $logDebug $ "Loading project config file " <> T.pack (maybe (toFilePath fp) toFilePath (stripDir currDir fp)) load fp Nothing -> do $logDebug $ "No project config file found, using defaults." return Nothing where load fp = do ProjectAndConfigMonoid project config <- loadYaml fp return $ Just (project, fp, config) -- | Get the location of the default stack configuration file. -- If a file already exists at the deprecated location, its location is returned. -- Otherwise, the new location is returned. getDefaultGlobalConfigPath :: (MonadIO m, MonadLogger m) => m (Maybe (Path Abs File)) getDefaultGlobalConfigPath = case (defaultGlobalConfigPath, defaultGlobalConfigPathDeprecated) of (Just new,Just old) -> liftM (Just . fst ) $ tryDeprecatedPath (Just "non-project global configuration file") fileExists new old (Just new,Nothing) -> return (Just new) _ -> return Nothing -- | Get the location of the default user configuration file. -- If a file already exists at the deprecated location, its location is returned. -- Otherwise, the new location is returned. getDefaultUserConfigPath :: (MonadIO m, MonadLogger m) => Path Abs Dir -> m (Path Abs File) getDefaultUserConfigPath stackRoot = do (path, exists) <- tryDeprecatedPath (Just "non-project configuration file") fileExists (defaultUserConfigPath stackRoot) (defaultUserConfigPathDeprecated stackRoot) unless exists $ do createTree (parent path) liftIO $ S.writeFile (toFilePath path) $ S.concat [ "# This file contains default non-project-specific settings for 'stack', used\n" , "# in all projects. For more information about stack's configuration, see\n" , "# https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md\n" , "#\n" , Yaml.encode (mempty :: Object) ] return path packagesParser :: Parser [String] packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))