[WIP] Add feature to configure build plan download URL.

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

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"

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/"

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

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

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"
 

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
+      }

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