Implement extensible snapshots #863

mgsloan · mgsloan · commit 9be58d79663d · 2016-05-04T16:18:52.000-07:00
diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs
@@ -213,7 +213,7 @@ parseTargetsFromBuildOpts needTargets boptscli = do
                     }
             ResolverCustom _ url -> do
                 stackYamlFP <- asks $ bcStackYaml . getBuildConfig
-                parseCustomMiniBuildPlan stackYamlFP url
+                parseCustomMiniBuildPlan (Just stackYamlFP) url
     rawLocals <- getLocalPackageViews
     workingDir <- getCurrentDir
 
diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs
@@ -95,6 +95,7 @@ data BuildPlanException
         (Map PackageName (Maybe Version, Set PackageName)) -- truly unknown
         (Map PackageName (Set PackageIdentifier)) -- shadowed
     | SnapshotNotFound SnapName
+    | FilepathInDownloadedSnapshot T.Text
     deriving (Typeable)
 instance Exception BuildPlanException
 instance Show BuildPlanException where
@@ -174,6 +175,11 @@ instance Show BuildPlanException where
                       $ Set.toList
                       $ Set.unions
                       $ Map.elems shadowed
+    show (FilepathInDownloadedSnapshot url) = unlines
+        [ "Downloaded snapshot specified a 'resolver: { location: filepath }' "
+        , "field, but filepaths are not allowed in downloaded snapshots.\n"
+        , "Filepath specified: " ++ T.unpack url
+        ]
 
 -- | Determine the necessary packages to install to have the given set of
 -- packages available.
@@ -221,8 +227,6 @@ toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager
                 -> Map PackageName (Version, Map FlagName Bool, [Text], Maybe GitSHA1) -- ^ non-core packages
                 -> m MiniBuildPlan
 toMiniBuildPlan compilerVersion requireAllowNewer corePackages packages = do
-    $logInfo "Caching build plan"
-
     -- Determine the dependencies of all of the packages in the build plan. We
     -- handle core packages specially, because some of them will not be in the
     -- package index. For those, we allow missing packages to exist, and then
@@ -409,6 +413,24 @@ getToolMap mbp =
       $ Set.toList
       $ mpiExes mpi
 
+loadResolver
+    :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadMask m)
+    => Maybe (Path Abs File)
+    -> Resolver
+    -> m MiniBuildPlan
+loadResolver mconfigPath resolver =
+    case resolver of
+        ResolverSnapshot snap -> loadMiniBuildPlan snap
+        -- TODO(mgsloan): Not sure what this FIXME means
+        -- FIXME instead of passing the stackYaml dir we should maintain
+        -- the file URL in the custom resolver always relative to stackYaml.
+        ResolverCustom _ url -> parseCustomMiniBuildPlan mconfigPath url
+        ResolverCompiler compiler -> return MiniBuildPlan
+            { mbpCompilerVersion = compiler
+            , mbpPackages = mempty
+            , mbpAllowNewer = False
+            }
+
 -- | Load up a 'MiniBuildPlan', preferably from cache
 loadMiniBuildPlan
     :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadMask m)
@@ -892,11 +914,20 @@ shadowMiniBuildPlan (MiniBuildPlan cv pkgs0 allowNewer) shadowed =
                 Just False -> Right
                 Nothing -> assert False Right
 
-parseCustomMiniBuildPlan :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)
-                         => Path Abs File -- ^ stack.yaml file location
-                         -> T.Text -> m MiniBuildPlan
-parseCustomMiniBuildPlan stackYamlFP url0 = do
-    yamlFP <- getYamlFP url0
+parseCustomMiniBuildPlan
+    :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m)
+    => Maybe (Path Abs File) -- ^ Root directory for when url is a filepath
+    -> T.Text
+    -> m MiniBuildPlan
+parseCustomMiniBuildPlan mconfigPath url0 = do
+    $logDebug $ "Loading " <> url0 <> " build plan"
+    eyamlFP <- getYamlFP url0
+    let yamlFP = either id id eyamlFP
+
+    -- FIXME: determine custom snapshot path based on contents. Ideally,
+    -- use a hash scheme that ignores formatting differences (works on
+    -- the data), so that an implicit snapshot (TBD) will hash to the
+    -- same thing as a custom snapshot.
 
     yamlBS <- liftIO $ S.readFile $ toFilePath yamlFP
     let yamlHash = S8.unpack $ B16.encode $ SHA256.hash yamlBS
