Actually grab .cabal files via Git SHA when possible

src/Stack/Build/Execute.hs

@@ -775,7 +775,8 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
             TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp)
             TTUpstream package _ gitSHA1 -> do
                 mdist <- liftM Just distRelativeDir
-                m <- unpackPackageIdents eeEnvOverride eeTempDir mdist $ Set.singleton taskProvides
+                m <- unpackPackageIdents eeEnvOverride eeTempDir mdist
+                   $ Map.singleton taskProvides gitSHA1
                 case Map.toList m of
                     [(ident, dir)]
                         | ident == taskProvides -> do

src/Stack/Fetch.hs

@@ -34,6 +34,7 @@ import           Control.Concurrent.STM         (TVar, atomically, modifyTVar,
                                                  newTVarIO, readTVar,
                                                  readTVarIO, writeTVar)
 import           Control.Exception              (assert)
+import           Control.Exception.Enclosed     (tryIO)
 import           Control.Monad                  (join, liftM, unless, void,
                                                  when)
 import           Control.Monad.Catch
@@ -49,6 +50,10 @@ import qualified Data.ByteString.Lazy           as L
 import           Data.Either                    (partitionEithers)
 import qualified Data.Foldable                  as F
 import           Data.Function                  (fix)
+import qualified Data.Git                       as Git
+import qualified Data.Git.Ref                   as Git
+import qualified Data.Git.Storage               as Git
+import qualified Data.Git.Storage.Object        as Git
 import           Data.List                      (intercalate)
 import           Data.List.NonEmpty             (NonEmpty)
 import qualified Data.List.NonEmpty             as NE
@@ -58,6 +63,7 @@ import           Data.Maybe                     (maybeToList, catMaybes)
 import           Data.Monoid                    ((<>))
 import           Data.Set                       (Set)
 import qualified Data.Set                       as Set
+import           Data.String                    (fromString)
 import qualified Data.Text                      as T
 import           Data.Text.Encoding             (decodeUtf8)
 import           Data.Typeable                  (Typeable)
@@ -74,7 +80,8 @@ import           System.FilePath                ((<.>))
 import qualified System.FilePath                as FP
 import           System.IO                      (IOMode (ReadMode),
                                                  SeekMode (AbsoluteSeek), hSeek,
-                                                 withBinaryFile)
+                                                 withBinaryFile, openBinaryFile,
+                                                 hClose)
 import           System.PosixCompat             (setFileMode)
 import           Text.EditDistance              as ED
 
@@ -122,12 +129,16 @@ fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpMa
               => EnvOverride
               -> Set PackageIdentifier
               -> m ()
-fetchPackages menv idents = do
+fetchPackages menv idents' = do
     resolved <- resolvePackages menv idents Set.empty
     ToFetchResult toFetch alreadyUnpacked <- getToFetch Nothing resolved
     assert (Map.null alreadyUnpacked) (return ())
     nowUnpacked <- fetchPackages' Nothing toFetch
     assert (Map.null nowUnpacked) (return ())
+  where
+    -- Since we're just fetching tarballs and not unpacking cabal files, we can
+    -- always provide a Nothing Git SHA
+    idents = Map.fromList $ map (, Nothing) $ Set.toList idents'
 
 -- | Intended to work for the command line command.
 unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m)
@@ -140,7 +151,9 @@ unpackPackages menv dest input = do
     (names, idents) <- case partitionEithers $ map parse input of
         ([], x) -> return $ partitionEithers x
         (errs, _) -> throwM $ CouldNotParsePackageSelectors errs
-    resolved <- resolvePackages menv (Set.fromList idents) (Set.fromList names)
+    resolved <- resolvePackages menv
+        (Map.fromList $ map (, Nothing) idents)
+        (Set.fromList names)
     ToFetchResult toFetch alreadyUnpacked <- getToFetch (Just dest') resolved
     unless (Map.null alreadyUnpacked) $
         throwM $ UnpackDirectoryAlreadyExists $ Set.fromList $ map toFilePath $ Map.elems alreadyUnpacked
@@ -168,7 +181,7 @@ unpackPackageIdents
     => EnvOverride
     -> Path Abs Dir -- ^ unpack directory
     -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157
-    -> Set PackageIdentifier
+    -> Map PackageIdentifier (Maybe GitSHA1)
     -> m (Map PackageIdentifier (Path Abs Dir))
 unpackPackageIdents menv unpackDir mdistDir idents = do
     resolved <- resolvePackages menv idents Set.empty
@@ -179,12 +192,13 @@ unpackPackageIdents menv unpackDir mdistDir idents = do
 data ResolvedPackage = ResolvedPackage
     { rpCache :: !PackageCache
     , rpIndex :: !PackageIndex
+    , rpGitSHA1 :: !(Maybe GitSHA1)
     }
 
 -- | Resolve a set of package names and identifiers into @FetchPackage@ values.
 resolvePackages :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadBaseControl IO m, MonadCatch m)
                 => EnvOverride
