diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 37950c967a..d6d34911f6 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 + urls <- asks (configUrls . getConfig) + return $ + case name of + LTS _ _ -> urlsLtsBuildPlans urls <> "/" <> file + Nightly _ -> urlsNightlyBuildPlans urls <> "/" <> 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..391f349ccc 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.Urls 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 + configUrls = urlsFromMonoid configMonoidUrls configPackageIndices = fromMaybe [PackageIndex { indexName = IndexName "Hackage" diff --git a/src/Stack/Config/Urls.hs b/src/Stack/Config/Urls.hs new file mode 100644 index 0000000000..81ee90d023 --- /dev/null +++ b/src/Stack/Config/Urls.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Config.Urls (urlsFromMonoid) where + +import Stack.Types +import Data.Maybe + +urlsFromMonoid :: UrlsMonoid -> Urls +urlsFromMonoid monoid = + Urls + (fromMaybe defaultLatestSnapshot $ urlsMonoidLatestSnapshot monoid) + (fromMaybe defaultLtsBuildPlans $ urlsMonoidLtsBuildPlans monoid) + (fromMaybe defaultNightlyBuildPlans $ urlsMonoidNightlyBuildPlans monoid) + where + defaultLatestSnapshot = + "https://www.stackage.org/download/snapshots.json" + defaultLtsBuildPlans = + "https://raw.githubusercontent.com/fpco/lts-haskell/master/" + defaultNightlyBuildPlans = + "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..744f448367 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.Urls 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/Config.hs b/src/Stack/Types/Config.hs index ebbc644893..13ff3cfc51 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.Urls import Stack.Types.Compiler import Stack.Types.Docker import Stack.Types.Nix @@ -221,6 +222,12 @@ data Config = ,configLatestSnapshotUrl :: !Text -- ^ URL for a JSON file containing information on the latest -- snapshots available. + ,configUrls :: !Urls + -- ^ URLs for other files used by stack. + -- TODO: Better document + -- e.g. The latest snapshot file. + -- 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 +759,8 @@ data ConfigMonoid = -- ^ See: 'configHideTHLoading' , configMonoidLatestSnapshotUrl :: !(Maybe Text) -- ^ See: 'configLatestSnapshotUrl' + , configMonoidUrls :: !UrlsMonoid + -- ^ See: 'configUrls , configMonoidPackageIndices :: !(Maybe [PackageIndex]) -- ^ See: 'configPackageIndices' , configMonoidSystemGHC :: !(Maybe Bool) @@ -824,6 +833,7 @@ instance Monoid ConfigMonoid where , configMonoidConnectionCount = Nothing , configMonoidHideTHLoading = Nothing , configMonoidLatestSnapshotUrl = Nothing + , configMonoidUrls = mempty , configMonoidPackageIndices = Nothing , configMonoidSystemGHC = Nothing , configMonoidInstallGHC = Nothing @@ -862,6 +872,7 @@ instance Monoid ConfigMonoid where , configMonoidConnectionCount = configMonoidConnectionCount l <|> configMonoidConnectionCount r , configMonoidHideTHLoading = configMonoidHideTHLoading l <|> configMonoidHideTHLoading r , configMonoidLatestSnapshotUrl = configMonoidLatestSnapshotUrl l <|> configMonoidLatestSnapshotUrl r + , configMonoidUrls = configMonoidUrls l <> configMonoidUrls r , configMonoidPackageIndices = configMonoidPackageIndices l <|> configMonoidPackageIndices r , configMonoidSystemGHC = configMonoidSystemGHC l <|> configMonoidSystemGHC r , configMonoidInstallGHC = configMonoidInstallGHC l <|> configMonoidInstallGHC r @@ -909,6 +920,7 @@ parseConfigMonoidJSON obj = do configMonoidConnectionCount <- obj ..:? configMonoidConnectionCountName configMonoidHideTHLoading <- obj ..:? configMonoidHideTHLoadingName configMonoidLatestSnapshotUrl <- obj ..:? configMonoidLatestSnapshotUrlName + configMonoidUrls <- jsonSubWarnings (obj ..:? configMonoidUrlsName ..!= mempty) configMonoidPackageIndices <- jsonSubWarningsTT (obj ..:? configMonoidPackageIndicesName) configMonoidSystemGHC <- obj ..:? configMonoidSystemGHCName configMonoidInstallGHC <- obj ..:? configMonoidInstallGHCName @@ -1005,6 +1017,9 @@ configMonoidHideTHLoadingName = "hide-th-loading" configMonoidLatestSnapshotUrlName :: Text configMonoidLatestSnapshotUrlName = "latest-snapshot-url" +configMonoidUrlsName :: Text +configMonoidUrlsName = "urls" + configMonoidPackageIndicesName :: Text configMonoidPackageIndicesName = "package-indices" diff --git a/src/Stack/Types/Urls.hs b/src/Stack/Types/Urls.hs new file mode 100644 index 0000000000..46de0c5c8d --- /dev/null +++ b/src/Stack/Types/Urls.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} + +module Stack.Types.Urls where + +import Control.Applicative +import Data.Aeson.Extended +import Data.Text (Text) +import Data.Monoid + +data Urls = Urls + { urlsLatestSnapshot :: !Text + , urlsLtsBuildPlans :: !Text + , urlsNightlyBuildPlans :: !Text + } + deriving Show + +-- TODO: Really need this instance? +instance FromJSON (WithJSONWarnings Urls) where + parseJSON = withObjectWarnings "Urls" $ \o -> do + Urls + <$> o ..: "latest-snapshot" + <*> o ..: "lts-build-plans" + <*> o ..: "nightly-build-plans" + +data UrlsMonoid = UrlsMonoid + { urlsMonoidLatestSnapshot :: !(Maybe Text) + , urlsMonoidLtsBuildPlans :: !(Maybe Text) + , urlsMonoidNightlyBuildPlans :: !(Maybe Text) + } + deriving Show + +instance FromJSON (WithJSONWarnings UrlsMonoid) where + parseJSON = withObjectWarnings "UrlsMonoid" $ \o -> do + UrlsMonoid + <$> o ..: "latest-snapshot" + <*> o ..: "lts-build-plans" + <*> o ..: "nightly-build-plans" + +instance Monoid UrlsMonoid where + mempty = UrlsMonoid Nothing Nothing Nothing + mappend l r = UrlsMonoid + { urlsMonoidLatestSnapshot = urlsMonoidLatestSnapshot l <|> urlsMonoidLatestSnapshot r + , urlsMonoidLtsBuildPlans = urlsMonoidLtsBuildPlans l <|> urlsMonoidLtsBuildPlans r + , urlsMonoidNightlyBuildPlans = urlsMonoidNightlyBuildPlans l <|> urlsMonoidNightlyBuildPlans r + } diff --git a/stack.cabal b/stack.cabal index 058e5c784f..83151f5de4 100644 --- a/stack.cabal +++ b/stack.cabal @@ -80,6 +80,7 @@ library Stack.Clean Stack.Config Stack.Config.Build + Stack.Config.Urls Stack.Config.Docker Stack.Config.Nix Stack.ConfigCmd @@ -112,6 +113,7 @@ library Stack.Types Stack.Types.Build Stack.Types.BuildPlan + Stack.Types.Urls Stack.Types.Compiler Stack.Types.Config Stack.Types.Config.Build