diff --git a/src/Stackage/Config.hs b/src/Stackage/Config.hs index 059edab0..2fb57941 100644 --- a/src/Stackage/Config.hs +++ b/src/Stackage/Config.hs @@ -1,7 +1,260 @@ -{-# LANGUAGE EmptyDataDecls #-} +-- | The general Stackage configuration that starts everything off. This should +-- be smart to falback if there is no stackage.config, instead relying on +-- whatever files are available. +-- +-- If there is no stackage.config, 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 Stackage.Config ( + Config + , Settings + , getConfig + , NotYetImplemented(..) + ) where --- | +import Control.Applicative +import Control.Exception +import Control.Monad.Catch +import Control.Monad.Logger hiding (Loc) +import Control.Monad.IO.Class +import Data.Aeson +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Typeable +import qualified Data.Yaml as Yaml -module Stackage.Config where +import Filesystem.Loc -data Config +data Config = + Config {configPkgDbLocation :: Loc Absolute Dir + ,configSandboxLocation :: Loc Absolute Dir + ,configGhcBinLocation :: Loc Absolute Dir + ,configCabalBinLocation :: Loc Absolute Dir + ,configInDocker :: Bool + } +data Settings = Settings + +data NotYetImplemented = NotYetImplemented Text + deriving (Show, Typeable) +instance Exception NotYetImplemented + + +-- Some examples of stackage.config + +-- (example 1) +-- docker: true + +-- (example 2) +-- cabal-sandbox: +-- lts: 2 + +-- (example 3) +-- cabal-sandbox: +-- nightly: 2015-06-01 + +-- (example 4) +-- cabal-sandbox: +-- custom: +-- ghc: /home/dan/ghc/ghc-6.12/bin +-- cabal: /home/dan/.cabal/bin +-- sandbox: .cabal-sandbox + +-- (example 5) +-- cabal-sandbox: +-- custom: +-- ghc: '7.10' +-- cabal: detect +-- sandbox: detect + +data StackageConfig = + StackageConfig + { configStackageRoot :: Maybe Text + , configStackageHost :: Maybe Text + , configBuildStrategy :: BuildStrategy + } + deriving Show + +data BuildStrategy + = CabalSandbox CabalSandboxBuildStrategy + | Docker DockerBuildStrategy + deriving Show + +data CabalSandboxBuildStrategy + = BuildAgainstLTS LTSBuildStrategy + | BuildAgainstNightly NightlyBuildStrategy + | BuildAgainstSnapshot SnapshotBuildStrategy + | BuildAgainstCustom (CustomBuildStrategy Text) + deriving Show + +data DockerBuildStrategy = + DockerBuildStrategy + deriving Show + +data LTSBuildStrategy = + LTSBuildStrategy + { configLTS :: Text + } + deriving Show + +data NightlyBuildStrategy = + NightlyBuildStrategy + { configNightly :: Text + } + deriving Show + +data SnapshotBuildStrategy = + SnapshotBuildStrategy + { configSnapshot :: Text + } + deriving Show + +data CustomBuildStrategy a = + CustomBuildStrategy + { customGhcBinLocation :: a + , customCabalBinLocation :: a + , customSandboxLocation :: a + } + deriving Show + + +instance FromJSON LTSBuildStrategy where + parseJSON j = parseAsText j <|> parseAsScientific j where + parseAsText = withText "LTSBuildStrategy" $ \t -> do + let configLTS = t + return LTSBuildStrategy{..} + -- allows people to not have to quote the lts field + parseAsScientific = withScientific "LTSBuildStrategy" $ \s -> do + let configLTS = Text.pack $ show s + return LTSBuildStrategy{..} + +instance FromJSON NightlyBuildStrategy where + parseJSON = withText "NightlyBuildStrategy" $ \t -> do + let configNightly = t + return NightlyBuildStrategy{..} + +instance FromJSON SnapshotBuildStrategy where + parseJSON = withText "SnapshotBuildStrategy" $ \t -> do + let configSnapshot = t + return SnapshotBuildStrategy{..} + + +instance FromJSON a => FromJSON (CustomBuildStrategy a) where + parseJSON = withObject "CustomBuildStrategy" $ \obj -> do + customGhcBinLocation <- obj .: "ghc" + customCabalBinLocation <- obj .: "cabal" + customSandboxLocation <- obj .: "sandbox" + return CustomBuildStrategy{..} + +instance FromJSON StackageConfig where + parseJSON = withObject "StackageConfig" $ \obj -> do + configStackageRoot <- obj .:? "stackage-root" + configStackageHost <- obj .:? "stackage-host" + configBuildStrategy <- + (Docker <$> obj .: "docker") <|> + (CabalSandbox <$> obj .: "cabal-sandbox") + return StackageConfig{..} + +instance FromJSON DockerBuildStrategy where + parseJSON = withBool "DockerBuildStrategy" $ \b -> + if b + then return DockerBuildStrategy + else fail "docker: false" + +instance FromJSON CabalSandboxBuildStrategy where + parseJSON = withObject "CabalSandboxBuildStrategy" $ \obj -> + (BuildAgainstLTS <$> obj .: "lts") <|> + (BuildAgainstNightly <$> obj .: "nightly") <|> + (BuildAgainstSnapshot <$> obj .: "snapshot") <|> + (BuildAgainstCustom <$> obj .: "custom") + +parseBuildStrategy :: (MonadLogger m, MonadIO m, MonadThrow m) + => CabalSandboxBuildStrategy -> m (CustomBuildStrategy (Loc Absolute Dir)) +parseBuildStrategy (BuildAgainstLTS lts) = + resolveLTSSnapshot lts >>= parseBuildStrategy . BuildAgainstSnapshot +parseBuildStrategy (BuildAgainstNightly nightly) = + resolveNightlySnapshot nightly >>= parseBuildStrategy . BuildAgainstSnapshot +parseBuildStrategy (BuildAgainstSnapshot snapshot) = do + customGhcBinLocation <- resolveSnapshotGhcLoc snapshot + customCabalBinLocation <- resolveSnapshotCabalLoc snapshot + customSandboxLocation <- resolveSnapshotSandboxLoc snapshot + return CustomBuildStrategy{..} +parseBuildStrategy (BuildAgainstCustom custom) = do + ghcBinLoc <- resolveCustomGhcLoc (customGhcBinLocation custom) + cabalBinLoc <- resolveCustomCabalLoc (customCabalBinLocation custom) + sandboxLocation <- resolveCustomSandboxLoc (customSandboxLocation custom) + return CustomBuildStrategy + { customGhcBinLocation = ghcBinLoc + , customCabalBinLocation = cabalBinLoc + , customSandboxLocation = sandboxLocation + } + +-- TODO +-- Build strategy based on whatever ghc, cabal, and sandbox are visible. +--defaultBuildStrategy :: (MonadLogger m, MonadIO m, MonadThrow m) +-- => m (CustomBuildStrategy (Loc Absolute Dir)) +--defaultBuildStrategy = undefined + +getStackageConfig :: (MonadLogger m, MonadIO m, MonadThrow m) + => m StackageConfig +getStackageConfig = do + mconf <- liftIO $ Yaml.decodeFile "stackage.config" + maybe (throwM $ NotYetImplemented "getStackageConfig") return mconf + + +configFromStackageConfig :: (MonadLogger m, MonadIO m, MonadThrow m) + => StackageConfig -> m Config +configFromStackageConfig StackageConfig{..} = do + CustomBuildStrategy{..} <- case configBuildStrategy of + CabalSandbox strategy -> parseBuildStrategy strategy + Docker _ -> throwM $ NotYetImplemented "configFromStackageConfig" + let configPkgDbLocation = undefined + configSandboxLocation = undefined + configGhcBinLocation = undefined + configCabalBinLocation = undefined + configInDocker = undefined + return Config{..} + +-- TODO: handle more settings +-- TODO: handle failure to retrieve StacakgeConfig +getConfig :: (MonadLogger m,MonadIO m,MonadThrow m) + => Settings -> m Config +getConfig Settings = do + stackageConfig <- getStackageConfig + configFromStackageConfig stackageConfig + + +resolveLTSSnapshot :: (MonadLogger m, MonadIO m, MonadThrow m) + => LTSBuildStrategy -> m SnapshotBuildStrategy +resolveLTSSnapshot _ = throwM $ NotYetImplemented "resolveLTSSnapshot" + +resolveNightlySnapshot :: (MonadLogger m, MonadIO m, MonadThrow m) + => NightlyBuildStrategy -> m SnapshotBuildStrategy +resolveNightlySnapshot _ = throwM $ NotYetImplemented "resolveNightlySnapshot" + + +resolveSnapshotSandboxLoc :: (MonadLogger m, MonadIO m, MonadThrow m) + => SnapshotBuildStrategy -> m (Loc Absolute Dir) +resolveSnapshotSandboxLoc _ = throwM $ NotYetImplemented "resolveSnapshotSandboxLoc" + +resolveSnapshotGhcLoc :: (MonadLogger m, MonadIO m, MonadThrow m) + => SnapshotBuildStrategy -> m (Loc Absolute Dir) +resolveSnapshotGhcLoc _ = throwM $ NotYetImplemented "resolveSnapshotGhcLoc" + +resolveSnapshotCabalLoc :: (MonadLogger m, MonadIO m, MonadThrow m) + => SnapshotBuildStrategy -> m (Loc Absolute Dir) +resolveSnapshotCabalLoc _ = throwM $ NotYetImplemented "resolveSnapshotCabalLoc" + +resolveCustomSandboxLoc :: (MonadLogger m, MonadIO m, MonadThrow m) + => Text -> m (Loc Absolute Dir) +resolveCustomSandboxLoc _ = throwM $ NotYetImplemented "resolveCustomSandboxLoc" + +resolveCustomGhcLoc :: (MonadLogger m, MonadIO m, MonadThrow m) + => Text -> m (Loc Absolute Dir) +resolveCustomGhcLoc _ = throwM $ NotYetImplemented "resolveCustomGhcLoc" + +resolveCustomCabalLoc :: (MonadLogger m, MonadIO m, MonadThrow m) + => Text -> m (Loc Absolute Dir) +resolveCustomCabalLoc _ = throwM $ NotYetImplemented "resolveCustomCabalLoc" diff --git a/src/Stackage/Environment.hs b/src/Stackage/Environment.hs new file mode 100644 index 00000000..16df71bd --- /dev/null +++ b/src/Stackage/Environment.hs @@ -0,0 +1,24 @@ +-- | Handling of environment variables, such as the PATH, +-- GHC_PACKAGE_SANDBOX, etc. +module Stackage.Environment where + +import Control.Monad.Catch +import Control.Monad.Logger hiding (Loc) +import Control.Monad.IO.Class +import Data.Map (Map) +import Data.Text (Text) + +import Stackage.Config + + +getEnvironmentVariables :: (MonadLogger m,MonadIO m,MonadThrow m) + => Config -> m (Map Text Text) +getEnvironmentVariables _ = throwM $ NotYetImplemented "getEnvironmentVariables" + +getPATH :: (MonadLogger m,MonadIO m,MonadThrow m) + => Config -> m Text +getPATH _ = throwM $ NotYetImplemented "getPATH" + +withConfiguredEnvironment :: (MonadLogger m,MonadIO m,MonadThrow m) + => Config -> (m a -> m a) -> m a +withConfiguredEnvironment _ _ = throwM $ NotYetImplemented "withConfiguredEnvironment" diff --git a/stackage-common.cabal b/stackage-common.cabal index 468eb241..749294fa 100644 --- a/stackage-common.cabal +++ b/stackage-common.cabal @@ -14,7 +14,13 @@ cabal-version: >=1.8 library hs-source-dirs: src/ ghc-options: -Wall -O2 + extensions: DeriveDataTypeable + RecordWildCards + DataKinds + OverloadedStrings exposed-modules: Stackage.Types + Stackage.Config + Stackage.Environment Stackage.GhcPkg Stackage.GhcPkgId Stackage.PackageName