diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 4b1088af23..bfd11e36b6 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -211,7 +211,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 index 71305f8031..6201e4be3d 100644 --- 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]) -- ^ 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 @@ -404,6 +408,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, MonadCatch 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, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m) @@ -883,11 +905,20 @@ shadowMiniBuildPlan (MiniBuildPlan cv pkgs0 allowNewer) shadowed = Just False -> Right Nothing -> assert False Right -parseCustomMiniBuildPlan :: (MonadIO m, MonadCatch 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, MonadCatch 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 @@ -896,36 +927,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 - (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 @@ -944,9 +972,45 @@ 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 + 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, MonadCatch 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])) + addFlagsAndOpts (PackageIdentifier name ver) = + ( name + , ( ver + , Map.findWithDefault Map.empty name flags + -- NOTE: similar to 'allGhcOptions' in Stack.Types.Build + , ghcOptionsFor name ghcOptions + ) + ) + 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 index eebadab5db..57e01f23b7 100644 --- 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 index c6959479af..888734d169 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -482,7 +482,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 index 4fdc710666..af64d10a40 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1719,34 +1719,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 index 011833fb1d..67bea2992d 100644 --- 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 new file mode 100644 index 0000000000..6384950f91 --- /dev/null +++ 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 new file mode 100644 index 0000000000..718ab78970 --- /dev/null +++ b/test/integration/tests/1265-extensible-snapshots/files/snapshot-modify-lts.yaml @@ -0,0 +1,3 @@ +resolver: lts-5.11 +drop-packages: +- zlib \ No newline at end of file diff --git a/test/integration/tests/1265-extensible-snapshots/files/snapshot.yaml b/test/integration/tests/1265-extensible-snapshots/files/snapshot.yaml index 5cbad1de3c..c4eaa20dd5 100644 --- 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 \ No newline at end of file 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 new file mode 100644 index 0000000000..6938cb2afa --- /dev/null +++ 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: [] \ No newline at end of file