@@ -905,36 +936,33 @@ parseCustomMiniBuildPlan stackYamlFP url0 = do
     let binaryFP = customPlanDir </> $(mkRelDir "bin") </> binaryFilename
 
     taggedDecodeOrLoad binaryFP $ do
-        WithJSONWarnings result warnings <-
+        WithJSONWarnings (cs0, mresolver) warnings <-
              either (throwM . ParseCustomSnapshotException url0) return $
              decodeEither' yamlBS
-        logJSONWarnings (toFilePath yamlFP) warnings
-        let (CustomSnapshot
-                mcompilerVersion
-                packages
-                (PackageFlags flags)
-                ghcOptions
-                allowNewer) = result
-        let addFlags :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool, [Text]))
-            addFlags (PackageIdentifier name ver) =
-                ( name
-                , ( ver
-                  , Map.findWithDefault Map.empty name flags
-                  -- NOTE: similar to 'allGhcOptions' in Stack.Types.Build
-                  , ghcOptionsFor name ghcOptions
-                  )
-                )
-        case mcompilerVersion of
-            Just compilerVersion ->
-                toMiniBuildPlan
-                    compilerVersion
-                    (fromMaybe False allowNewer)
-                    Map.empty
-                    (fmap addGitSHA $ Map.fromList $ map addFlags $ Set.toList packages)
-            Nothing -> do
-                -- TODO: proper exception type
+        logJSONWarnings (T.unpack url0) warnings
+        case (mresolver, csCompilerVersion cs0) of
+            (Nothing, Nothing) ->
                 fail $ "Failed to load custom snapshot at " ++
-                    T.unpack url0 ++ ", because no compiler is specified."
+                    T.unpack url0 ++
+                    ", because no 'compiler' or 'resolver' is specified."
+            (Nothing, Just cv) ->
+                applyCustomSnapshot cs0 MiniBuildPlan
+                    { mbpCompilerVersion = cv
+                    , mbpPackages = mempty
+                    , mbpAllowNewer = False
+                    }
+            -- Even though we ignore the compiler version here, it gets
+            -- used due to applyCustomSnapshot
+            (Just resolver, _) -> do
+                -- Load referenced resolver. If the custom snapshot is
+                -- stored at a user location, then allow relative
+                -- filepath custom snapshots.
+                mbp <- loadResolver customFile resolver
+                applyCustomSnapshot cs0 mbp
+              where
+                customFile = case eyamlFP of
+                    Left _ -> Nothing
+                    Right fp -> Just fp
   where
     getCustomPlanDir = do
         root <- asks $ configStackRoot . getConfig
@@ -953,12 +981,47 @@ parseCustomMiniBuildPlan stackYamlFP url0 = do
 
         let cacheFP = customPlanDir </> $(mkRelDir "yaml") </> hashFP
         _ <- download req cacheFP
