Config.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}

-- | The general Stack configuration that starts everything off. This should
-- be smart to falback if there is no stack.yaml, instead relying on
-- whatever files are available.
--
-- If there is no stack.yaml, and there is a cabal.config, we
-- read in those constraints, and if there's a cabal.sandbox.config,
-- we read any constraints from there and also find the package
-- database from there, etc. And if there's nothing, we should
-- probably default to behaving like cabal, possibly with spitting out
-- a warning that "you should run `stk init` to make things better".
module Stack.Config
  ( configOptsParser
  , loadConfig
  ) where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Catch
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           Data.Aeson
import           Data.Either (partitionEithers)
import           Data.Map (Map)
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Distribution.Package as C
import qualified Distribution.PackageDescription as C
import           Data.Maybe
import           Data.Monoid
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Yaml as Yaml
import           Distribution.System (OS (Windows), Platform (..), buildPlatform)
import           Network.HTTP.Client.Conduit (HasHttpManager, getHttpManager, Manager)
import           Options.Applicative (Parser)
import           Path
import           Path.IO
import           Stack.BuildPlan
import           Stack.Types.Config
import           Stack.Constants
import qualified Stack.Docker as Docker
import           Stack.Package
import           Stack.Types
import           System.Directory
import           System.Environment
import           System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride)

-- | Get the default resolver value
getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
                   => Path Abs Dir
                   -> m (Resolver, Map PackageName (Map FlagName Bool), Bool)
getDefaultResolver dir = do
    ecabalfp <- try $ getCabalFileName dir
    let cabalFileExists = either (const False) (const True) ecabalfp
    msnap <- case ecabalfp of
        Left e -> do
            $logWarn $ T.pack $ show (e :: PackageException)
            return Nothing
        Right cabalfp -> do
            gpd <- readPackageUnresolved cabalfp
            mpair <- findBuildPlan gpd
            let name =
                    case C.package $ C.packageDescription gpd of
                        C.PackageIdentifier cname _ ->
                            fromCabalPackageName cname
            return $ fmap (, name) mpair
    case msnap of
        Just ((snap, flags), name) ->
            return (ResolverSnapshot snap, Map.singleton name flags, cabalFileExists)
        Nothing -> do
            s <- getSnapshots
            let snap = case IntMap.maxViewWithKey (snapshotsLts s) of
                    Just ((x, y), _) -> LTS x y
                    Nothing -> Nightly $ snapshotsNightly s
            return (ResolverSnapshot snap, Map.empty, cabalFileExists)

data ProjectAndConfigMonoid
  = ProjectAndConfigMonoid !Project !ConfigMonoid

instance FromJSON ProjectAndConfigMonoid where
    parseJSON = withObject "Project, ConfigMonoid" $ \o -> do
        dirs <- o .:? "packages" .!= ["."]
        extraDeps' <- o .:? "extra-deps" .!= []
        extraDeps <-
            case partitionEithers $ goDeps extraDeps' of
                ([], x) -> return $ Map.fromList x
                (errs, _) -> fail $ unlines errs

        flags <- o .:? "flags" .!= mempty
        resolver <- o .: "resolver"
        config <- parseJSON $ Object o
        let project = Project
                { projectPackages = dirs
                , projectExtraDeps = extraDeps
                , projectFlags = flags
                , projectResolver = resolver
                }
        return $ ProjectAndConfigMonoid project config
      where
        goDeps =
            map toSingle . Map.toList . Map.unionsWith S.union . map toMap
          where
            toMap i = Map.singleton
                (packageIdentifierName i)
                (S.singleton (packageIdentifierVersion i))

        toSingle (k, s) =
            case S.toList s of
                [x] -> Right (k, x)
                xs -> Left $ concat
                    [ "Multiple versions for package "
                    , packageNameString k
                    , ": "
                    , unwords $ map versionString xs
                    ]

