🆕 Add config build-plan-url-prefixes

Related: commercialhaskell#1794
igrep · Apr 12, 2016 · 2a26ecf · 2a26ecf
1 parent 8d1146b
commit 2a26ecf
Show file tree

Hide file tree

Showing 8 changed files with 81 additions and 25 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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