diff --git a/ChangeLog.md b/ChangeLog.md index 4f96666bc4..202d33d715 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -16,6 +16,17 @@ Behavior changes: as well. If you manually specify a package index with only a Git URL, Git will still be used. See [#2780](https://github.com/commercialhaskell/stack/issues/2780) +* When you provide the `--resolver` argument to the `stack unpack` + command, any packages passed in by name only will be looked up in + the given snapshot instead of taking the latest version. For + example, `stack --resolver lts-7.14 unpack mtl` will get version + 2.2.1 of `mtl`, regardless of the latest version available in the + package indices. This will also force the same cabal file revision + to be used as is specified in the snapshot. + + Unpacking via a package identifier (e.g. `stack --resolver lts-7.14 + unpack mtl-2.2.1`) will ignore any settings in the snapshot and take + the most recent revision. Other enhancements: diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 20bf276a17..3faf91d8f2 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -285,11 +285,11 @@ addDeps allowMissing compilerVersion toCalc = do if allowMissing then do (missingNames, missingIdents, m) <- - resolvePackagesAllowMissing shaMap Set.empty + resolvePackagesAllowMissing menv Nothing shaMap Set.empty assert (Set.null missingNames) $ return (m, missingIdents) else do - m <- resolvePackages menv shaMap Set.empty + m <- resolvePackages menv Nothing shaMap Set.empty return (m, Set.empty) let byIndex = Map.fromListWith (++) $ flip map (Map.toList resolvedMap) $ \(ident, rp) -> diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 56fafaa7bf..f0972f4ab6 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -132,7 +132,7 @@ fetchPackages :: (StackMiniM env m, HasConfig env) -> Set PackageIdentifier -> m () fetchPackages menv idents' = do - resolved <- resolvePackages menv idents Set.empty + resolved <- resolvePackages menv Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved assert (Map.null alreadyUnpacked) (return ()) nowUnpacked <- fetchPackages' Nothing toFetch @@ -145,15 +145,16 @@ fetchPackages menv idents' = do -- | Intended to work for the command line command. unpackPackages :: (StackMiniM env m, HasConfig env) => EnvOverride + -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan -> FilePath -- ^ destination -> [String] -- ^ names or identifiers -> m () -unpackPackages menv dest input = do +unpackPackages menv mMiniBuildPlan dest input = do dest' <- resolveDir' dest (names, idents) <- case partitionEithers $ map parse input of ([], x) -> return $ partitionEithers x (errs, _) -> throwM $ CouldNotParsePackageSelectors errs - resolved <- resolvePackages menv + resolved <- resolvePackages menv mMiniBuildPlan (Map.fromList $ map (, Nothing) idents) (Set.fromList names) ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved @@ -186,7 +187,7 @@ unpackPackageIdents -> Map PackageIdentifier (Maybe GitSHA1) -> m (Map PackageIdentifier (Path Abs Dir)) unpackPackageIdents menv unpackDir mdistDir idents = do - resolved <- resolvePackages menv idents Set.empty + resolved <- resolvePackages menv Nothing idents Set.empty ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just unpackDir) resolved nowUnpacked <- fetchPackages' mdistDir toFetch return $ alreadyUnpacked <> nowUnpacked @@ -195,15 +196,17 @@ data ResolvedPackage = ResolvedPackage { rpCache :: !PackageCache , rpIndex :: !PackageIndex , rpGitSHA1 :: !(Maybe GitSHA1) + , rpMissingGitSHA :: !Bool } -- | Resolve a set of package names and identifiers into @FetchPackage@ values. resolvePackages :: (StackMiniM env m, HasConfig env) => EnvOverride + -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan -> Map PackageIdentifier (Maybe GitSHA1) -> Set PackageName -> m (Map PackageIdentifier ResolvedPackage) -resolvePackages menv idents0 names0 = do +resolvePackages menv mMiniBuildPlan idents0 names0 = do eres <- go case eres of Left _ -> do @@ -211,7 +214,7 @@ resolvePackages menv idents0 names0 = do go >>= either throwM return Right x -> return x where - go = r <$> resolvePackagesAllowMissing idents0 names0 + go = r <$> resolvePackagesAllowMissing menv mMiniBuildPlan idents0 names0 r (missingNames, missingIdents, idents) | not $ Set.null missingNames = Left $ UnknownPackageNames missingNames | not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents "" @@ -219,28 +222,53 @@ resolvePackages menv idents0 names0 = do resolvePackagesAllowMissing :: (StackMiniM env m, HasConfig env) - => Map PackageIdentifier (Maybe GitSHA1) + => EnvOverride + -> Maybe MiniBuildPlan -- ^ when looking up by name, take from this build plan + -> Map PackageIdentifier (Maybe GitSHA1) -> Set PackageName -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage) -resolvePackagesAllowMissing idents0 names0 = do - (caches, shaCaches) <- getPackageCaches - let versions = Map.fromListWith max $ map toTuple $ Map.keys caches - (missingNames, idents1) = partitionEithers $ map - (\name -> maybe (Left name ) (Right . PackageIdentifier name) - (Map.lookup name versions)) - (Set.toList names0) - let (missingIdents, resolved) = partitionEithers $ map (goIdent caches shaCaches) - $ Map.toList - $ idents0 <> Map.fromList (map (, Nothing) idents1) - return (Set.fromList missingNames, Set.fromList missingIdents, Map.fromList resolved) +resolvePackagesAllowMissing menv mMiniBuildPlan idents0 names0 = do + res@(_, _, resolved) <- inner + if any rpMissingGitSHA $ Map.elems resolved + then do + $logInfo "Missing some cabal revision files, updating indices" + updateAllIndices menv + inner + else return res where + inner = do + (caches, shaCaches) <- getPackageCaches + + let versions = Map.fromListWith max $ map toTuple $ Map.keys caches + + getNamed :: PackageName -> Maybe (PackageIdentifier, Maybe GitSHA1) + getNamed = + case mMiniBuildPlan of + Nothing -> getNamedFromIndex + Just mbp -> getNamedFromBuildPlan mbp + + getNamedFromBuildPlan mbp name = do + mpi <- Map.lookup name $ mbpPackages mbp + Just (PackageIdentifier name (mpiVersion mpi), mpiGitSHA1 mpi) + getNamedFromIndex name = fmap + (\ver -> (PackageIdentifier name ver, Nothing)) + (Map.lookup name versions) + + (missingNames, idents1) = partitionEithers $ map + (\name -> maybe (Left name) Right (getNamed name)) + (Set.toList names0) + let (missingIdents, resolved) = partitionEithers $ map (goIdent caches shaCaches) + $ Map.toList + $ idents0 <> Map.fromList idents1 + return (Set.fromList missingNames, Set.fromList missingIdents, Map.fromList resolved) + goIdent caches shaCaches (ident, mgitsha) = case Map.lookup ident caches of Nothing -> Left ident Just (index, cache) -> - let (index', cache', mgitsha') = + let (index', cache', mgitsha', missingGitSHA) = case mgitsha of - Nothing -> (index, cache, mgitsha) + Nothing -> (index, cache, mgitsha, False) Just gitsha -> case HashMap.lookup gitsha shaCaches of Just (index'', offsetSize) -> @@ -250,12 +278,27 @@ resolvePackagesAllowMissing idents0 names0 = do -- about this SHA, don't do -- any lookups later , Nothing + , False -- not missing, we found the Git SHA ) - Nothing -> (index, cache, mgitsha) + Nothing -> (index, cache, mgitsha, + case simplifyIndexLocation (indexLocation index) of + -- No surprise that there's + -- nothing in the cache about + -- the SHA, since this package + -- comes from a Git + -- repo. We'll look it up + -- later when we've opened up + -- the Git repo itself for + -- reading. + SILGit _ -> False + + -- Index using HTTP, so we're missing the Git SHA + SILHttp _ -> True) in Right (ident, ResolvedPackage { rpCache = cache' , rpIndex = index' , rpGitSHA1 = mgitsha' + , rpMissingGitSHA = missingGitSHA }) data ToFetch = ToFetch @@ -306,8 +349,9 @@ withCabalFiles name pkgs f = do $logWarn $ mconcat [ "Did not find .cabal file for " , T.pack $ packageIdentifierString ident - , " with Git SHA of " + , " with SHA of " , decodeUtf8 sha + , " in the Git repository" ] $logDebug (T.pack (show e)) goPkg h Nothing (ident, pc, Nothing, tf) @@ -320,7 +364,7 @@ withCabalFiles name pkgs f = do Just (GitSHA1 sha) -> $logWarn $ mconcat [ "Did not find .cabal file for " , T.pack $ packageIdentifierString ident - , " with Git SHA of " + , " with SHA of " , decodeUtf8 sha , " in tarball-based cache" ] diff --git a/src/Stack/Hoogle.hs b/src/Stack/Hoogle.hs index 12731a7e39..8cd37d2e48 100644 --- a/src/Stack/Hoogle.hs +++ b/src/Stack/Hoogle.hs @@ -98,8 +98,21 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go pathToHaddocks hoogleMinIdent = PackageIdentifier hooglePackageName hoogleMinVersion hooglePackageIdentifier <- - do (_,_,resolved) <- + do menv <- getMinimalEnvOverride + (_,_,resolved) <- resolvePackagesAllowMissing + menv + + -- FIXME this Nothing means "do not follow any + -- specific snapshot", which matches old + -- behavior. However, since introducing the + -- logic to pin a name to a package in a + -- snapshot, we may arguably want to ensure + -- that we're grabbing the version of Hoogle + -- present in the snapshot currently being + -- used. + Nothing + mempty (Set.fromList [hooglePackageName]) return diff --git a/src/Stack/PackageIndex.hs b/src/Stack/PackageIndex.hs index 56bf5f1805..0c62e96bcc 100644 --- a/src/Stack/PackageIndex.hs +++ b/src/Stack/PackageIndex.hs @@ -222,11 +222,10 @@ updateIndex menv index = do let name = indexName index logUpdate mirror = $logSticky $ "Updating package index " <> indexNameText (indexName index) <> " (mirrored at " <> mirror <> ") ..." git <- isGitInstalled menv - case (git, indexLocation index) of - (True, ILGit url) -> logUpdate url >> updateIndexGit menv name index url - (False, ILGit url) -> logUpdate url >> throwM (GitNotAvailable name) - (_, ILGitHttp _ url) -> logUpdate url >> updateIndexHTTP name index url - (_, ILHttp url) -> logUpdate url >> updateIndexHTTP name index url + case (git, simplifyIndexLocation $ indexLocation index) of + (True, SILGit url) -> logUpdate url >> updateIndexGit menv name index url + (False, SILGit url) -> logUpdate url >> throwM (GitNotAvailable name) + (_, SILHttp url) -> logUpdate url >> updateIndexHTTP name index url -- | Update the index Git repo and the index tarball updateIndexGit :: (StackMiniM env m, HasConfig env) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 3a9e568fe0..46fd346c69 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -641,7 +641,7 @@ upgradeCabal :: (StackM env m, HasConfig env, HasGHCVariant env) -> m () upgradeCabal menv wc = do let name = $(mkPackageName "Cabal") - rmap <- resolvePackages menv Map.empty (Set.singleton name) + rmap <- resolvePackages menv Nothing Map.empty (Set.singleton name) newest <- case Map.keys rmap of [] -> error "No Cabal library found in index, cannot upgrade" diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index c3058b2929..517f5ec240 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1172,10 +1172,9 @@ configPackageIndexRepo name = do case filter (\p -> indexName p == name) indices of [index] -> do let murl = - case indexLocation index of - ILGit x -> Just x - ILHttp _ -> Nothing - ILGitHttp x _ -> Just x + case simplifyIndexLocation $ indexLocation index of + SILGit x -> Just x + SILHttp _ -> Nothing case murl of Nothing -> return Nothing Just url -> do diff --git a/src/Stack/Types/PackageIndex.hs b/src/Stack/Types/PackageIndex.hs index 5646eb7f29..939bfcbdae 100644 --- a/src/Stack/Types/PackageIndex.hs +++ b/src/Stack/Types/PackageIndex.hs @@ -16,6 +16,8 @@ module Stack.Types.PackageIndex , IndexName(..) , indexNameText , IndexLocation(..) + , SimplifiedIndexLocation (..) + , simplifyIndexLocation ) where import Control.DeepSeq (NFData) @@ -108,6 +110,15 @@ instance FromJSON IndexName where data IndexLocation = ILGit !Text | ILHttp !Text | ILGitHttp !Text !Text deriving (Show, Eq, Ord) +-- | Simplified 'IndexLocation', which will either be a Git repo or HTTP URL. +data SimplifiedIndexLocation = SILGit !Text | SILHttp !Text + deriving (Show, Eq, Ord) + +simplifyIndexLocation :: IndexLocation -> SimplifiedIndexLocation +simplifyIndexLocation (ILGit t) = SILGit t +simplifyIndexLocation (ILHttp t) = SILHttp t +-- Prefer HTTP over Git +simplifyIndexLocation (ILGitHttp _ t) = SILHttp t -- | Information on a single package index data PackageIndex = PackageIndex diff --git a/src/main/Main.hs b/src/main/Main.hs index b36dd515f0..6f93681e5c 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -2,6 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -54,6 +55,7 @@ import Path.IO import qualified Paths_stack as Meta import Prelude hiding (pi, mapM) import Stack.Build +import Stack.BuildPlan import Stack.Clean (CleanOpts, clean) import Stack.Config import Stack.ConfigCmd as ConfigCmd @@ -94,6 +96,7 @@ import Stack.Solver (solveExtraDeps) import Stack.Types.Version import Stack.Types.Config import Stack.Types.Compiler +import Stack.Types.Resolver import Stack.Types.StackT import Stack.Upgrade import qualified Stack.Upload as Upload @@ -624,7 +627,19 @@ uninstallCmd _ go = withConfigAndLock go $ do unpackCmd :: [String] -> GlobalOpts -> IO () unpackCmd names go = withConfigAndLock go $ do menv <- getMinimalEnvOverride - Stack.Fetch.unpackPackages menv "." names + mMiniBuildPlan <- + case globalResolver go of + Nothing -> return Nothing + Just ar -> fmap Just $ do + r <- makeConcreteResolver ar + case r of + ResolverSnapshot snapName -> do + config <- view configL + miniConfig <- loadMiniConfig config + runInnerStackT miniConfig (loadMiniBuildPlan snapName) + ResolverCompiler _ -> error "unpack does not work with compiler resolvers" + ResolverCustom _ _ -> error "unpack does not work with custom resolvers" + Stack.Fetch.unpackPackages menv mMiniBuildPlan "." names -- | Update the package index updateCmd :: () -> GlobalOpts -> IO ()