{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
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
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)
configFromConfigMonoid
:: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env)
=> Path Abs Dir
-> Path Abs File
-> 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
(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 {..}
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
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
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")
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
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)
loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadThrow m,MonadBaseControl IO m,MonadReader env m,HasHttpManager env,HasTerminal env)
=> ConfigMonoid
-> Maybe (Path Abs File)
-> m (LoadConfig m)
loadConfig configArgs mstackYaml = do
stackRoot <- determineStackRoot
userConfigPath <- getDefaultUserConfigPath stackRoot
extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadYaml
let extraConfigs =
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
}
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
-> 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
}
resolvePackageEntry
:: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m
,MonadBaseControl IO m)
=> EnvOverride
-> Path Abs Dir
-> 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
resolvePackageLocation
:: (MonadIO m, MonadThrow m, MonadReader env m, HasHttpManager env, MonadLogger m, MonadCatch m
,MonadBaseControl IO m)
=> EnvOverride
-> Path Abs Dir
-> 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
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
getExtraConfigs :: (MonadIO m, MonadLogger m)
=> Path Abs File
-> 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)
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
getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
=> Maybe (Path Abs File)
-> 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'
then return Nothing
else search dir'
loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
=> Maybe (Path Abs File)
-> 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)
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
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"))