-        return cacheFP
-
-    getYamlFPFromFile url = do
-        fp <- liftIO $ D.canonicalizePath $ toFilePath (parent stackYamlFP) FP.</> T.unpack (fromMaybe url $
-            T.stripPrefix "file://" url <|> T.stripPrefix "file:" url)
-        parseAbsFile fp
-
-    -- we add a Nothing since we don't yet collect Git SHAs for custom snapshots
-    addGitSHA (x, y, z) = (x, y, z, Nothing)
+        return (Left cacheFP)
+
+    getYamlFPFromFile url =
+        case mconfigPath of
+           Nothing -> throwM $ FilepathInDownloadedSnapshot url
+           Just configPath -> do
+               fp <- liftIO $ D.canonicalizePath $ toFilePath (parent configPath) FP.</> T.unpack (fromMaybe url $
+                   T.stripPrefix "file://" url <|> T.stripPrefix "file:" url)
+               Right <$> parseAbsFile fp
+
+applyCustomSnapshot
+    :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadMask m)
+    => CustomSnapshot
+    -> MiniBuildPlan
+    -> m MiniBuildPlan
+applyCustomSnapshot cs mbp0 = do
+    let CustomSnapshot mcompilerVersion
+                       packages
+                       dropPackages
+                       (PackageFlags flags)
+                       ghcOptions
+                       mallowNewer
+            = cs
+        addFlagsAndOpts :: PackageIdentifier -> (PackageName, (Version, Map FlagName Bool, [Text], Maybe GitSHA1))
+        addFlagsAndOpts (PackageIdentifier name ver) =
+            ( name
+            , ( ver
+              , Map.findWithDefault Map.empty name flags
+              -- NOTE: similar to 'allGhcOptions' in Stack.Types.Build
+              , ghcOptionsFor name ghcOptions
+              -- we add a Nothing since we don't yet collect Git SHAs for custom snapshots
+              , Nothing
+              )
+            )
+        packageMap = Map.fromList $ map addFlagsAndOpts $ Set.toList packages
+        cv = fromMaybe (mbpCompilerVersion mbp0) mcompilerVersion
+        packages0 =
+             mbpPackages mbp0 `Map.difference` (Map.fromSet (\_ -> ()) dropPackages)
+    mbp1 <- toMiniBuildPlan cv False mempty packageMap
+    return $ MiniBuildPlan
+        { mbpCompilerVersion = cv
+        , mbpPackages = Map.union (mbpPackages mbp1) packages0
+        , mbpAllowNewer = fromMaybe (mbpAllowNewer mbp0) mallowNewer
+        }
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -520,7 +520,7 @@ loadBuildConfig mproject config mresolver mcompiler = do
                     mbp <- runReaderT (loadMiniBuildPlan snapName) miniConfig
                     return $ mbpCompilerVersion mbp
                 ResolverCustom _name url -> do
-                    mbp <- runReaderT (parseCustomMiniBuildPlan stackYamlFP url) miniConfig
+                    mbp <- runReaderT (parseCustomMiniBuildPlan (Just stackYamlFP) url) miniConfig
                     return $ mbpCompilerVersion mbp
                 ResolverCompiler wantedCompiler -> return wantedCompiler
 
diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs
@@ -481,7 +481,7 @@ getResolverConstraints stackYaml resolver =
         ResolverCustom _ url -> do
             -- FIXME instead of passing the stackYaml dir we should maintain
             -- the file URL in the custom resolver always relative to stackYaml.
-            mbp <- parseCustomMiniBuildPlan stackYaml url
+            mbp <- parseCustomMiniBuildPlan (Just stackYaml) url
             return (mbpCompilerVersion mbp, mbpConstraints mbp)
         ResolverCompiler compiler ->
             return (compiler, Map.empty)
diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -1659,34 +1659,22 @@ data DockerUser = DockerUser
 data CustomSnapshot = CustomSnapshot
     { csCompilerVersion :: !(Maybe CompilerVersion)
     , csPackages :: !(Set PackageIdentifier)
+    , csDropPackages :: !(Set PackageName)
     , csFlags :: !PackageFlags
     , csGhcOptions :: !GhcOptions
     , csAllowNewer :: !(Maybe Bool)
     }
 
-instance FromJSON (WithJSONWarnings CustomSnapshot) where
-    parseJSON = withObjectWarnings "CustomSnapshot" $ \o -> CustomSnapshot
-        <$> o ..:? "compiler"
-        <*> o ..:? "packages" ..!= mempty
-        <*> o ..:? "flags" ..!= mempty
-        <*> o ..:? configMonoidGhcOptionsName ..!= mempty
-        <*> o ..:? configMonoidAllowNewerName
-
-instance Monoid CustomSnapshot where
-    mempty = CustomSnapshot
-        { csCompilerVersion = Nothing
-        , csPackages = mempty
-        , csFlags = mempty
-        , csGhcOptions = mempty
-        , csAllowNewer = Nothing
-        }
-    mappend l r = CustomSnapshot
-        { csCompilerVersion = csCompilerVersion l <|> csCompilerVersion r
-        , csPackages = csPackages l <> csPackages r
-        , csFlags = csFlags l <> csFlags r
-        , csGhcOptions = csGhcOptions l <> csGhcOptions r
-        , csAllowNewer = csAllowNewer l <|> csAllowNewer r
-        }
+instance FromJSON (WithJSONWarnings (CustomSnapshot, Maybe Resolver)) where
+    parseJSON = withObjectWarnings "CustomSnapshot" $ \o -> (,)
+        <$> (CustomSnapshot
+            <$> o ..:? "compiler"
+            <*> o ..:? "packages" ..!= mempty
+            <*> o ..:? "drop-packages" ..!= mempty
+            <*> o ..:? "flags" ..!= mempty
+            <*> o ..:? configMonoidGhcOptionsName ..!= mempty
+            <*> o ..:? configMonoidAllowNewerName)
+        <*> jsonSubWarningsT (o ..:? "resolver")
 
 newtype GhcOptions = GhcOptions
     { unGhcOptions :: Map (Maybe PackageName) [Text] }
