Update on missing SHA

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:
 

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 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) ->

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
@@ -200,38 +201,54 @@ data ResolvedPackage = ResolvedPackage
 -- | 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
             updateAllIndices menv
             go >>= either throwM return
         Right x -> return x
   where
-    go = r <$> resolvePackagesAllowMissing idents0 names0
+    go = r <$> resolvePackagesAllowMissing mMiniBuildPlan idents0 names0
     r (missingNames, missingIdents, idents)
       | not $ Set.null missingNames  = Left $ UnknownPackageNames       missingNames
       | not $ Set.null missingIdents = Left $ UnknownPackageIdentifiers missingIdents ""
       | otherwise                    = Right idents
 
 resolvePackagesAllowMissing
     :: (StackMiniM env m, HasConfig env)
-    => Map PackageIdentifier (Maybe GitSHA1)
+    => 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
+resolvePackagesAllowMissing mMiniBuildPlan idents0 names0 = 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 . PackageIdentifier name)
-                (Map.lookup name versions))
+            (\name -> maybe (Left name) Right (getNamed name))
             (Set.toList names0)
     let (missingIdents, resolved) = partitionEithers $ map (goIdent caches shaCaches)
                                   $ Map.toList
-                                  $ idents0 <> Map.fromList (map (, Nothing) idents1)
+                                  $ idents0 <> Map.fromList idents1
     return (Set.fromList missingNames, Set.fromList missingIdents, Map.fromList resolved)
   where
     goIdent caches shaCaches (ident, mgitsha) =

src/Stack/Hoogle.hs

@@ -100,6 +100,17 @@ hoogleCmd (args,setup,rebuild) go = withBuildConfig go pathToHaddocks
         hooglePackageIdentifier <-
             do (_,_,resolved) <-
                    resolvePackagesAllowMissing
+
+                       -- 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

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"

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 ()