-                -> Set PackageIdentifier
+                -> Map PackageIdentifier (Maybe GitSHA1)
                 -> Set PackageName
                 -> m (Map PackageIdentifier ResolvedPackage)
 resolvePackages menv idents0 names0 = do
@@ -203,7 +217,7 @@ resolvePackages menv idents0 names0 = do
 
 resolvePackagesAllowMissing
     :: (MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadLogger m, MonadThrow m, MonadBaseControl IO m, MonadCatch m)
-    => Set PackageIdentifier
+    => Map PackageIdentifier (Maybe GitSHA1)
     -> Set PackageName
     -> m (Set PackageName, Set PackageIdentifier, Map PackageIdentifier ResolvedPackage)
 resolvePackagesAllowMissing idents0 names0 = do
@@ -214,16 +228,17 @@ resolvePackagesAllowMissing idents0 names0 = do
                 (Map.lookup name versions))
             (Set.toList names0)
         (missingIdents, resolved) = partitionEithers $ map (goIdent caches)
-                                  $ Set.toList
-                                  $ idents0 <> Set.fromList idents1
+                                  $ Map.toList
+                                  $ idents0 <> Map.fromList (map (, Nothing) idents1)
     return (Set.fromList missingNames, Set.fromList missingIdents, Map.fromList resolved)
   where
-    goIdent caches ident =
+    goIdent caches (ident, mgitsha) =
         case Map.lookup ident caches of
             Nothing -> Left ident
             Just (index, cache) -> Right (ident, ResolvedPackage
                 { rpCache = cache
                 , rpIndex = index
+                , rpGitSHA1 = mgitsha
                 })
 
 data ToFetch = ToFetch
@@ -245,15 +260,42 @@ data ToFetchResult = ToFetchResult
 withCabalFiles
     :: (MonadMask m, MonadIO m, MonadLogger m, MonadReader env m, HasConfig env)
     => IndexName
-    -> [(PackageIdentifier, PackageCache, a)]
+    -> [(PackageIdentifier, PackageCache, Maybe GitSHA1, a)]
     -> (PackageIdentifier -> a -> ByteString -> IO b)
     -> m [b]
 withCabalFiles name pkgs f = do
     indexPath <- configPackageIndex name
-    liftIO $ withBinaryFile (toFilePath indexPath) ReadMode $ \h ->
-        mapM (goPkg h) pkgs
+    mgitRepo <- configPackageIndexRepo name
+    bracket
+        (liftIO $ openBinaryFile (toFilePath indexPath) ReadMode)
+        (liftIO . hClose) $ \h ->
+            let inner mgit = mapM (goPkg h mgit) pkgs
+             in case mgitRepo of
+                    Nothing -> inner Nothing
+                    Just repo -> bracket
+                        (liftIO $ Git.openRepo
+                                $ fromString
+                                $ toFilePath repo FP.</> ".git")
+                        (liftIO . Git.closeRepo)
+                        (inner . Just)
   where
-    goPkg h (ident, pc, tf) = do
+    goPkg h (Just git) (ident, pc, Just (GitSHA1 sha), tf) = do
+        let ref = Git.fromHex sha
+        mobj <- liftIO $ tryIO $ Git.getObject git ref True
+        case mobj of
+            Right (Just (Git.ObjBlob (Git.Blob bs))) -> liftIO $ f ident tf (L.toStrict bs)
+            -- fallback when the appropriate SHA isn't found
+            e -> do
+                $logWarn $ mconcat
+                    [ "Did not find .cabal file for "
+                    , T.pack $ packageIdentifierString ident
+                    , " with Git SHA of "
+                    , decodeUtf8 sha
+                    , "\n"
+                    , T.pack $ show e
+                    ]
+                goPkg h Nothing (ident, pc, Nothing, tf)
+    goPkg h _mgit (ident, pc, _mgitsha, tf) = liftIO $ do
         hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc
         cabalBS <- S.hGet h $ fromIntegral $ pcSize pc
         f ident tf cabalBS
@@ -277,13 +319,14 @@ withCabalLoader menv inner = do
 
     loadCaches <- getPackageCachesIO
     runInBase <- liftBaseWith $ \run -> return (void . run)
+    unlift <- askRunBase
 
     -- TODO in the future, keep all of the necessary @Handle@s open
     let doLookup :: PackageIdentifier
                  -> IO ByteString
         doLookup ident = do
             caches <- loadCaches
-            eres <- lookupPackageIdentifierExact ident env caches
+            eres <- unlift $ lookupPackageIdentifierExact ident env cachesCurr
             case eres of
                 Just bs -> return bs
                 -- Update the cache and try again
@@ -327,7 +370,7 @@ lookupPackageIdentifierExact ident env caches =
         Nothing -> return Nothing
         Just (index, cache) -> do
             [bs] <- flip runReaderT env