diff --git a/test/integration/tests/1265-extensible-snapshots/Main.hs b/test/integration/tests/1265-extensible-snapshots/Main.hs
@@ -1,4 +1,8 @@
 import StackTest
 
 main :: IO ()
-main = stack ["build", "SHA"]
+main = do
+    stack ["build", "async"]
+    stackErr ["build", "zlib-bindings"]
+    stack ["build", "--stack-yaml", "stack-modify-lts.yaml", "async"]
+    stackErr ["build", "--stack-yaml", "stack-modify-lts.yaml", "zlib-bindings"]
diff --git a/test/integration/tests/1265-extensible-snapshots/files/snapshot-2.yaml b/test/integration/tests/1265-extensible-snapshots/files/snapshot-2.yaml
@@ -0,0 +1,9 @@
+resolver: ghc-7.10
+packages:
+- stm-2.4.4.1
+- async-2.1.0
+- zlib-0.6.1.1
+# FIXME: test these here
+flags: {}
+ghc-options: {}
+allow-newer: true
diff --git a/test/integration/tests/1265-extensible-snapshots/files/snapshot-modify-lts.yaml b/test/integration/tests/1265-extensible-snapshots/files/snapshot-modify-lts.yaml
@@ -0,0 +1,3 @@
+resolver: lts-5.11
+drop-packages:
+- zlib
diff --git a/test/integration/tests/1265-extensible-snapshots/files/snapshot.yaml b/test/integration/tests/1265-extensible-snapshots/files/snapshot.yaml
@@ -1,15 +1,7 @@
-compiler: ghc-7.10
+resolver:
+    name: test-snapshot-2
+    location: snapshot-2.yaml
 packages:
-# Just the first thing I found via github search that conditionally adds exports
-# based on flags.
-#
-# TODO: check that the decoder interface is present (and that this flag matters)
-- SHA-1.6.4
-- binary-0.8.0.0
-flags:
-    SHA:
-        DecoderInterface: true
-# FIXME: test this better
-ghc-options:
-    SHA: "-Wall"
-allow-newer: true
+- microlens-0.4.3.0
+drop-packages:
+- zlib
diff --git a/test/integration/tests/1265-extensible-snapshots/files/stack-modify-lts.yaml b/test/integration/tests/1265-extensible-snapshots/files/stack-modify-lts.yaml
@@ -0,0 +1,4 @@
+resolver:
+    name: snapshot-modify-lts
+    location: snapshot-modify-lts.yaml
+packages: []

Original file line number	Diff line number	Diff line change
`@@ -213,7 +213,7 @@ parseTargetsFromBuildOpts needTargets boptscli = do`
`213`	`213`	`}`
`214`	`214`	`ResolverCustom _ url -> do`
`215`	`215`	`stackYamlFP <- asks $ bcStackYaml . getBuildConfig`
`216`		`- parseCustomMiniBuildPlan stackYamlFP url`
	`216`	`+ parseCustomMiniBuildPlan (Just stackYamlFP) url`
`217`	`217`	`rawLocals <- getLocalPackageViews`
`218`	`218`	`workingDir <- getCurrentDir`
`219`	`219`
Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+resolver: lts-5.11`
	`2`	`+drop-packages:`
	`3`	`+- zlib`