Merge pull request #2916 from commercialhaskell/update-on-missing-sha

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

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,52 +196,79 @@ 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
             updateAllIndices menv
             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 ""
       | otherwise                    = Right idents
 
 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"
                 ]

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

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)

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

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

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