-- | Note that this will be @Nothing@ on Windows, which is by design.
defaultStackGlobalConfig :: Maybe (Path Abs File)
defaultStackGlobalConfig = parseAbsFile "/etc/stack/config"

-- Interprets ConfigMonoid options.
configFromConfigMonoid
    :: (MonadLogger m, MonadIO m, MonadCatch m, MonadReader env m, HasHttpManager env)
    => Path Abs Dir -- ^ stack root, e.g. ~/.stack
    -> Maybe Project
    -> ConfigMonoid
    -> m Config
configFromConfigMonoid configStackRoot mproject ConfigMonoid{..} = do
     let configDocker = Docker.dockerOptsFromMonoid mproject configStackRoot configMonoidDockerOpts
         configConnectionCount = fromMaybe 8 configMonoidConnectionCount
         configHideTHLoading = fromMaybe True configMonoidHideTHLoading
         configLatestSnapshotUrl = fromMaybe
            "https://www.stackage.org/download/snapshots.json"
            configMonoidLatestSnapshotUrl
         configPackageIndices = fromMaybe
            [PackageIndex
                { indexName = IndexName "hackage.haskell.org"
                , 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

         -- Only place in the codebase where platform is hard-coded. In theory
         -- in the future, allow it to be configured.
         configPlatform = buildPlatform

     origEnv <- getEnvOverride configPlatform
     let configEnvOverride _ = return origEnv

     platform <- runReaderT platformRelDir configPlatform

     configLocalPrograms <-
        case configPlatform of
            Platform _ Windows -> do
                progsDir <- getWindowsProgsDir configStackRoot origEnv
                return $ progsDir </> $(mkRelDir stackProgName) </> platform
            _ -> return $ configStackRoot </> $(mkRelDir "programs") </> platform

     return Config {..}

-- | Command-line arguments parser for configuration.
configOptsParser :: Bool -> Parser ConfigMonoid
configOptsParser docker =
    (\opts -> mempty { configMonoidDockerOpts = opts })
    <$> Docker.dockerOptsParser docker

-- | Get the directory on Windows where we should install extra programs. For
-- more information, see discussion at:
-- https://github.com/fpco/minghc/issues/43#issuecomment-99737383
getWindowsProgsDir :: MonadThrow m
                   => Path Abs Dir
                   -> EnvOverride
                   -> m (Path Abs Dir)
getWindowsProgsDir stackRoot m =
    case Map.lookup "LOCALAPPDATA" $ unEnvOverride m of
        Just t -> do
            lad <- parseAbsDir $ T.unpack t
            return $ lad </> $(mkRelDir "Programs")
        Nothing -> return $ stackRoot </> $(mkRelDir "Programs")

data MiniConfig = MiniConfig Manager Config
instance HasConfig MiniConfig where
    getConfig (MiniConfig _ c) = c
instance HasStackRoot MiniConfig
instance HasHttpManager MiniConfig where
    getHttpManager (MiniConfig man _) = man
instance HasPlatform MiniConfig

-- | Load the configuration, using current directory, environment variables,
-- and defaults as necessary.
loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env,MonadBaseControl IO m)
           => ConfigMonoid
           -- ^ Config monoid from parsed command-line arguments
           -> m (LoadConfig m)
loadConfig configArgs = do
    stackRoot <- determineStackRoot
    extraConfigs <- getExtraConfigs stackRoot >>= mapM loadYaml
    mproject <- loadProjectConfig
    config <- configFromConfigMonoid stackRoot (fmap (\(proj, _, _) -> proj) mproject) $ mconcat $
        case mproject of
            Nothing -> configArgs : extraConfigs
            Just (_, _, projectConfig) -> configArgs : projectConfig : extraConfigs
    return $ LoadConfig
        { lcConfig          = config
        , lcLoadBuildConfig = loadBuildConfig mproject config
        , lcProjectRoot     = fmap (\(_, fp, _) -> parent fp) mproject
        }

-- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.
-- values.
loadBuildConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env,MonadBaseControl IO m)
                => Maybe (Project, Path Abs File, ConfigMonoid)
                -> Config
                -> NoBuildConfigStrategy
                -> m BuildConfig