-                  $ withCabalFiles (indexName index) [(ident, cache, ())]
+                  $ withCabalFiles (indexName index) [(ident, cache, Nothing, ())]
                   $ \_ _ bs -> return bs
             return $ Just bs
 
@@ -390,7 +433,7 @@ getToFetch mdest resolvedAll = do
                     d = pcDownload $ rpCache resolved
                     targz = T.pack $ packageIdentifierString ident ++ ".tar.gz"
                 tarball <- configPackageTarball (indexName index) ident
-                return $ Left (indexName index, [(ident, rpCache resolved, ToFetch
+                return $ Left (indexName index, [(ident, rpCache resolved, rpGitSHA1 resolved, ToFetch
                     { tfTarball = tarball
                     , tfDestDir = mdestDir
                     , tfUrl = case d of

src/Stack/Setup.hs

@@ -486,7 +486,7 @@ upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env
              -> m ()
 upgradeCabal menv wc = do
     let name = $(mkPackageName "Cabal")
-    rmap <- resolvePackages menv Set.empty (Set.singleton name)
+    rmap <- resolvePackages menv Map.empty (Set.singleton name)
     newest <-
         case Map.keys rmap of
             [] -> error "No Cabal library found in index, cannot upgrade"
@@ -510,7 +510,8 @@ upgradeCabal menv wc = do
                 , T.pack $ versionString installed
                 ]
             let ident = PackageIdentifier name newest
-            m <- unpackPackageIdents menv tmpdir Nothing (Set.singleton ident)
+            -- Nothing below: use the newest .cabal file revision
+            m <- unpackPackageIdents menv tmpdir Nothing (Map.singleton ident Nothing)
 
             compilerPath <- join $ findExecutable menv (compilerExeName wc)
             newestDir <- parseRelDir $ versionString newest

src/Stack/Types/Config.hs

@@ -72,6 +72,7 @@ module Stack.Types.Config
   ,configPackageIndexCache
   ,configPackageIndexGz
   ,configPackageIndexRoot
+  ,configPackageIndexRepo
   ,configPackageTarball
   ,indexNameText
   ,IndexLocation(..)
@@ -176,6 +177,7 @@ import           Stack.Types.PackageIndex
 import           Stack.Types.PackageName
 import           Stack.Types.TemplateName
 import           Stack.Types.Version
+import           System.FilePath (takeBaseName)
 import           System.PosixCompat.Types (UserID, GroupID, FileMode)
 import           System.Process.Read (EnvOverride, findExecutable)
 
@@ -1239,6 +1241,29 @@ configPackageIndexRoot (IndexName name) = do
     dir <- parseRelDir $ S8.unpack name
     return (configStackRoot config </> $(mkRelDir "indices") </> dir)
 
+-- | Git repo directory for a specific package index, returns 'Nothing' if not
+-- a Git repo
+configPackageIndexRepo :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Maybe (Path Abs Dir))
+configPackageIndexRepo name = do
+    indices <- asks $ configPackageIndices . getConfig
+    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 murl of
+                Nothing -> return Nothing
+                Just url -> do
+                    sDir <- configPackageIndexRoot name
+                    repoName <- parseRelDir $ takeBaseName $ T.unpack url
+                    let suDir =
+                          sDir </>
+                          $(mkRelDir "git-update")
+                    return $ Just $ suDir </> repoName
+        _ -> assert False $ return Nothing
+
 -- | Location of the 00-index.cache file
 configPackageIndexCache :: (MonadReader env m, HasConfig env, MonadThrow m) => IndexName -> m (Path Abs File)
 configPackageIndexCache = liftM (</> $(mkRelFile "00-index.cache")) . configPackageIndexRoot

src/Stack/Upgrade.hs

@@ -15,7 +15,6 @@ import qualified Data.Map                    as Map
 import           Data.Maybe                  (isNothing)
 import           Data.Monoid                 ((<>))
 import qualified Data.Monoid
-import qualified Data.Set                    as Set
 import qualified Data.Text as T
 import           Lens.Micro                  (set)
 import           Network.HTTP.Client.Conduit (HasHttpManager)
@@ -83,7 +82,9 @@ upgrade gitRepo mresolver builtHash =
                 return Nothing
             Just version -> do
                 let ident = PackageIdentifier $(mkPackageName "stack") version
-                paths <- unpackPackageIdents menv tmp Nothing $ Set.singleton ident
+                paths <- unpackPackageIdents menv tmp Nothing
+                    -- accept latest cabal revision by not supplying a Git SHA
+                    $ Map.singleton ident Nothing
                 case Map.lookup ident paths of
                     Nothing -> error "Stack.Upgrade.upgrade: invariant violated, unpacked directory not found"
                     Just path -> return $ Just path

stack.cabal

@@ -168,6 +168,7 @@ library
                    , filepath >= 1.3.0.2
                    , fsnotify >= 0.2.1
                    , hashable >= 1.2.3.2
+                   , hit
                    , hpc
                    , http-client >= 0.4.17
                    , http-client-tls >= 0.2.2