module Stack.Config
(MiniConfig
,loadConfig
,loadConfigMaybeProject
,loadMiniConfig
,packagesParser
,getLocalPackages
,resolvePackageEntry
,getImplicitGlobalProjectDir
,getStackYaml
,getSnapshots
,makeConcreteResolver
,checkOwnership
,getInContainer
,getInNixShell
,defaultConfigYaml
,getProjectConfig
,LocalConfigStatus(..)
) where
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Zip as Zip
import qualified Codec.Compression.GZip as GZip
import Control.Applicative
import Control.Arrow ((***))
import Control.Exception (assert)
import Control.Monad (liftM, unless, when, filterM)
import Control.Monad.Catch (MonadThrow, MonadCatch, catchAll, throwM, catch)
import Control.Monad.Extra (firstJustM)
import Control.Monad.IO.Class
import Control.Monad.Logger hiding (Loc)
import Control.Monad.Reader (ask, runReaderT)
import Crypto.Hash (hashWith, SHA256(..))
import Data.Aeson.Extended
import qualified Data.ByteArray as Mem (convert)
import qualified Data.ByteString as S
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString.Lazy as L
import Data.Foldable (forM_)
import Data.IORef
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid.Extra
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
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 Lens.Micro (lens)
import Network.HTTP.Client (parseUrlThrow)
import Network.HTTP.Download (download)
import Network.HTTP.Simple (httpJSON, getResponseBody)
import Options.Applicative (Parser, strOption, long, help)
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.Find (findInParents)
import Path.IO
import qualified Paths_stack as Meta
import Stack.BuildPlan
import Stack.Config.Build
import Stack.Config.Docker
import Stack.Config.Nix
import Stack.Config.Urls
import Stack.Constants
import qualified Stack.Image as Image
import Stack.Types.BuildPlan
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.Docker
import Stack.Types.Internal
import Stack.Types.Nix
import Stack.Types.PackageIndex (HttpType (HTHackageSecurity), HackageSecurity (..))
import Stack.Types.Resolver
import Stack.Types.StackT
import Stack.Types.Urls
import Stack.Types.Version
import System.Environment
import System.IO
import System.PosixCompat.Files (fileOwner, getFileStatus)
import System.PosixCompat.User (getEffectiveUserID)
import System.Process.Read
import System.Process.Run
tryDeprecatedPath
:: (MonadIO m, MonadLogger m)
=> Maybe T.Text
-> (Path Abs a -> m Bool)
-> Path Abs a
-> Path Abs a
-> m (Path Abs a, Bool)
tryDeprecatedPath mWarningDesc exists new old = do
newExists <- exists new
if newExists
then return (new, True)
else do
oldExists <- exists old
if oldExists
then do
case mWarningDesc of
Nothing -> return ()
Just desc ->
$logWarn $ T.concat
[ "Warning: Location of ", desc, " at '"
, T.pack (toFilePath old)
, "' is deprecated; rename it to '"
, T.pack (toFilePath new)
, "' instead" ]
return (old, True)
else return (new, False)
getImplicitGlobalProjectDir
:: (MonadIO m, MonadLogger m)
=> Config -> m (Path Abs Dir)
getImplicitGlobalProjectDir config =
liftM fst $ tryDeprecatedPath
Nothing
doesDirExist
(implicitGlobalProjectDir stackRoot)
(implicitGlobalProjectDirDeprecated stackRoot)
where
stackRoot = configStackRoot config
getStackYaml
:: (StackMiniM env m, HasConfig env)
=> m (Path Abs File)
getStackYaml = do
config <- view configL
case configMaybeProject config of
Just (_project, stackYaml) -> return stackYaml
Nothing -> liftM (</> stackDotYaml) (getImplicitGlobalProjectDir config)
getSnapshots
:: (StackMiniM env m, HasConfig env)
=> m Snapshots
getSnapshots = do
latestUrlText <- askLatestSnapshotUrl
latestUrl <- parseUrlThrow (T.unpack latestUrlText)
$logDebug $ "Downloading snapshot versions file from " <> latestUrlText
result <- httpJSON latestUrl
$logDebug $ "Done downloading and parsing snapshot versions file"
return $ getResponseBody result
makeConcreteResolver
:: (StackMiniM env m, HasConfig env)
=> AbstractResolver
-> m Resolver
makeConcreteResolver (ARResolver r) = return r
makeConcreteResolver ar = do
snapshots <- getSnapshots
r <-
case ar of
ARResolver r -> assert False $ return r
ARGlobal -> do
config <- view configL
implicitGlobalDir <- getImplicitGlobalProjectDir config
let fp = implicitGlobalDir </> stackDotYaml
WithJSONWarnings (ProjectAndConfigMonoid project _) _warnings <-
liftIO (Yaml.decodeFileEither $ toFilePath fp)
>>= either throwM return
return $ projectResolver project
ARLatestNightly -> return $ ResolverSnapshot $ Nightly $ snapshotsNightly snapshots
ARLatestLTSMajor x ->
case IntMap.lookup x $ snapshotsLts snapshots of
Nothing -> error $ "No LTS release found with major version " ++ show x
Just y -> return $ ResolverSnapshot $ LTS x y
ARLatestLTS
| IntMap.null $ snapshotsLts snapshots -> error "No LTS releases found"
| otherwise ->
let (x, y) = IntMap.findMax $ snapshotsLts snapshots
in return $ ResolverSnapshot $ LTS x y
$logInfo $ "Selected resolver: " <> resolverName r
return r
getLatestResolver :: (StackMiniM env m, HasConfig env) => m Resolver
getLatestResolver = do
snapshots <- getSnapshots
let mlts = do
(x,y) <- listToMaybe (reverse (IntMap.toList (snapshotsLts snapshots)))
return (LTS x y)
snap = fromMaybe (Nightly (snapshotsNightly snapshots)) mlts
return (ResolverSnapshot snap)
configNoLocalConfig
:: (MonadLogger m, MonadIO m, MonadCatch m)
=> Path Abs Dir
-> Maybe AbstractResolver
-> ConfigMonoid
-> m Config
configNoLocalConfig _ Nothing _ = throwM NoResolverWhenUsingNoLocalConfig
configNoLocalConfig stackRoot (Just resolver) configMonoid = do
userConfigPath <- getFakeConfigPath stackRoot resolver
configFromConfigMonoid
stackRoot
userConfigPath
False
(Just resolver)
Nothing
configMonoid
configFromConfigMonoid
:: (MonadLogger m, MonadIO m, MonadCatch m)
=> Path Abs Dir
-> Path Abs File
-> Bool
-> Maybe AbstractResolver
-> Maybe (Project, Path Abs File)
-> ConfigMonoid
-> m Config
configFromConfigMonoid
configStackRoot configUserConfigPath configAllowLocals mresolver
mproject ConfigMonoid{..} = do
let configWorkDir = fromFirst $(mkRelDir ".stack-work") configMonoidWorkDir
configUrls <- case (getFirst configMonoidLatestSnapshotUrl, getFirst (urlsMonoidLatestSnapshot configMonoidUrls)) of
(Just url, Nothing) -> do
$logWarn "The latest-snapshot-url field is deprecated in favor of 'urls' configuration"
return (urlsFromMonoid configMonoidUrls) { urlsLatestSnapshot = url }
_ -> return (urlsFromMonoid configMonoidUrls)
let configConnectionCount = fromFirst 8 configMonoidConnectionCount
configHideTHLoading = fromFirst True configMonoidHideTHLoading
configPackageIndices = fromFirst
[PackageIndex
{ indexName = IndexName "Hackage"
, indexLocation = ILGitHttp
"https://github.com/commercialhaskell/all-cabal-hashes.git"
"https://s3.amazonaws.com/hackage.fpcomplete.com/"
(HTHackageSecurity HackageSecurity
{ hsKeyIds =
[ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
, "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
, "280b10153a522681163658cb49f632cde3f38d768b736ddbc901d99a1a772833"
, "2a96b1889dc221c17296fcc2bb34b908ca9734376f0f361660200935916ef201"
, "2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3"
, "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
, "772e9f4c7db33d251d5c6e357199c819e569d130857dc225549b40845ff0890d"
, "aa315286e6ad281ad61182235533c41e806e5a787e0b6d1e7eef3f09d137d2e9"
, "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
]
, hsKeyThreshold = 3
})
, indexDownloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"
, indexGpgVerify = False
, indexRequireHashes = False
}]
configMonoidPackageIndices
configGHCVariant0 = getFirst configMonoidGHCVariant
configGHCBuild = getFirst configMonoidGHCBuild
configInstallGHC = fromFirst False configMonoidInstallGHC
configSkipGHCCheck = fromFirst False configMonoidSkipGHCCheck
configSkipMsys = fromFirst False configMonoidSkipMsys
configExtraIncludeDirs = configMonoidExtraIncludeDirs
configExtraLibDirs = configMonoidExtraLibDirs
configOverrideGccPath = getFirst configMonoidOverrideGccPath
(Platform defArch defOS) = buildPlatform
arch = fromMaybe defArch
$ getFirst configMonoidArch >>= Distribution.Text.simpleParse
os = defOS
configPlatform = Platform arch os
configRequireStackVersion = simplifyVersionRange (getIntersectingVersionRange configMonoidRequireStackVersion)
configImage = Image.imgOptsFromMonoid configMonoidImageOpts
configCompilerCheck = fromFirst MatchMinor configMonoidCompilerCheck
configPlatformVariant <- liftIO $
maybe PlatformVariantNone PlatformVariant <$> lookupEnv platformVariantEnvVar
let configBuild = buildOptsFromMonoid configMonoidBuildOpts
configDocker <-
dockerOptsFromMonoid (fmap fst mproject) configStackRoot mresolver configMonoidDockerOpts
configNix <- nixOptsFromMonoid configMonoidNixOpts os
configSystemGHC <-
case (getFirst configMonoidSystemGHC, nixEnable configNix) of
(Just False, True) ->
throwM NixRequiresSystemGhc
_ ->
return
(fromFirst
(dockerEnable configDocker || nixEnable configNix)
configMonoidSystemGHC)
when (isJust configGHCVariant0 && configSystemGHC) $
throwM ManualGHCVariantSettingsAreIncompatibleWithSystemGHC
rawEnv <- liftIO getEnvironment
pathsEnv <- augmentPathMap configMonoidExtraPath
(Map.fromList (map (T.pack *** T.pack) rawEnv))
origEnv <- mkEnvOverride configPlatform pathsEnv
let configEnvOverride _ = return origEnv
configLocalProgramsBase <- case getFirst configMonoidLocalProgramsBase of
Nothing -> getDefaultLocalProgramsBase configStackRoot configPlatform origEnv
Just path -> return path
platformOnlyDir <- runReaderT platformOnlyRelDir (configPlatform, configPlatformVariant)
let configLocalPrograms = configLocalProgramsBase </> platformOnlyDir
configLocalBin <-
case getFirst configMonoidLocalBinPath of
Nothing -> do
localDir <- getAppUserDataDir "local"
return $ localDir </> $(mkRelDir "bin")
Just userPath ->
(case mproject of
Nothing -> resolveDir' userPath
Just (_, configYaml) -> resolveDir (parent configYaml) userPath)
`catchAll`
const (throwM (NoSuchDirectory userPath))
configJobs <-
case getFirst configMonoidJobs of
Nothing -> liftIO getNumProcessors
Just i -> return i
let configConcurrentTests = fromFirst True configMonoidConcurrentTests
let configTemplateParams = configMonoidTemplateParameters
configScmInit = getFirst configMonoidScmInit
configGhcOptions = configMonoidGhcOptions
configSetupInfoLocations = configMonoidSetupInfoLocations
configPvpBounds = fromFirst PvpBoundsNone configMonoidPvpBounds
configModifyCodePage = fromFirst True configMonoidModifyCodePage
configExplicitSetupDeps = configMonoidExplicitSetupDeps
configRebuildGhcOptions = fromFirst False configMonoidRebuildGhcOptions
configApplyGhcOptions = fromFirst AGOLocals configMonoidApplyGhcOptions
configAllowNewer = fromFirst False configMonoidAllowNewer
configDefaultTemplate = getFirst configMonoidDefaultTemplate
configDumpLogs = fromFirst DumpWarningLogs configMonoidDumpLogs
configAllowDifferentUser <-
case getFirst configMonoidAllowDifferentUser of
Just True -> return True
_ -> getInContainer
configPackageCaches <- liftIO $ newIORef Nothing
let configMaybeProject = mproject
return Config {..}
getDefaultLocalProgramsBase :: MonadThrow m
=> Path Abs Dir
-> Platform
-> EnvOverride
-> m (Path Abs Dir)
getDefaultLocalProgramsBase configStackRoot configPlatform override =
let
defaultBase = configStackRoot </> $(mkRelDir "programs")
in
case configPlatform of
Platform _ Windows ->
case Map.lookup "LOCALAPPDATA" $ unEnvOverride override of
Just t -> do
lad <- parseAbsDir $ T.unpack t
return $ lad </> $(mkRelDir "Programs") </> $(mkRelDir stackProgName)
Nothing -> return defaultBase
_ -> return defaultBase
data MiniConfig = MiniConfig
{ mcGHCVariant :: !GHCVariant
, mcConfig :: !Config
}
instance HasConfig MiniConfig where
configL = lens mcConfig (\x y -> x { mcConfig = y })
instance HasPlatform MiniConfig
instance HasGHCVariant MiniConfig where
ghcVariantL = lens mcGHCVariant (\x y -> x { mcGHCVariant = y })
loadMiniConfig :: Config -> MiniConfig
loadMiniConfig config =
let ghcVariant = fromMaybe GHCStandard (configGHCVariant0 config)
in MiniConfig ghcVariant config
loadConfigMaybeProject
:: StackM env m
=> ConfigMonoid
-> Maybe AbstractResolver
-> LocalConfigStatus (Project, Path Abs File, ConfigMonoid)
-> m (LoadConfig m)
loadConfigMaybeProject configArgs mresolver mproject = do
(stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs
let loadHelper mproject' = do
userConfigPath <- getDefaultUserConfigPath stackRoot
extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadConfigYaml
let extraConfigs =
map (\c -> c {configMonoidDockerOpts =
(configMonoidDockerOpts c) {dockerMonoidDefaultEnable = Any False}})
extraConfigs0
configFromConfigMonoid
stackRoot
userConfigPath
True
mresolver
(fmap (\(x, y, _) -> (x, y)) mproject')
$ mconcat $ configArgs
: maybe id (\(_, _, projectConfig) -> (projectConfig:)) mproject' extraConfigs
config <-
case mproject of
LCSNoConfig -> configNoLocalConfig stackRoot mresolver configArgs
LCSProject project -> loadHelper $ Just project
LCSNoProject -> loadHelper Nothing
unless (fromCabalVersion Meta.version `withinRange` configRequireStackVersion config)
(throwM (BadStackVersionException (configRequireStackVersion config)))
let mprojectRoot = fmap (\(_, fp, _) -> parent fp) mproject
unless (configAllowDifferentUser config) $ do
unless userOwnsStackRoot $
throwM (UserDoesn'tOwnDirectory stackRoot)
forM_ mprojectRoot $ \dir ->
checkOwnership (dir </> configWorkDir config)
return LoadConfig
{ lcConfig = config
, lcLoadBuildConfig = loadBuildConfig mproject config mresolver
, lcProjectRoot =
case mprojectRoot of
LCSProject fp -> Just fp
LCSNoProject -> Nothing
LCSNoConfig -> Nothing
}
loadConfig :: StackM env m
=> ConfigMonoid
-> Maybe AbstractResolver
-> StackYamlLoc (Path Abs File)
-> m (LoadConfig m)
loadConfig configArgs mresolver mstackYaml =
loadProjectConfig mstackYaml >>= loadConfigMaybeProject configArgs mresolver
loadBuildConfig :: StackM env m
=> LocalConfigStatus (Project, Path Abs File, ConfigMonoid)
-> Config
-> Maybe AbstractResolver
-> Maybe CompilerVersion
-> m BuildConfig
loadBuildConfig mproject config mresolver mcompiler = do
env <- ask
(project', stackYamlFP) <- case mproject of
LCSProject (project, fp, _) -> do
forM_ (projectUserMsg project) ($logWarn . T.pack)
return (project, fp)
LCSNoConfig -> do
p <- getEmptyProject
return (p, configUserConfigPath config)
LCSNoProject -> do
$logDebug "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
ensureDir destDir
exists <- doesFileExist dest
if exists
then do
ProjectAndConfigMonoid project _ <- loadConfigYaml dest
when (view terminalL env) $
case mresolver of
Nothing ->
$logDebug ("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"
$logDebug ("Using resolver: " <> name <>
" specified on command line")
return (project, dest)
else do
$logInfo ("Writing implicit global project config file to: " <> T.pack dest')
$logInfo "Note: You can change the snapshot via the resolver field there."
p <- getEmptyProject
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"
, "# http://docs.haskellstack.org/en/stable/yaml_configuration/\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 ->
runReaderT (makeConcreteResolver aresolver) miniConfig
let project = project'
{ projectResolver = resolver
, projectCompiler = mcompiler <|> projectCompiler project'
}
(mbp0, loadedResolver) <- flip runReaderT miniConfig $
loadResolver (Just stackYamlFP) (projectResolver project)
let mbp = case projectCompiler project of
Just compiler -> mbp0 { mbpCompilerVersion = compiler }
Nothing -> mbp0
extraPackageDBs <- mapM resolveDir' (projectExtraPackageDBs project)
return BuildConfig
{ bcConfig = config
, bcResolver = loadedResolver
, bcWantedMiniBuildPlan = mbp
, bcGHCVariant = view ghcVariantL miniConfig
, bcPackageEntries = projectPackages project
, bcExtraDeps = projectExtraDeps project
, bcExtraPackageDBs = extraPackageDBs
, bcStackYaml = stackYamlFP
, bcFlags = projectFlags project
, bcImplicitGlobal =
case mproject of
LCSNoProject -> True
LCSProject _ -> False
LCSNoConfig -> False
}
where
miniConfig = loadMiniConfig config
getEmptyProject = do
r <- case mresolver of
Just aresolver -> do
r' <- runReaderT (makeConcreteResolver aresolver) miniConfig
$logInfo ("Using resolver: " <> resolverName r' <> " specified on command line")
return r'
Nothing -> do
r'' <- runReaderT getLatestResolver miniConfig
$logInfo ("Using latest snapshot resolver: " <> resolverName r'')
return r''
return Project
{ projectUserMsg = Nothing
, projectPackages = mempty
, projectExtraDeps = mempty
, projectFlags = mempty
, projectResolver = r
, projectCompiler = Nothing
, projectExtraPackageDBs = []
}
getLocalPackages
:: (StackMiniM env m, HasEnvConfig env)
=> m (Map.Map (Path Abs Dir) TreatLikeExtraDep)
getLocalPackages = do
cacheRef <- view $ envConfigL.to envConfigPackagesRef
mcached <- liftIO $ readIORef cacheRef
case mcached of
Just cached -> return cached
Nothing -> do
menv <- getMinimalEnvOverride
root <- view projectRootL
entries <- view $ buildConfigL.to bcPackageEntries
liftM (Map.fromList . concat) $ mapM
(resolvePackageEntry menv root)
entries
resolvePackageEntry
:: (StackMiniM env m, HasConfig env)
=> EnvOverride
-> Path Abs Dir
-> PackageEntry
-> m [(Path Abs Dir, TreatLikeExtraDep)]
resolvePackageEntry menv projRoot pe = do
entryRoot <- resolvePackageLocation menv projRoot (peLocation pe)
paths <-
case peSubdirs pe of
[] -> return [entryRoot]
subs -> mapM (resolveDir entryRoot) subs
extraDep <-
case peExtraDepMaybe pe of
Just e -> return e
Nothing ->
case peLocation pe of
PLFilePath _ ->
return False
PLRemote url _ -> do
$logWarn $ mconcat
[ "No extra-dep setting found for package at URL:\n\n"
, url
, "\n\n"
, "This is usually a mistake, external packages "
, "should typically\nbe treated as extra-deps to avoid "
, "spurious test case failures."
]
return False
return $ map (, extraDep) paths
resolvePackageLocation
:: (StackMiniM env m, HasConfig env)
=> EnvOverride
-> Path Abs Dir
-> PackageLocation
-> m (Path Abs Dir)
resolvePackageLocation _ projRoot (PLFilePath fp) = resolveDir projRoot fp
resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
workDir <- view workDirL
let nameBeforeHashing = case remotePackageType of
RPTHttp{} -> url
RPTGit commit -> T.unwords [url, commit]
RPTHg commit -> T.unwords [url, commit, "hg"]
name = T.unpack $ decodeUtf8 $ S.take 12 $ B64URL.encode $ Mem.convert $ hashWith SHA256 $ encodeUtf8 nameBeforeHashing
root = projRoot </> workDir </> $(mkRelDir "downloaded")
fileExtension' = case remotePackageType of
RPTHttp -> ".http-archive"
_ -> ".unused"
fileRel <- parseRelFile $ name ++ fileExtension'
dirRel <- parseRelDir name
dirRelTmp <- parseRelDir $ name ++ ".tmp"
let file = root </> fileRel
dir = root </> dirRel
exists <- doesDirExist dir
unless exists $ do
ignoringAbsence (removeDirRecur dir)
let cloneAndExtract commandName cloneArgs resetCommand commit = do
ensureDir root
callProcessInheritStderrStdout Cmd
{ cmdDirectoryToRunIn = Just root
, cmdCommandToRun = commandName
, cmdEnvOverride = menv
, cmdCommandLineArguments =
"clone" :
cloneArgs ++
[ T.unpack url
, toFilePathNoTrailingSep dir
]
}
created <- doesDirExist dir
unless created $ throwM $ FailedToCloneRepo commandName
readProcessNull (Just dir) menv commandName
(resetCommand ++ [T.unpack commit, "--"])
`catch` \case
ex@ProcessFailed{} -> do
$logInfo $ "Please ensure that commit " <> commit <> " exists within " <> url
throwM ex
ex -> throwM ex
case remotePackageType of
RPTHttp -> do
let dirTmp = root </> dirRelTmp
ignoringAbsence (removeDirRecur dirTmp)
let fp = toFilePath file
req <- parseUrlThrow $ T.unpack url
_ <- download req file
let tryTar = do
$logDebug $ "Trying to untar " <> T.pack fp
liftIO $ withBinaryFile fp ReadMode $ \h -> do
lbs <- L.hGetContents h
let entries = Tar.read $ GZip.decompress lbs
Tar.unpack (toFilePath dirTmp) entries
tryZip = do
$logDebug $ "Trying to unzip " <> T.pack fp
archive <- fmap Zip.toArchive $ liftIO $ L.readFile fp
liftIO $ Zip.extractFilesFromArchive [Zip.OptDestination
(toFilePath dirTmp)] archive
err = throwM $ UnableToExtractArchive url file
catchAllLog goodpath handler =
catchAll goodpath $ \e -> do
$logDebug $ "Got exception: " <> T.pack (show e)
handler
tryTar `catchAllLog` tryZip `catchAllLog` err
renameDir dirTmp dir
RPTGit commit -> cloneAndExtract "git" ["--recursive"] ["--git-dir=.git", "reset", "--hard"] commit
RPTHg commit -> cloneAndExtract "hg" [] ["--repository", ".", "update", "-C"] commit
case remotePackageType of
RPTHttp -> do
x <- listDir dir
case x of
([dir'], []) -> return dir'
(dirs, files) -> do
ignoringAbsence (removeFile file)
ignoringAbsence (removeDirRecur dir)
throwM $ UnexpectedArchiveContents dirs files
_ -> return dir
determineStackRootAndOwnership
:: (MonadIO m, MonadCatch m)
=> ConfigMonoid
-> m (Path Abs Dir, Bool)
determineStackRootAndOwnership clArgs = do
stackRoot <- do
case getFirst (configMonoidStackRoot clArgs) of
Just x -> return x
Nothing -> do
mstackRoot <- liftIO $ lookupEnv stackRootEnvVar
case mstackRoot of
Nothing -> getAppUserDataDir stackProgName
Just x -> parseAbsDir x
(existingStackRootOrParentDir, userOwnsIt) <- do
mdirAndOwnership <- findInParents getDirAndOwnership stackRoot
case mdirAndOwnership of
Just x -> return x
Nothing -> throwM (BadStackRoot stackRoot)
when (existingStackRootOrParentDir /= stackRoot) $
if userOwnsIt
then liftIO $ ensureDir stackRoot
else throwM $
Won'tCreateStackRootInDirectoryOwnedByDifferentUser
stackRoot
existingStackRootOrParentDir
stackRoot' <- canonicalizePath stackRoot
return (stackRoot', userOwnsIt)
checkOwnership :: (MonadIO m, MonadCatch m) => Path Abs Dir -> m ()
checkOwnership dir = do
mdirAndOwnership <- firstJustM getDirAndOwnership [dir, parent dir]
case mdirAndOwnership of
Just (_, True) -> return ()
Just (dir', False) -> throwM (UserDoesn'tOwnDirectory dir')
Nothing ->
(throwM . NoSuchDirectory) $ (toFilePathNoTrailingSep . parent) dir
getDirAndOwnership
:: (MonadIO m, MonadCatch m)
=> Path Abs Dir
-> m (Maybe (Path Abs Dir, Bool))
getDirAndOwnership dir = forgivingAbsence $ do
ownership <- isOwnedByUser dir
return (dir, ownership)
isOwnedByUser :: MonadIO m => Path Abs t -> m Bool
isOwnedByUser path = liftIO $ do
if osIsWindows
then return True
else do
fileStatus <- getFileStatus (toFilePath path)
user <- getEffectiveUserID
return (user == fileOwner fileStatus)
where
#ifdef WINDOWS
osIsWindows = True
#else
osIsWindows = False
#endif
getInContainer :: (MonadIO m) => m Bool
getInContainer = liftIO (isJust <$> lookupEnv inContainerEnvVar)
getInNixShell :: (MonadIO m) => m Bool
getInNixShell = liftIO (isJust <$> lookupEnv inNixShellEnvVar)
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 doesFileExist
$ fromMaybe userConfigPath mstackConfig
: maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfigPath)
loadConfigYaml
:: (FromJSON (WithJSONWarnings a), MonadIO m, MonadLogger m)
=> Path Abs File -> m a
loadConfigYaml path = do
eres <- loadYaml path
case eres of
Left err -> liftIO $ throwM (ParseConfigFileException path err)
Right res -> return res
loadYaml
:: (FromJSON (WithJSONWarnings a), MonadIO m, MonadLogger m)
=> Path Abs File -> m (Either Yaml.ParseException a)
loadYaml path = do
eres <- liftIO $ Yaml.decodeFileEither (toFilePath path)
case eres of
Left err -> return (Left err)
Right (WithJSONWarnings res warnings) -> do
logJSONWarnings (toFilePath path) warnings
return (Right res)
getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
=> StackYamlLoc (Path Abs File)
-> m (LocalConfigStatus (Path Abs File))
getProjectConfig (SYLOverride stackYaml) = return $ LCSProject stackYaml
getProjectConfig SYLDefault = do
env <- liftIO getEnvironment
case lookup "STACK_YAML" env of
Just fp -> do
$logInfo "Getting project config file from STACK_YAML environment"
liftM LCSProject $ resolveFile' fp
Nothing -> do
currDir <- getCurrentDir
maybe LCSNoProject LCSProject <$> findInParents getStackDotYaml currDir
where
getStackDotYaml dir = do
let fp = dir </> stackDotYaml
fp' = toFilePath fp
$logDebug $ "Checking for project config at: " <> T.pack fp'
exists <- doesFileExist fp
if exists
then return $ Just fp
else return Nothing
getProjectConfig SYLNoConfig = return LCSNoConfig
data LocalConfigStatus a
= LCSNoProject
| LCSProject a
| LCSNoConfig
deriving (Show,Functor,Foldable,Traversable)
loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
=> StackYamlLoc (Path Abs File)
-> m (LocalConfigStatus (Project, Path Abs File, ConfigMonoid))
loadProjectConfig mstackYaml = do
mfp <- getProjectConfig mstackYaml
case mfp of
LCSProject fp -> do
currDir <- getCurrentDir
$logDebug $ "Loading project config file " <>
T.pack (maybe (toFilePath fp) toFilePath (stripDir currDir fp))
LCSProject <$> load fp
LCSNoProject -> do
$logDebug $ "No project config file found, using defaults."
return LCSNoProject
LCSNoConfig -> do
$logDebug "Ignoring config files"
return LCSNoConfig
where
load fp = do
ProjectAndConfigMonoid project config <- loadConfigYaml fp
return (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")
doesFileExist
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")
doesFileExist
(defaultUserConfigPath stackRoot)
(defaultUserConfigPathDeprecated stackRoot)
unless exists $ do
ensureDir (parent path)
liftIO $ S.writeFile (toFilePath path) defaultConfigYaml
return path
getFakeConfigPath
:: (MonadIO m, MonadThrow m)
=> Path Abs Dir
-> AbstractResolver
-> m (Path Abs File)
getFakeConfigPath stackRoot ar = do
asString <-
case ar of
ARResolver r -> return $ T.unpack $ resolverName r
_ -> throwM $ InvalidResolverForNoLocalConfig $ show ar
asDir <- parseRelDir asString
let full = stackRoot </> $(mkRelDir "script") </> asDir </> $(mkRelFile "config.yaml")
ensureDir (parent full)
return full
packagesParser :: Parser [String]
packagesParser = many (strOption (long "package" <> help "Additional packages that must be installed"))
defaultConfigYaml :: S.ByteString
defaultConfigYaml = S.intercalate "\n"
[ "# This file contains default non-project-specific settings for 'stack', used"
, "# in all projects. For more information about stack's configuration, see"
, "# http://docs.haskellstack.org/en/stable/yaml_configuration/"
, ""
, "# The following parameters are used by \"stack new\" to automatically fill fields"
, "# in the cabal config. We recommend uncommenting them and filling them out if"
, "# you intend to use 'stack new'."
, "# See https://docs.haskellstack.org/en/stable/yaml_configuration/#templates"
, "templates:"
, " params:"
, "# author-name:"
, "# author-email:"
, "# copyright:"
, "# github-username:"
]