loadBuildConfig mproject config noConfigStrat = do
    env <- ask
    let miniConfig = MiniConfig (getHttpManager env) config
    (project, stackYamlFP) <- case mproject of
      Just (project, fp, _) -> return (project, fp)
      Nothing -> case noConfigStrat of
        ThrowException -> do
            currDir <- getWorkingDir
            throwM $ NoProjectConfigFound currDir
        ExecStrategy ->
            error "You do not have a stack.yaml. This will be handled in the future, see https://github.com/fpco/stack/issues/59"
        CreateConfig -> do
            currDir <- getWorkingDir
            (r, flags, cabalFileExists) <- runReaderT (getDefaultResolver currDir) miniConfig
            let dest = currDir </> stackDotYaml
                dest' = toFilePath dest
            exists <- liftIO $ doesFileExist dest'
            when exists $ error "Invariant violated: in toBuildConfig's Nothing branch, and the stack.yaml file exists"
            $logInfo $ "Writing default config file to: " <> T.pack dest'
            let p = Project
                    { projectPackages =
                        if cabalFileExists
                            then ["."]
                            else []
                    , projectExtraDeps = Map.empty
                    , projectFlags = flags
                    , projectResolver = r
                    }
            liftIO $ Yaml.encodeFile dest' p
            return (p, dest)

    ghcVersion <-
        case projectResolver project of
            ResolverSnapshot snapName -> do
                mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig
                return $ mbpGhcVersion mbp
            ResolverGhc m -> return $ fromMajorVersion m

    let root = parent stackYamlFP
    packages' <- mapM (resolveDir root) (projectPackages project)
    let packages = S.fromList packages'

    return BuildConfig
        { bcConfig = config
        , bcResolver = projectResolver project
        , bcGhcVersion = ghcVersion
        , bcPackages = packages
        , bcExtraDeps = projectExtraDeps project
        , bcRoot = root
        , bcStackYaml = stackYamlFP
        , bcFlags = projectFlags project
        }

-- | Get the stack root, e.g. ~/.stack
determineStackRoot :: (MonadIO m, MonadThrow m) => m (Path Abs Dir)
determineStackRoot = do
    env <- liftIO getEnvironment
    case lookup stackRootEnvVar env of
        Nothing -> do
            x <- liftIO $ getAppUserDataDirectory stackProgName
            parseAbsDir x
        Just x -> do
            y <- liftIO $ do
                createDirectoryIfMissing True x
                canonicalizePath x
            parseAbsDir y

-- | Determine the extra config file locations which exist.
--
-- Returns most local first
getExtraConfigs :: MonadIO m
                => Path Abs Dir -- ^ stack root
                -> m [Path Abs File]
getExtraConfigs stackRoot = 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 (liftIO . doesFileExist . toFilePath)
        $ fromMaybe (stackRoot </> stackDotYaml) mstackConfig
        : maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfig)

-- | Load and parse YAML from the given file.
loadYaml :: (FromJSON a,MonadIO m) => Path Abs File -> m a
loadYaml path =
    liftIO $ Yaml.decodeFileEither (toFilePath path)
         >>= either throwM return

-- | Get the location of the project config file, if it exists
getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
                 => m (Maybe (Path Abs File))
getProjectConfig = 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 <- liftIO $ doesFileExist fp'
        if exists
            then return $ Just fp
            else do
                let dir' = parent dir
                if dir == dir'
                    -- fully traversed, give up
                    then return Nothing
                    else search dir'

-- | Find the project config file location, respecting environment variables
-- and otherwise traversing parents. If no config is found, we supply a default
-- based on current directory.
loadProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)
                  => m (Maybe (Project, Path Abs File, ConfigMonoid))
loadProjectConfig = do
    mfp <- getProjectConfig
    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)