module Stack.Types.Config
(
HasPlatform(..)
,HasStackRoot(..)
,PlatformVariant(..)
,Config(..)
,HasConfig(..)
,askConfig
,askLatestSnapshotUrl
,explicitSetupDeps
,getMinimalEnvOverride
,BuildConfig(..)
,bcRoot
,bcWorkDir
,HasBuildConfig(..)
,GHCVariant(..)
,ghcVariantName
,ghcVariantSuffix
,parseGHCVariant
,HasGHCVariant(..)
,snapshotsDir
,EnvConfig(..)
,HasEnvConfig(..)
,getWhichCompiler
,ApplyGhcOptions(..)
,ConfigException(..)
,ConfigMonoid(..)
,EnvSettings(..)
,minimalEnvSettings
,GlobalOpts(..)
,GlobalOptsMonoid(..)
,defaultLogLevel
,LoadConfig(..)
,PackageEntry(..)
,peExtraDep
,PackageLocation(..)
,RemotePackageType(..)
,PackageIndex(..)
,IndexName(..)
,configPackageIndex
,configPackageIndexCache
,configPackageIndexGz
,configPackageIndexRoot
,configPackageTarball
,indexNameText
,IndexLocation(..)
,Project(..)
,ProjectAndConfigMonoid(..)
,PvpBounds(..)
,parsePvpBounds
,Resolver(..)
,parseResolverText
,resolverName
,AbstractResolver(..)
,SCM(..)
,bindirSuffix
,configInstalledCache
,configMiniBuildPlanCache
,configProjectWorkDir
,docDirSuffix
,flagCacheLocal
,extraBinDirs
,hpcReportDir
,installationRootDeps
,installationRootLocal
,packageDatabaseDeps
,packageDatabaseExtra
,packageDatabaseLocal
,platformOnlyRelDir
,platformGhcRelDir
,useShaPathOnWindows
,getWorkDir
,EvalOpts(..)
,ExecOpts(..)
,SpecialExecCmd(..)
,ExecOptsExtra(..)
,DownloadInfo(..)
,VersionedDownloadInfo(..)
,SetupInfo(..)
,SetupInfoLocation(..)
,DockerEntrypoint(..)
,DockerUser(..)
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Exception
import Control.Monad (liftM, mzero, forM)
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, object,
(.=), (..:), (..:?), (..!=), Value(String, Object),
withObjectWarnings, WarningParser, Object, jsonSubWarnings,
jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings)
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
import qualified Data.Map.Strict as M
import Data.Maybe
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Typeable
import Data.Yaml (ParseException)
import Distribution.System (Platform)
import qualified Distribution.Text
import Distribution.Version (anyVersion)
import Network.HTTP.Client (parseUrl)
import Path
import qualified Paths_stack as Meta
import Stack.Constants (stackRootEnvVar)
import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName)
import Stack.Types.Compiler
import Stack.Types.Docker
import Stack.Types.Nix
import Stack.Types.FlagName
import Stack.Types.Image
import Stack.Types.PackageIdentifier
import Stack.Types.PackageIndex
import Stack.Types.PackageName
import Stack.Types.TemplateName
import Stack.Types.Version
import System.PosixCompat.Types (UserID, GroupID, FileMode)
import System.Process.Read (EnvOverride)
#ifdef mingw32_HOST_OS
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString.Base16 as B16
#endif
data Config =
Config {configStackRoot :: !(Path Abs Dir)
,configWorkDir :: !(Path Rel Dir)
,configUserConfigPath :: !(Path Abs File)
,configDocker :: !DockerOpts
,configNix :: !NixOpts
,configEnvOverride :: !(EnvSettings -> IO EnvOverride)
,configLocalProgramsBase :: !(Path Abs Dir)
,configLocalPrograms :: !(Path Abs Dir)
,configConnectionCount :: !Int
,configHideTHLoading :: !Bool
,configPlatform :: !Platform
,configPlatformVariant :: !PlatformVariant
,configGHCVariant0 :: !(Maybe GHCVariant)
,configLatestSnapshotUrl :: !Text
,configPackageIndices :: ![PackageIndex]
,configSystemGHC :: !Bool
,configInstallGHC :: !Bool
,configSkipGHCCheck :: !Bool
,configSkipMsys :: !Bool
,configCompilerCheck :: !VersionCheck
,configLocalBin :: !(Path Abs Dir)
,configRequireStackVersion :: !VersionRange
,configJobs :: !Int
,configExtraIncludeDirs :: !(Set Text)
,configExtraLibDirs :: !(Set Text)
,configConfigMonoid :: !ConfigMonoid
,configConcurrentTests :: !Bool
,configImage :: !ImageOpts
,configTemplateParams :: !(Map Text Text)
,configScmInit :: !(Maybe SCM)
,configGhcOptions :: !(Map (Maybe PackageName) [Text])
,configSetupInfoLocations :: ![SetupInfoLocation]
,configPvpBounds :: !PvpBounds
,configModifyCodePage :: !Bool
,configExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)
,configRebuildGhcOptions :: !Bool
,configApplyGhcOptions :: !ApplyGhcOptions
,configAllowNewer :: !Bool
,configDefaultTemplate :: !(Maybe TemplateName)
,configAllowDifferentUser :: !Bool
}
data ApplyGhcOptions = AGOTargets
| AGOLocals
| AGOEverything
deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance FromJSON ApplyGhcOptions where
parseJSON = withText "ApplyGhcOptions" $ \t ->
case t of
"targets" -> return AGOTargets
"locals" -> return AGOLocals
"everything" -> return AGOEverything
_ -> fail $ "Invalid ApplyGhcOptions: " ++ show t
data PackageIndex = PackageIndex
{ indexName :: !IndexName
, indexLocation :: !IndexLocation
, indexDownloadPrefix :: !Text
, indexGpgVerify :: !Bool
, indexRequireHashes :: !Bool
}
deriving Show
instance FromJSON (WithJSONWarnings PackageIndex) where
parseJSON = withObjectWarnings "PackageIndex" $ \o -> do
name <- o ..: "name"
prefix <- o ..: "download-prefix"
mgit <- o ..:? "git"
mhttp <- o ..:? "http"
loc <-
case (mgit, mhttp) of
(Nothing, Nothing) -> fail $
"Must provide either Git or HTTP URL for " ++
T.unpack (indexNameText name)
(Just git, Nothing) -> return $ ILGit git
(Nothing, Just http) -> return $ ILHttp http
(Just git, Just http) -> return $ ILGitHttp git http
gpgVerify <- o ..:? "gpg-verify" ..!= False
reqHashes <- o ..:? "require-hashes" ..!= False
return PackageIndex
{ indexName = name
, indexLocation = loc
, indexDownloadPrefix = prefix
, indexGpgVerify = gpgVerify
, indexRequireHashes = reqHashes
}
newtype IndexName = IndexName { unIndexName :: ByteString }
deriving (Show, Eq, Ord, Hashable, Binary)
indexNameText :: IndexName -> Text
indexNameText = decodeUtf8 . unIndexName
instance ToJSON IndexName where
toJSON = toJSON . indexNameText
instance FromJSON IndexName where
parseJSON = withText "IndexName" $ \t ->
case parseRelDir (T.unpack t) of
Left e -> fail $ "Invalid index name: " ++ show e
Right _ -> return $ IndexName $ encodeUtf8 t
data IndexLocation = ILGit !Text | ILHttp !Text | ILGitHttp !Text !Text
deriving (Show, Eq, Ord)
data EnvSettings = EnvSettings
{ esIncludeLocals :: !Bool
, esIncludeGhcPackagePath :: !Bool
, esStackExe :: !Bool
, esLocaleUtf8 :: !Bool
}
deriving (Show, Eq, Ord)
data ExecOpts = ExecOpts
{ eoCmd :: !SpecialExecCmd
, eoArgs :: ![String]
, eoExtra :: !ExecOptsExtra
} deriving (Show)
data SpecialExecCmd
= ExecCmd String
| ExecGhc
| ExecRunGhc
deriving (Show, Eq)
data ExecOptsExtra
= ExecOptsPlain
| ExecOptsEmbellished
{ eoEnvSettings :: !EnvSettings
, eoPackages :: ![String]
}
deriving (Show)
data EvalOpts = EvalOpts
{ evalArg :: !String
, evalExtra :: !ExecOptsExtra
} deriving (Show)
data GlobalOpts = GlobalOpts
{ globalReExecVersion :: !(Maybe String)
, globalDockerEntrypoint :: !(Maybe DockerEntrypoint)
, globalLogLevel :: !LogLevel
, globalConfigMonoid :: !ConfigMonoid
, globalResolver :: !(Maybe AbstractResolver)
, globalCompiler :: !(Maybe CompilerVersion)
, globalTerminal :: !Bool
, globalStackYaml :: !(Maybe FilePath)
} deriving (Show)
data GlobalOptsMonoid = GlobalOptsMonoid
{ globalMonoidReExecVersion :: !(Maybe String)
, globalMonoidDockerEntrypoint :: !(Maybe DockerEntrypoint)
, globalMonoidLogLevel :: !(Maybe LogLevel)
, globalMonoidConfigMonoid :: !ConfigMonoid
, globalMonoidResolver :: !(Maybe AbstractResolver)
, globalMonoidCompiler :: !(Maybe CompilerVersion)
, globalMonoidTerminal :: !(Maybe Bool)
, globalMonoidStackYaml :: !(Maybe FilePath)
} deriving (Show)
instance Monoid GlobalOptsMonoid where
mempty = GlobalOptsMonoid Nothing Nothing Nothing mempty Nothing Nothing Nothing Nothing
mappend l r = GlobalOptsMonoid
{ globalMonoidReExecVersion = globalMonoidReExecVersion l <|> globalMonoidReExecVersion r
, globalMonoidDockerEntrypoint =
globalMonoidDockerEntrypoint l <|> globalMonoidDockerEntrypoint r
, globalMonoidLogLevel = globalMonoidLogLevel l <|> globalMonoidLogLevel r
, globalMonoidConfigMonoid = globalMonoidConfigMonoid l <> globalMonoidConfigMonoid r
, globalMonoidResolver = globalMonoidResolver l <|> globalMonoidResolver r
, globalMonoidCompiler = globalMonoidCompiler l <|> globalMonoidCompiler r
, globalMonoidTerminal = globalMonoidTerminal l <|> globalMonoidTerminal r
, globalMonoidStackYaml = globalMonoidStackYaml l <|> globalMonoidStackYaml r }
data AbstractResolver
= ARLatestNightly
| ARLatestLTS
| ARLatestLTSMajor !Int
| ARResolver !Resolver
| ARGlobal
deriving Show
defaultLogLevel :: LogLevel
defaultLogLevel = LevelInfo
data BuildConfig = BuildConfig
{ bcConfig :: !Config
, bcResolver :: !Resolver
, bcWantedCompiler :: !CompilerVersion
, bcPackageEntries :: ![PackageEntry]
, bcExtraDeps :: !(Map PackageName Version)
, bcExtraPackageDBs :: ![Path Abs Dir]
, bcStackYaml :: !(Path Abs File)
, bcFlags :: !(Map PackageName (Map FlagName Bool))
, bcImplicitGlobal :: !Bool
, bcGHCVariant :: !GHCVariant
, bcPackageCaches :: !(Map PackageIdentifier (PackageIndex, PackageCache))
}
bcRoot :: BuildConfig -> Path Abs Dir
bcRoot = parent . bcStackYaml
bcWorkDir :: (MonadReader env m, HasConfig env) => BuildConfig -> m (Path Abs Dir)
bcWorkDir bconfig = do
workDir <- getWorkDir
return (bcRoot bconfig </> workDir)
data EnvConfig = EnvConfig
{envConfigBuildConfig :: !BuildConfig
,envConfigCabalVersion :: !Version
,envConfigCompilerVersion :: !CompilerVersion
,envConfigPackages :: !(Map (Path Abs Dir) Bool)}
instance HasBuildConfig EnvConfig where
getBuildConfig = envConfigBuildConfig
instance HasConfig EnvConfig
instance HasPlatform EnvConfig
instance HasGHCVariant EnvConfig
instance HasStackRoot EnvConfig
class (HasBuildConfig r, HasGHCVariant r) => HasEnvConfig r where
getEnvConfig :: r -> EnvConfig
instance HasEnvConfig EnvConfig where
getEnvConfig = id
data LoadConfig m = LoadConfig
{ lcConfig :: !Config
, lcLoadBuildConfig :: !(Maybe CompilerVersion -> m BuildConfig)
, lcProjectRoot :: !(Maybe (Path Abs Dir))
}
data PackageEntry = PackageEntry
{ peExtraDepMaybe :: !(Maybe Bool)
, peValidWanted :: !(Maybe Bool)
, peLocation :: !PackageLocation
, peSubdirs :: ![FilePath]
}
deriving Show
peExtraDep :: PackageEntry -> Bool
peExtraDep pe =
case peExtraDepMaybe pe of
Just x -> x
Nothing ->
case peValidWanted pe of
Just x -> not x
Nothing -> False
instance ToJSON PackageEntry where
toJSON pe | not (peExtraDep pe) && null (peSubdirs pe) =
toJSON $ peLocation pe
toJSON pe = object
[ "extra-dep" .= peExtraDep pe
, "location" .= peLocation pe
, "subdirs" .= peSubdirs pe
]
instance FromJSON (WithJSONWarnings PackageEntry) where
parseJSON (String t) = do
WithJSONWarnings loc _ <- parseJSON $ String t
return $ noJSONWarnings
(PackageEntry
{ peExtraDepMaybe = Nothing
, peValidWanted = Nothing
, peLocation = loc
, peSubdirs = []
})
parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry
<$> o ..:? "extra-dep"
<*> o ..:? "valid-wanted"
<*> jsonSubWarnings (o ..: "location")
<*> o ..:? "subdirs" ..!= []) v
data PackageLocation
= PLFilePath FilePath
| PLRemote Text RemotePackageType
deriving Show
data RemotePackageType
= RPTHttp
| RPTGit Text
| RPTHg Text
deriving Show
instance ToJSON PackageLocation where
toJSON (PLFilePath fp) = toJSON fp
toJSON (PLRemote t RPTHttp) = toJSON t
toJSON (PLRemote x (RPTGit y)) = toJSON $ T.unwords ["git", x, y]
toJSON (PLRemote x (RPTHg y)) = toJSON $ T.unwords ["hg", x, y]
instance FromJSON (WithJSONWarnings PackageLocation) where
parseJSON v
= (noJSONWarnings <$> withText "PackageLocation" (\t -> http t <|> file t) v)
<|> git v
<|> hg v
where
file t = pure $ PLFilePath $ T.unpack t
http t =
case parseUrl $ T.unpack t of
Left _ -> mzero
Right _ -> return $ PLRemote t RPTHttp
git = withObjectWarnings "PackageGitLocation" $ \o -> PLRemote
<$> o ..: "git"
<*> (RPTGit <$> o ..: "commit")
hg = withObjectWarnings "PackageHgLocation" $ \o -> PLRemote
<$> o ..: "hg"
<*> (RPTHg <$> o ..: "commit")
data Project = Project
{ projectUserMsg :: !(Maybe String)
, projectPackages :: ![PackageEntry]
, projectExtraDeps :: !(Map PackageName Version)
, projectFlags :: !(Map PackageName (Map FlagName Bool))
, projectResolver :: !Resolver
, projectCompiler :: !(Maybe CompilerVersion)
, projectExtraPackageDBs :: ![FilePath]
}
deriving Show
instance ToJSON Project where
toJSON p = object $
(maybe id (\cv -> (("compiler" .= cv) :)) (projectCompiler p))
((maybe id (\msg -> (("user-message" .= msg) :)) (projectUserMsg p))
[ "packages" .= projectPackages p
, "extra-deps" .= map fromTuple (Map.toList $ projectExtraDeps p)
, "flags" .= projectFlags p
, "resolver" .= projectResolver p
, "extra-package-dbs" .= projectExtraPackageDBs p
])
data Resolver
= ResolverSnapshot SnapName
| ResolverCompiler !CompilerVersion
| ResolverCustom !Text !Text
deriving (Show)
instance ToJSON Resolver where
toJSON (ResolverCustom name location) = object
[ "name" .= name
, "location" .= location
]
toJSON x = toJSON $ resolverName x
instance FromJSON (WithJSONWarnings Resolver) where
parseJSON v@(Object _) = withObjectWarnings "Resolver" (\o -> ResolverCustom
<$> o ..: "name"
<*> o ..: "location") v
parseJSON (String t) = either (fail . show) return (noJSONWarnings <$> parseResolverText t)
parseJSON _ = fail $ "Invalid Resolver, must be Object or String"
resolverName :: Resolver -> Text
resolverName (ResolverSnapshot name) = renderSnapName name
resolverName (ResolverCompiler v) = compilerVersionText v
resolverName (ResolverCustom name _) = "custom-" <> name
parseResolverText :: MonadThrow m => Text -> m Resolver
parseResolverText t
| Right x <- parseSnapName t = return $ ResolverSnapshot x
| Just v <- parseCompilerVersion t = return $ ResolverCompiler v
| otherwise = throwM $ ParseResolverException t
class HasStackRoot env where
getStackRoot :: env -> Path Abs Dir
default getStackRoot :: HasConfig env => env -> Path Abs Dir
getStackRoot = configStackRoot . getConfig
class HasPlatform env where
getPlatform :: env -> Platform
default getPlatform :: HasConfig env => env -> Platform
getPlatform = configPlatform . getConfig
getPlatformVariant :: env -> PlatformVariant
default getPlatformVariant :: HasConfig env => env -> PlatformVariant
getPlatformVariant = configPlatformVariant . getConfig
instance HasPlatform (Platform,PlatformVariant) where
getPlatform (p,_) = p
getPlatformVariant (_,v) = v
class HasGHCVariant env where
getGHCVariant :: env -> GHCVariant
default getGHCVariant :: HasBuildConfig env => env -> GHCVariant
getGHCVariant = bcGHCVariant . getBuildConfig
instance HasGHCVariant GHCVariant where
getGHCVariant = id
class (HasStackRoot env, HasPlatform env) => HasConfig env where
getConfig :: env -> Config
default getConfig :: HasBuildConfig env => env -> Config
getConfig = bcConfig . getBuildConfig
instance HasStackRoot Config
instance HasPlatform Config
instance HasConfig Config where
getConfig = id
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
data ConfigMonoid =
ConfigMonoid
{ configMonoidWorkDir :: !(Maybe FilePath)
, configMonoidDockerOpts :: !DockerOptsMonoid
, configMonoidNixOpts :: !NixOptsMonoid
, configMonoidConnectionCount :: !(Maybe Int)
, configMonoidHideTHLoading :: !(Maybe Bool)
, configMonoidLatestSnapshotUrl :: !(Maybe Text)
, configMonoidPackageIndices :: !(Maybe [PackageIndex])
, configMonoidSystemGHC :: !(Maybe Bool)
,configMonoidInstallGHC :: !(Maybe Bool)
,configMonoidSkipGHCCheck :: !(Maybe Bool)
,configMonoidSkipMsys :: !(Maybe Bool)
,configMonoidCompilerCheck :: !(Maybe VersionCheck)
,configMonoidRequireStackVersion :: !VersionRange
,configMonoidOS :: !(Maybe String)
,configMonoidArch :: !(Maybe String)
,configMonoidGHCVariant :: !(Maybe GHCVariant)
,configMonoidJobs :: !(Maybe Int)
,configMonoidExtraIncludeDirs :: !(Set Text)
,configMonoidExtraLibDirs :: !(Set Text)
,configMonoidConcurrentTests :: !(Maybe Bool)
,configMonoidLocalBinPath :: !(Maybe FilePath)
,configMonoidImageOpts :: !ImageOptsMonoid
,configMonoidTemplateParameters :: !(Map Text Text)
,configMonoidScmInit :: !(Maybe SCM)
,configMonoidGhcOptions :: !(Map (Maybe PackageName) [Text])
,configMonoidExtraPath :: ![Path Abs Dir]
,configMonoidSetupInfoLocations :: ![SetupInfoLocation]
,configMonoidPvpBounds :: !(Maybe PvpBounds)
,configMonoidModifyCodePage :: !(Maybe Bool)
,configMonoidExplicitSetupDeps :: !(Map (Maybe PackageName) Bool)
,configMonoidRebuildGhcOptions :: !(Maybe Bool)
,configMonoidApplyGhcOptions :: !(Maybe ApplyGhcOptions)
,configMonoidAllowNewer :: !(Maybe Bool)
,configMonoidDefaultTemplate :: !(Maybe TemplateName)
, configMonoidAllowDifferentUser :: !(Maybe Bool)
}
deriving Show
instance Monoid ConfigMonoid where
mempty = ConfigMonoid
{ configMonoidWorkDir = Nothing
, configMonoidDockerOpts = mempty
, configMonoidNixOpts = mempty
, configMonoidConnectionCount = Nothing
, configMonoidHideTHLoading = Nothing
, configMonoidLatestSnapshotUrl = Nothing
, configMonoidPackageIndices = Nothing
, configMonoidSystemGHC = Nothing
, configMonoidInstallGHC = Nothing
, configMonoidSkipGHCCheck = Nothing
, configMonoidSkipMsys = Nothing
, configMonoidRequireStackVersion = anyVersion
, configMonoidOS = Nothing
, configMonoidArch = Nothing
, configMonoidGHCVariant = Nothing
, configMonoidJobs = Nothing
, configMonoidExtraIncludeDirs = Set.empty
, configMonoidExtraLibDirs = Set.empty
, configMonoidConcurrentTests = Nothing
, configMonoidLocalBinPath = Nothing
, configMonoidImageOpts = mempty
, configMonoidTemplateParameters = mempty
, configMonoidScmInit = Nothing
, configMonoidCompilerCheck = Nothing
, configMonoidGhcOptions = mempty
, configMonoidExtraPath = []
, configMonoidSetupInfoLocations = mempty
, configMonoidPvpBounds = Nothing
, configMonoidModifyCodePage = Nothing
, configMonoidExplicitSetupDeps = mempty
, configMonoidRebuildGhcOptions = Nothing
, configMonoidApplyGhcOptions = Nothing
, configMonoidAllowNewer = Nothing
, configMonoidDefaultTemplate = Nothing
, configMonoidAllowDifferentUser = Nothing
}
mappend l r = ConfigMonoid
{ configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r
, configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
, configMonoidNixOpts = configMonoidNixOpts l <> configMonoidNixOpts r
, configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r
, configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r
, configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r
, configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r
, configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r
, configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r
, configMonoidSkipGHCCheck = configMonoidSkipGHCCheck l <|> configMonoidSkipGHCCheck r
, configMonoidSkipMsys = configMonoidSkipMsys l <|> configMonoidSkipMsys r
, configMonoidRequireStackVersion = intersectVersionRanges (configMonoidRequireStackVersion l)
(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)
, configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r
, configMonoidLocalBinPath = configMonoidLocalBinPath l <|> configMonoidLocalBinPath r
, configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r
, configMonoidTemplateParameters = configMonoidTemplateParameters l <> configMonoidTemplateParameters r
, configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r
, configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r
, configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r)
, configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r
, configMonoidSetupInfoLocations = configMonoidSetupInfoLocations l ++ configMonoidSetupInfoLocations r
, configMonoidPvpBounds = configMonoidPvpBounds l <|> configMonoidPvpBounds r
, configMonoidModifyCodePage = configMonoidModifyCodePage l <|> configMonoidModifyCodePage r
, configMonoidExplicitSetupDeps = configMonoidExplicitSetupDeps l <> configMonoidExplicitSetupDeps r
, configMonoidRebuildGhcOptions = configMonoidRebuildGhcOptions l <|> configMonoidRebuildGhcOptions r
, configMonoidApplyGhcOptions = configMonoidApplyGhcOptions l <|> configMonoidApplyGhcOptions r
, configMonoidAllowNewer = configMonoidAllowNewer l <|> configMonoidAllowNewer r
, configMonoidDefaultTemplate = configMonoidDefaultTemplate l <|> configMonoidDefaultTemplate r
, configMonoidAllowDifferentUser = configMonoidAllowDifferentUser l <|> configMonoidAllowDifferentUser r
}
instance FromJSON (WithJSONWarnings ConfigMonoid) where
parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON
parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid
parseConfigMonoidJSON obj = do
configMonoidWorkDir <- obj ..:? configMonoidWorkDirName
configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty)
configMonoidNixOpts <- jsonSubWarnings (obj ..:? configMonoidNixOptsName ..!= mempty)
configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName
configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName
configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName
configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName)
configMonoidSystemGHC <- obj ..:? configMonoidSystemGHCName
configMonoidInstallGHC <- obj ..:? configMonoidInstallGHCName
configMonoidSkipGHCCheck <- obj ..:? configMonoidSkipGHCCheckName
configMonoidSkipMsys <- obj ..:? configMonoidSkipMsysName
configMonoidRequireStackVersion <- unVersionRangeJSON <$>
obj ..:? configMonoidRequireStackVersionName
..!= VersionRangeJSON anyVersion
configMonoidOS <- obj ..:? configMonoidOSName
configMonoidArch <- obj ..:? configMonoidArchName
configMonoidGHCVariant <- obj ..:? configMonoidGHCVariantName
configMonoidJobs <- obj ..:? configMonoidJobsName
configMonoidExtraIncludeDirs <- obj ..:? configMonoidExtraIncludeDirsName ..!= Set.empty
configMonoidExtraLibDirs <- obj ..:? configMonoidExtraLibDirsName ..!= Set.empty
configMonoidConcurrentTests <- obj ..:? configMonoidConcurrentTestsName
configMonoidLocalBinPath <- obj ..:? configMonoidLocalBinPathName
configMonoidImageOpts <- jsonSubWarnings (obj ..:? configMonoidImageOptsName ..!= mempty)
templates <- obj ..:? "templates"
(configMonoidScmInit,configMonoidTemplateParameters) <-
case templates of
Nothing -> return (Nothing,M.empty)
Just tobj -> do
scmInit <- tobj ..:? configMonoidScmInitName
params <- tobj ..:? configMonoidTemplateParametersName
return (scmInit,fromMaybe M.empty params)
configMonoidCompilerCheck <- obj ..:? configMonoidCompilerCheckName
mghcoptions <- obj ..:? configMonoidGhcOptionsName
configMonoidGhcOptions <-
case mghcoptions of
Nothing -> return mempty
Just m -> fmap Map.fromList $ mapM handleGhcOptions $ Map.toList m
extraPath <- obj ..:? configMonoidExtraPathName ..!= []
configMonoidExtraPath <- forM extraPath $
either (fail . show) return . parseAbsDir . T.unpack
configMonoidSetupInfoLocations <-
maybeToList <$> jsonSubWarningsT (obj ..:? configMonoidSetupInfoLocationsName)
configMonoidPvpBounds <- obj ..:? configMonoidPvpBoundsName
configMonoidModifyCodePage <- obj ..:? configMonoidModifyCodePageName
configMonoidExplicitSetupDeps <-
(obj ..:? configMonoidExplicitSetupDepsName ..!= mempty)
>>= fmap Map.fromList . mapM handleExplicitSetupDep . Map.toList
configMonoidRebuildGhcOptions <- obj ..:? configMonoidRebuildGhcOptionsName
configMonoidApplyGhcOptions <- obj ..:? configMonoidApplyGhcOptionsName
configMonoidAllowNewer <- obj ..:? configMonoidAllowNewerName
configMonoidDefaultTemplate <- obj ..:? configMonoidDefaultTemplateName
configMonoidAllowDifferentUser <- obj ..:? configMonoidAllowDifferentUserName
return ConfigMonoid {..}
where
handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text])
handleGhcOptions (name', vals') = do
name <-
if name' == "*"
then return Nothing
else case parsePackageNameFromString $ T.unpack name' of
Left e -> fail $ show e
Right x -> return $ Just x
case parseArgs Escaping vals' of
Left e -> fail e
Right vals -> return (name, map T.pack vals)
handleExplicitSetupDep :: Monad m => (Text, Bool) -> m (Maybe PackageName, Bool)
handleExplicitSetupDep (name', b) = do
name <-
if name' == "*"
then return Nothing
else case parsePackageNameFromString $ T.unpack name' of
Left e -> fail $ show e
Right x -> return $ Just x
return (name, b)
configMonoidWorkDirName :: Text
configMonoidWorkDirName = "work-dir"
configMonoidDockerOptsName :: Text
configMonoidDockerOptsName = "docker"
configMonoidNixOptsName :: Text
configMonoidNixOptsName = "nix"
configMonoidConnectionCountName :: Text
configMonoidConnectionCountName = "connection-count"
configMonoidHideTHLoadingName :: Text
configMonoidHideTHLoadingName = "hide-th-loading"
configMonoidLatestSnapshotUrlName :: Text
configMonoidLatestSnapshotUrlName = "latest-snapshot-url"
configMonoidPackageIndicesName :: Text
configMonoidPackageIndicesName = "package-indices"
configMonoidSystemGHCName :: Text
configMonoidSystemGHCName = "system-ghc"
configMonoidInstallGHCName :: Text
configMonoidInstallGHCName = "install-ghc"
configMonoidSkipGHCCheckName :: Text
configMonoidSkipGHCCheckName = "skip-ghc-check"
configMonoidSkipMsysName :: Text
configMonoidSkipMsysName = "skip-msys"
configMonoidRequireStackVersionName :: Text
configMonoidRequireStackVersionName = "require-stack-version"
configMonoidOSName :: Text
configMonoidOSName = "os"
configMonoidArchName :: Text
configMonoidArchName = "arch"
configMonoidGHCVariantName :: Text
configMonoidGHCVariantName = "ghc-variant"
configMonoidJobsName :: Text
configMonoidJobsName = "jobs"
configMonoidExtraIncludeDirsName :: Text
configMonoidExtraIncludeDirsName = "extra-include-dirs"
configMonoidExtraLibDirsName :: Text
configMonoidExtraLibDirsName = "extra-lib-dirs"
configMonoidConcurrentTestsName :: Text
configMonoidConcurrentTestsName = "concurrent-tests"
configMonoidLocalBinPathName :: Text
configMonoidLocalBinPathName = "local-bin-path"
configMonoidImageOptsName :: Text
configMonoidImageOptsName = "image"
configMonoidScmInitName :: Text
configMonoidScmInitName = "scm-init"
configMonoidTemplateParametersName :: Text
configMonoidTemplateParametersName = "params"
configMonoidCompilerCheckName :: Text
configMonoidCompilerCheckName = "compiler-check"
configMonoidGhcOptionsName :: Text
configMonoidGhcOptionsName = "ghc-options"
configMonoidExtraPathName :: Text
configMonoidExtraPathName = "extra-path"
configMonoidSetupInfoLocationsName :: Text
configMonoidSetupInfoLocationsName = "setup-info"
configMonoidPvpBoundsName :: Text
configMonoidPvpBoundsName = "pvp-bounds"
configMonoidModifyCodePageName :: Text
configMonoidModifyCodePageName = "modify-code-page"
configMonoidExplicitSetupDepsName :: Text
configMonoidExplicitSetupDepsName = "explicit-setup-deps"
configMonoidRebuildGhcOptionsName :: Text
configMonoidRebuildGhcOptionsName = "rebuild-ghc-options"
configMonoidApplyGhcOptionsName :: Text
configMonoidApplyGhcOptionsName = "apply-ghc-options"
configMonoidAllowNewerName :: Text
configMonoidAllowNewerName = "allow-newer"
configMonoidDefaultTemplateName :: Text
configMonoidDefaultTemplateName = "default-template"
configMonoidAllowDifferentUserName :: Text
configMonoidAllowDifferentUserName = "allow-different-user"
data ConfigException
= ParseConfigFileException (Path Abs File) ParseException
| ParseResolverException Text
| NoProjectConfigFound (Path Abs Dir) (Maybe Text)
| UnexpectedArchiveContents [Path Abs Dir] [Path Abs File]
| UnableToExtractArchive Text (Path Abs File)
| BadStackVersionException VersionRange
| NoMatchingSnapshot [SnapName]
| ResolverMismatch Resolver String
| ResolverPartial Resolver String
| NoSuchDirectory FilePath
| ParseGHCVariantException String
| BadStackRootEnvVar (Path Abs Dir)
| Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir)
| UserDoesn'tOwnDirectory (Path Abs Dir)
deriving Typeable
instance Show ConfigException where
show (ParseConfigFileException configFile exception) = concat
[ "Could not parse '"
, toFilePath configFile
, "':\n"
, show exception
, "\nSee http://docs.haskellstack.org/en/stable/yaml_configuration/."
]
show (ParseResolverException t) = concat
[ "Invalid resolver value: "
, T.unpack t
, ". Possible valid values include lts-2.12, nightly-YYYY-MM-DD, ghc-7.10.2, and ghcjs-0.1.0_ghc-7.10.2. "
, "See https://www.stackage.org/snapshots for a complete list."
]
show (NoProjectConfigFound dir mcmd) = concat
[ "Unable to find a stack.yaml file in the current directory ("
, toFilePath dir
, ") or its ancestors"
, case mcmd of
Nothing -> ""
Just cmd -> "\nRecommended action: stack " ++ T.unpack cmd
]
show (UnexpectedArchiveContents dirs files) = concat
[ "When unpacking an archive specified in your stack.yaml file, "
, "did not find expected contents. Expected: a single directory. Found: "
, show ( map (toFilePath . dirname) dirs
, map (toFilePath . filename) files
)
]
show (UnableToExtractArchive url file) = concat
[ "Archive extraction failed. We support tarballs and zip, couldn't handle the following URL, "
, T.unpack url, " downloaded to the file ", toFilePath $ filename file
]
show (BadStackVersionException requiredRange) = concat
[ "The version of stack you are using ("
, show (fromCabalVersion Meta.version)
, ") is outside the required\n"
,"version range specified in stack.yaml ("
, T.unpack (versionRangeText requiredRange)
, ")." ]
show (NoMatchingSnapshot names) = concat
[ "None of the following snapshots provides a compiler matching "
, "your package(s):\n"
, unlines $ map (\name -> " - " <> T.unpack (renderSnapName name))
names
, "\nYou can try the following options:\n"
, " - Use '--omit-packages to exclude mismatching package(s).\n"
, " - Use '--resolver' to specify a matching snapshot/resolver\n"
]
show (ResolverMismatch resolver errDesc) = concat
[ "Resolver '"
, T.unpack (resolverName resolver)
, "' does not have a matching compiler to build some or all of your "
, "package(s).\n"
, errDesc
, "\nHowever, you can try '--omit-packages to exclude mismatching "
, "package(s)."
]
show (ResolverPartial resolver errDesc) = concat
[ "Resolver '"
, T.unpack (resolverName resolver)
, "' does not have all the packages to match your requirements.\n"
, unlines $ fmap (" " <>) (lines errDesc)
, "\nHowever, you can try '--solver' to use external packages."
]
show (NoSuchDirectory dir) = concat
["No directory could be located matching the supplied path: "
,dir
]
show (ParseGHCVariantException v) = concat
[ "Invalid ghc-variant value: "
, v
]
show (BadStackRootEnvVar envStackRoot) = concat
[ "Invalid $"
, stackRootEnvVar
, ": '"
, toFilePath envStackRoot
, "'. Please provide a valid absolute path."
]
show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat
[ "Preventing creation of $"
, stackRootEnvVar
, " '"
, toFilePath envStackRoot
, "'. Parent directory '"
, toFilePath parentDir
, "' is owned by someone else."
]
show (UserDoesn'tOwnDirectory dir) = concat
[ "You are not the owner of '"
, toFilePath dir
, "'. Aborting to protect file permissions."
, "\nRetry with '--"
, T.unpack configMonoidAllowDifferentUserName
, "' to disable this precaution."
]
instance Exception ConfigException
askConfig :: (MonadReader env m, HasConfig env) => m Config
askConfig = liftM getConfig ask
askLatestSnapshotUrl :: (MonadReader env m, HasConfig env) => m Text
askLatestSnapshotUrl = asks (configLatestSnapshotUrl . getConfig)
configPackageIndexRoot :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs Dir)
configPackageIndexRoot (IndexName name) = do
config <- asks getConfig
dir <- parseRelDir $ S8.unpack name
return (configStackRoot config </> $(mkRelDir "indices") </> dir)
configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexCache = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot
configPackageIndex :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndex = liftM (</> $(mkRelFile "00-index.tar")) . configPackageIndexRoot
configPackageIndexGz :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
configPackageIndexGz = liftM (</> $(mkRelFile "00-index.tar.gz")) . configPackageIndexRoot
configPackageTarball :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> PackageIdentifier -> m (Path Abs File)
configPackageTarball iname ident = do
root <- configPackageIndexRoot iname
name <- parseRelDir $ packageNameString $ packageIdentifierName ident
ver <- parseRelDir $ versionString $ packageIdentifierVersion ident
base <- parseRelFile $ packageIdentifierString ident ++ ".tar.gz"
return (root </> $(mkRelDir "packages") </> name </> ver </> base)
getWorkDir :: (MonadReader env m, HasConfig env) => m (Path Rel Dir)
getWorkDir = configWorkDir `liftM` asks getConfig
configProjectWorkDir :: (HasBuildConfig env, MonadReader env m) => m (Path Abs Dir)
configProjectWorkDir = do
bc <- asks getBuildConfig
workDir <- getWorkDir
return (bcRoot bc </> workDir)
configInstalledCache :: (HasBuildConfig env, MonadReader env m) => m (Path Abs File)
configInstalledCache = liftM (</> $(mkRelFile "installed-cache.bin")) configProjectWorkDir
platformOnlyRelDir
:: (MonadReader env m, HasPlatform env, MonadThrow m)
=> m (Path Rel Dir)
platformOnlyRelDir = do
platform <- asks getPlatform
platformVariant <- asks getPlatformVariant
parseRelDir (Distribution.Text.display platform ++ platformVariantSuffix platformVariant)
snapshotsDir :: (MonadReader env m, HasConfig env, HasGHCVariant env, MonadThrow m) => m (Path Abs Dir)
snapshotsDir = do
config <- asks getConfig
platform <- platformGhcRelDir
return $ configStackRoot config </> $(mkRelDir "snapshots") </> platform
installationRootDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
installationRootDeps = do
config <- asks getConfig
psc <- platformSnapAndCompilerRel
return $ configStackRoot config </> $(mkRelDir "snapshots") </> psc
installationRootLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
installationRootLocal = do
bc <- asks getBuildConfig
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
return $ configProjectWorkDir bc </> $(mkRelDir "install") </> psc
platformSnapAndCompilerRel
:: (MonadReader env m, HasPlatform env, HasEnvConfig env, MonadThrow m)
=> m (Path Rel Dir)
platformSnapAndCompilerRel = do
bc <- asks getBuildConfig
platform <- platformGhcRelDir
name <- parseRelDir $ T.unpack $ resolverName $ bcResolver bc
ghc <- compilerVersionDir
useShaPathOnWindows (platform </> name </> ghc)
platformGhcRelDir
:: (MonadReader env m, HasPlatform env, HasGHCVariant env, MonadThrow m)
=> m (Path Rel Dir)
platformGhcRelDir = do
platform <- asks getPlatform
platformVariant <- asks getPlatformVariant
ghcVariant <- asks getGHCVariant
parseRelDir (mconcat [ Distribution.Text.display platform
, platformVariantSuffix platformVariant
, ghcVariantSuffix ghcVariant ])
useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir)
useShaPathOnWindows =
#ifdef mingw32_HOST_OS
parseRelDir . S8.unpack . S8.take 8 . B16.encode . SHA1.hash . encodeUtf8 . T.pack . toFilePath
#else
return
#endif
compilerVersionDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Rel Dir)
compilerVersionDir = do
compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)
parseRelDir $ case compilerVersion of
GhcVersion version -> versionString version
GhcjsVersion {} -> compilerVersionString compilerVersion
packageDatabaseDeps :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
packageDatabaseDeps = do
root <- installationRootDeps
return $ root </> $(mkRelDir "pkgdb")
packageDatabaseLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
packageDatabaseLocal = do
root <- installationRootLocal
return $ root </> $(mkRelDir "pkgdb")
packageDatabaseExtra :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m [Path Abs Dir]
packageDatabaseExtra = do
bc <- asks getBuildConfig
return $ bcExtraPackageDBs bc
flagCacheLocal :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
flagCacheLocal = do
root <- installationRootLocal
return $ root </> $(mkRelDir "flag-cache")
configMiniBuildPlanCache :: (MonadThrow m, MonadReader env m, HasConfig env, HasGHCVariant env)
=> SnapName
-> m (Path Abs File)
configMiniBuildPlanCache name = do
root <- asks getStackRoot
platform <- platformGhcRelDir
file <- parseRelFile $ T.unpack (renderSnapName name) ++ ".cache"
return (root </> $(mkRelDir "build-plan-cache") </> platform </> file)
bindirSuffix :: Path Rel Dir
bindirSuffix = $(mkRelDir "bin")
docDirSuffix :: Path Rel Dir
docDirSuffix = $(mkRelDir "doc")
hpcReportDir :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> m (Path Abs Dir)
hpcReportDir = do
root <- installationRootLocal
return $ root </> $(mkRelDir "hpc")
extraBinDirs :: (MonadThrow m, MonadReader env m, HasEnvConfig env)
=> m (Bool -> [Path Abs Dir])
extraBinDirs = do
deps <- installationRootDeps
local <- installationRootLocal
return $ \locals -> if locals
then [local </> bindirSuffix, deps </> bindirSuffix]
else [deps </> bindirSuffix]
getMinimalEnvOverride :: (MonadReader env m, HasConfig env, MonadIO m) => m EnvOverride
getMinimalEnvOverride = do
config <- asks getConfig
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)
data ProjectAndConfigMonoid
= ProjectAndConfigMonoid !Project !ConfigMonoid
instance FromJSON (WithJSONWarnings ProjectAndConfigMonoid) where
parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do
dirs <- jsonSubWarningsTT (o ..:? "packages") ..!= [packageEntryCurrDir]
extraDeps' <- o ..:? "extra-deps" ..!= []
extraDeps <-
case partitionEithers $ goDeps extraDeps' of
([], x) -> return $ Map.fromList x
(errs, _) -> fail $ unlines errs
flags <- o ..:? "flags" ..!= mempty
resolver <- jsonSubWarnings (o ..: "resolver")
compiler <- o ..:? "compiler"
msg <- o ..:? "user-message"
config <- parseConfigMonoidJSON o
extraPackageDBs <- o ..:? "extra-package-dbs" ..!= []
let project = Project
{ projectUserMsg = msg
, projectPackages = dirs
, projectExtraDeps = extraDeps
, projectFlags = flags
, projectResolver = resolver
, projectCompiler = compiler
, projectExtraPackageDBs = extraPackageDBs
}
return $ ProjectAndConfigMonoid project config
where
goDeps =
map toSingle . Map.toList . Map.unionsWith Set.union . map toMap
where
toMap i = Map.singleton
(packageIdentifierName i)
(Set.singleton (packageIdentifierVersion i))
toSingle (k, s) =
case Set.toList s of
[x] -> Right (k, x)
xs -> Left $ concat
[ "Multiple versions for package "
, packageNameString k
, ": "
, unwords $ map versionString xs
]
packageEntryCurrDir :: PackageEntry
packageEntryCurrDir = PackageEntry
{ peValidWanted = Nothing
, peExtraDepMaybe = Nothing
, peLocation = PLFilePath "."
, peSubdirs = []
}
data SCM = Git
deriving (Show)
instance FromJSON SCM where
parseJSON v = do
s <- parseJSON v
case s of
"git" -> return Git
_ -> fail ("Unknown or unsupported SCM: " <> s)
instance ToJSON SCM where
toJSON Git = toJSON ("git" :: Text)
data PlatformVariant = PlatformVariantNone
| PlatformVariant String
platformVariantSuffix :: PlatformVariant -> String
platformVariantSuffix PlatformVariantNone = ""
platformVariantSuffix (PlatformVariant v) = "-" ++ v
data GHCVariant
= GHCStandard
| GHCGMP4
| GHCArch
| GHCIntegerSimple
| GHCCustom String
deriving (Show)
instance FromJSON GHCVariant where
parseJSON =
withText
"GHCVariant"
(either (fail . show) return . parseGHCVariant . T.unpack)
ghcVariantName :: GHCVariant -> String
ghcVariantName GHCStandard = "standard"
ghcVariantName GHCGMP4 = "gmp4"
ghcVariantName GHCArch = "arch"
ghcVariantName GHCIntegerSimple = "integersimple"
ghcVariantName (GHCCustom name) = "custom-" ++ name
ghcVariantSuffix :: GHCVariant -> String
ghcVariantSuffix GHCStandard = ""
ghcVariantSuffix v = "-" ++ ghcVariantName v
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 == "arch" -> return GHCArch
| s == "integersimple" -> return GHCIntegerSimple
| otherwise -> return (GHCCustom s)
data DownloadInfo = DownloadInfo
{ downloadInfoUrl :: Text
, downloadInfoContentLength :: Maybe Int
, downloadInfoSha1 :: Maybe ByteString
} deriving (Show)
instance FromJSON (WithJSONWarnings DownloadInfo) where
parseJSON = withObjectWarnings "DownloadInfo" parseDownloadInfoFromObject
parseDownloadInfoFromObject :: Object -> WarningParser DownloadInfo
parseDownloadInfoFromObject o = do
url <- o ..: "url"
contentLength <- o ..:? "content-length"
sha1TextMay <- o ..:? "sha1"
return
DownloadInfo
{ downloadInfoUrl = url
, downloadInfoContentLength = contentLength
, downloadInfoSha1 = fmap encodeUtf8 sha1TextMay
}
data VersionedDownloadInfo = VersionedDownloadInfo
{ vdiVersion :: Version
, vdiDownloadInfo :: DownloadInfo
}
deriving Show
instance FromJSON (WithJSONWarnings VersionedDownloadInfo) 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)
, siGHCJSs :: Map Text (Map CompilerVersion DownloadInfo)
, siStack :: Map Text (Map Version DownloadInfo)
}
deriving Show
instance FromJSON (WithJSONWarnings SetupInfo) 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)
siGHCJSs <- jsonSubWarningsTT (o ..:? "ghcjs" ..!= mempty)
siStack <- jsonSubWarningsTT (o ..:? "stack" ..!= mempty)
return SetupInfo {..}
instance Monoid SetupInfo where
mempty =
SetupInfo
{ siSevenzExe = Nothing
, siSevenzDll = Nothing
, siMsys2 = Map.empty
, siGHCs = Map.empty
, siGHCJSs = Map.empty
, siStack = Map.empty
}
mappend l r =
SetupInfo
{ siSevenzExe = siSevenzExe r <|> siSevenzExe l
, siSevenzDll = siSevenzDll r <|> siSevenzDll l
, siMsys2 = siMsys2 r <> siMsys2 l
, siGHCs = Map.unionWith (<>) (siGHCs r) (siGHCs l)
, siGHCJSs = Map.unionWith (<>) (siGHCJSs r) (siGHCJSs l)
, siStack = Map.unionWith (<>) (siStack l) (siStack r) }
data SetupInfoLocation
= SetupInfoFileOrURL String
| SetupInfoInline SetupInfo
deriving (Show)
instance FromJSON (WithJSONWarnings SetupInfoLocation) where
parseJSON v =
(noJSONWarnings <$>
withText "SetupInfoFileOrURL" (pure . SetupInfoFileOrURL . T.unpack) v) <|>
inline
where
inline = do
WithJSONWarnings si w <- parseJSON v
return $ WithJSONWarnings (SetupInfoInline si) w
data PvpBounds
= PvpBoundsNone
| PvpBoundsUpper
| PvpBoundsLower
| PvpBoundsBoth
deriving (Show, Read, Eq, Typeable, Ord, Enum, Bounded)
pvpBoundsText :: PvpBounds -> Text
pvpBoundsText PvpBoundsNone = "none"
pvpBoundsText PvpBoundsUpper = "upper"
pvpBoundsText PvpBoundsLower = "lower"
pvpBoundsText PvpBoundsBoth = "both"
parsePvpBounds :: Text -> Either String PvpBounds
parsePvpBounds t =
case Map.lookup t m of
Nothing -> Left $ "Invalid PVP bounds: " ++ T.unpack t
Just x -> Right x
where
m = Map.fromList $ map (pvpBoundsText &&& id) [minBound..maxBound]
instance ToJSON PvpBounds where
toJSON = toJSON . pvpBoundsText
instance FromJSON PvpBounds where
parseJSON = withText "PvpBounds" (either fail return . parsePvpBounds)
explicitSetupDeps :: (MonadReader env m, HasConfig env) => PackageName -> m Bool
explicitSetupDeps name = do
m <- asks $ configExplicitSetupDeps . getConfig
return $
case Map.lookup (Just name) m of
Just b -> b
Nothing ->
case Map.lookup Nothing m of
Just b -> b
Nothing -> False
data DockerEntrypoint = DockerEntrypoint
{ deUser :: !(Maybe DockerUser)
} deriving (Read,Show)
data DockerUser = DockerUser
{ duUid :: UserID
, duGid :: GroupID
, duGroups :: [GroupID]
, duUmask :: FileMode
} deriving (Read,Show)