From 2a26ecf3e3960fd836c0c50439d71c72b351cc49 Mon Sep 17 00:00:00 2001 From: Yuji Yamamoto Date: Mon, 11 Apr 2016 07:40:59 +0900 Subject: [PATCH] :new: Add config build-plan-url-prefixes Related: https://github.com/commercialhaskell/stack/issues/1794 --- src/Stack/BuildPlan.hs | 16 +++++++---- src/Stack/Config.hs | 2 ++ src/Stack/Config/BuildPlanUrlPrefixes.hs | 18 ++++++++++++ src/Stack/Constants.hs | 19 ------------- src/Stack/Types.hs | 1 + src/Stack/Types/BuildPlanUrlPrefixes.hs | 35 ++++++++++++++++++++++++ src/Stack/Types/Config.hs | 13 +++++++++ stack.cabal | 2 ++ 8 files changed, 81 insertions(+), 25 deletions(-) create mode 100644 src/Stack/Config/BuildPlanUrlPrefixes.hs create mode 100644 src/Stack/Types/BuildPlanUrlPrefixes.hs diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 37950c967a..e6142b4a35 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -432,7 +432,7 @@ buildPlanFixes mbp = mbp -- | Load the 'BuildPlan' for the given snapshot. Will load from a local copy -- if available, otherwise downloading from Github. -loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasStackRoot env) +loadBuildPlan :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasStackRoot env, HasConfig env) => SnapName -> m BuildPlan loadBuildPlan name = do @@ -447,6 +447,7 @@ loadBuildPlan name = do Left e -> do $logDebug $ "Decoding build plan from file failed: " <> T.pack (show e) ensureDir (parent fp) + url <- buildBuildPlanUrl name file req <- parseUrl $ T.unpack url $logSticky $ "Downloading " <> renderSnapName name <> " build plan ..." $logDebug $ "Downloading build plan from: " <> url @@ -456,14 +457,17 @@ loadBuildPlan name = do where file = renderSnapName name <> ".yaml" - reponame = - case name of - LTS _ _ -> "lts-haskell" - Nightly _ -> "stackage-nightly" - url = rawGithubUrl "fpco" reponame "master" file handle404 (Status 404 _) _ _ = Just $ SomeException $ SnapshotNotFound name handle404 _ _ _ = Nothing +buildBuildPlanUrl :: (MonadReader env m, HasConfig env) => SnapName -> Text -> m Text +buildBuildPlanUrl name file = do + urlPrefixes <- asks (configBuildPlanUrlPrefixes . getConfig) + return $ + case name of + LTS _ _ -> buildPlanUrlPrefixesLts urlPrefixes <> "/" <> file + Nightly _ -> buildPlanUrlPrefixesNightly urlPrefixes <> "/" <> file + gpdPackages :: [GenericPackageDescription] -> Map PackageName Version gpdPackages gpds = Map.fromList $ map (fromCabalIdent . C.package . C.packageDescription) gpds diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index d3a578101e..21f235357d 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -78,6 +78,7 @@ import qualified Paths_stack as Meta import Safe (headMay) import Stack.BuildPlan import Stack.Config.Build +import Stack.Config.BuildPlanUrlPrefixes import Stack.Config.Docker import Stack.Config.Nix import Stack.Constants @@ -205,6 +206,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject c configLatestSnapshotUrl = fromMaybe "https://s3.amazonaws.com/haddock.stackage.org/snapshots.json" configMonoidLatestSnapshotUrl + configBuildPlanUrlPrefixes = buildPlanUrlPrefixesFromMonoid configMonoidBuildPlanUrlPrefixes configPackageIndices = fromMaybe [PackageIndex { indexName = IndexName "Hackage" diff --git a/src/Stack/Config/BuildPlanUrlPrefixes.hs b/src/Stack/Config/BuildPlanUrlPrefixes.hs new file mode 100644 index 0000000000..edbad83354 --- /dev/null +++ b/src/Stack/Config/BuildPlanUrlPrefixes.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Config.BuildPlanUrlPrefixes (buildPlanUrlPrefixesFromMonoid) where + +import Stack.Types +import Data.Maybe + +buildPlanUrlPrefixesFromMonoid + :: BuildPlanUrlPrefixesMonoid -> BuildPlanUrlPrefixes +buildPlanUrlPrefixesFromMonoid monoid = + BuildPlanUrlPrefixes + (fromMaybe defaultLts $ buildPlanUrlPrefixesMonoidLts monoid) + (fromMaybe defaultNightly $ buildPlanUrlPrefixesMonoidNightly monoid) + where + defaultLts = + "https://raw.githubusercontent.com/fpco/lts-haskell/master/" + defaultNightly = + "https://raw.githubusercontent.com/fpco/stackage-nightly/master/" diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 37f00f8f24..1b7f73f37f 100644 --- a/src/Stack/Constants.hs +++ b/src/Stack/Constants.hs @@ -11,7 +11,6 @@ module Stack.Constants ,haskellModuleExts ,imageStagingDir ,projectDockerSandboxDir - ,rawGithubUrl ,stackDotYaml ,stackRootEnvVar ,inContainerEnvVar @@ -45,7 +44,6 @@ import Data.Char (toUpper) import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Text (Text) -import qualified Data.Text as T import Path as FL import Prelude import Stack.Types.Compiler @@ -169,23 +167,6 @@ distRelativeDir = do $(mkRelDir "dist") platformAndCabal --- | Get a URL for a raw file on Github -rawGithubUrl :: Text -- ^ user/org name - -> Text -- ^ repo name - -> Text -- ^ branch name - -> Text -- ^ filename - -> Text -rawGithubUrl org repo branch file = T.concat - [ "https://raw.githubusercontent.com/" - , org - , "/" - , repo - , "/" - , branch - , "/" - , file - ] - -- | Docker sandbox from project root. projectDockerSandboxDir :: (MonadReader env m, HasConfig env) => Path Abs Dir -- ^ Project root diff --git a/src/Stack/Types.hs b/src/Stack/Types.hs index 26c1278984..8fb64b6dab 100644 --- a/src/Stack/Types.hs +++ b/src/Stack/Types.hs @@ -16,6 +16,7 @@ import Stack.Types.Docker as X import Stack.Types.Nix as X import Stack.Types.Image as X import Stack.Types.Build as X +import Stack.Types.BuildPlanUrlPrefixes as X import Stack.Types.Package as X import Stack.Types.Compiler as X import Stack.Types.Sig as X diff --git a/src/Stack/Types/BuildPlanUrlPrefixes.hs b/src/Stack/Types/BuildPlanUrlPrefixes.hs new file mode 100644 index 0000000000..35986b5aff --- /dev/null +++ b/src/Stack/Types/BuildPlanUrlPrefixes.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} + +module Stack.Types.BuildPlanUrlPrefixes where + +import Control.Applicative +import Data.Aeson.Extended +import Data.Text (Text) +import Data.Monoid + +data BuildPlanUrlPrefixes = BuildPlanUrlPrefixes + { buildPlanUrlPrefixesLts :: !Text + , buildPlanUrlPrefixesNightly :: !Text + } + deriving Show + +instance FromJSON (WithJSONWarnings BuildPlanUrlPrefixes) where + parseJSON = withObjectWarnings "BuildPlanUrlPrefixes" $ \o -> do + BuildPlanUrlPrefixes <$> o ..: "lts" <*> o ..: "nightly" + +data BuildPlanUrlPrefixesMonoid = BuildPlanUrlPrefixesMonoid + { buildPlanUrlPrefixesMonoidLts :: !(Maybe Text) + , buildPlanUrlPrefixesMonoidNightly :: !(Maybe Text) + } + deriving Show + +instance FromJSON (WithJSONWarnings BuildPlanUrlPrefixesMonoid) where + parseJSON = withObjectWarnings "BuildPlanUrlPrefixesMonoid" $ \o -> do + BuildPlanUrlPrefixesMonoid <$> o ..: "lts" <*> o ..: "nightly" + +instance Monoid BuildPlanUrlPrefixesMonoid where + mempty = BuildPlanUrlPrefixesMonoid Nothing Nothing + mappend l r = BuildPlanUrlPrefixesMonoid + { buildPlanUrlPrefixesMonoidLts = buildPlanUrlPrefixesMonoidLts l <|> buildPlanUrlPrefixesMonoidLts r + , buildPlanUrlPrefixesMonoidNightly = buildPlanUrlPrefixesMonoidNightly l <|> buildPlanUrlPrefixesMonoidNightly r + } diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index ebbc644893..1b1fa97b1e 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -164,6 +164,7 @@ import Path import qualified Paths_stack as Meta import {-# SOURCE #-} Stack.Constants (stackRootEnvVar) import Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName) +import Stack.Types.BuildPlanUrlPrefixes import Stack.Types.Compiler import Stack.Types.Docker import Stack.Types.Nix @@ -221,6 +222,10 @@ data Config = ,configLatestSnapshotUrl :: !Text -- ^ URL for a JSON file containing information on the latest -- snapshots available. + ,configBuildPlanUrlPrefixes :: !BuildPlanUrlPrefixes + -- ^ URL for a build plan files + -- A build plan name (e.g. lts5.9.yaml) is appended when downloading + -- the build plan actually. ,configPackageIndices :: ![PackageIndex] -- ^ Information on package indices. This is left biased, meaning that -- packages in an earlier index will shadow those in a later index. @@ -752,6 +757,8 @@ data ConfigMonoid = -- ^ See: 'configHideTHLoading' , configMonoidLatestSnapshotUrl :: !(Maybe Text) -- ^ See: 'configLatestSnapshotUrl' + , configMonoidBuildPlanUrlPrefixes :: !BuildPlanUrlPrefixesMonoid + -- ^ See: 'configBuildPlanUrlPrefixes , configMonoidPackageIndices :: !(Maybe [PackageIndex]) -- ^ See: 'configPackageIndices' , configMonoidSystemGHC :: !(Maybe Bool) @@ -824,6 +831,7 @@ instance Monoid ConfigMonoid where , configMonoidConnectionCount = Nothing , configMonoidHideTHLoading = Nothing , configMonoidLatestSnapshotUrl = Nothing + , configMonoidBuildPlanUrlPrefixes = mempty , configMonoidPackageIndices = Nothing , configMonoidSystemGHC = Nothing , configMonoidInstallGHC = Nothing @@ -862,6 +870,7 @@ instance Monoid ConfigMonoid where , configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r + , configMonoidBuildPlanUrlPrefixes = configMonoidBuildPlanUrlPrefixes l <> configMonoidBuildPlanUrlPrefixes r , configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r @@ -909,6 +918,7 @@ parseConfigMonoidJSON obj = do configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName + configMonoidBuildPlanUrlPrefixes <- jsonSubWarnings (obj ..:? configMonoidBuildPlanUrlPrefixesName ..!= mempty) configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName) configMonoidSystemGHC <- obj ..:? configMonoidSystemGHCName configMonoidInstallGHC <- obj ..:? configMonoidInstallGHCName @@ -1005,6 +1015,9 @@ configMonoidHideTHLoadingName = "hide-th-loading" configMonoidLatestSnapshotUrlName :: Text configMonoidLatestSnapshotUrlName = "latest-snapshot-url" +configMonoidBuildPlanUrlPrefixesName :: Text +configMonoidBuildPlanUrlPrefixesName = "build-plan-url-prefixes" + configMonoidPackageIndicesName :: Text configMonoidPackageIndicesName = "package-indices" diff --git a/stack.cabal b/stack.cabal index 058e5c784f..16d2bc39f7 100644 --- a/stack.cabal +++ b/stack.cabal @@ -80,6 +80,7 @@ library Stack.Clean Stack.Config Stack.Config.Build + Stack.Config.BuildPlanUrlPrefixes Stack.Config.Docker Stack.Config.Nix Stack.ConfigCmd @@ -112,6 +113,7 @@ library Stack.Types Stack.Types.Build Stack.Types.BuildPlan + Stack.Types.BuildPlanUrlPrefixes Stack.Types.Compiler Stack.Types.Config Stack.Types.Config.Build