Cabal file Git SHA

ChangeLog.md

@@ -10,6 +10,9 @@ Behavior changes:
 
 Other enhancements:
 
+* Grab Cabal files via Git SHA to avoid regressions from Hackage revisions
+  [#2070](https://github.com/commercialhaskell/stack/pull/2070)
+
 Bug fixes:
 
 ## 1.1.0

src/Stack/Build.hs

@@ -22,11 +22,12 @@ module Stack.Build
 
 import           Control.Exception (Exception)
 import           Control.Monad
-import           Control.Monad.Catch (MonadCatch, MonadMask)
+import           Control.Monad.Catch (MonadMask, MonadMask)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
 import           Control.Monad.Reader (MonadReader, asks)
 import           Control.Monad.Trans.Resource
+import           Control.Monad.Trans.Unlift (MonadBaseUnlift)
 import           Data.Aeson (Value (Object, Array), (.=), object)
 import           Data.Function
 import qualified Data.HashMap.Strict as HM
@@ -68,7 +69,7 @@ import           System.Win32.Console (setConsoleCP, setConsoleOutputCP, getCons
 import qualified Control.Monad.Catch as Catch
 #endif
 
-type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
+type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasBuildConfig env,MonadLogger m,MonadBaseUnlift IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env)
 
 -- | Build.
 --
@@ -267,8 +268,8 @@ mkBaseConfigOpts boptsCli = do
 withLoadPackage :: ( MonadIO m
                    , HasHttpManager env
                    , MonadReader env m
-                   , MonadBaseControl IO m
-                   , MonadCatch m
+                   , MonadBaseUnlift IO m
+                   , MonadMask m
                    , MonadLogger m
                    , HasEnvConfig env)
                 => EnvOverride

src/Stack/Build/ConstructPlan.hs

@@ -202,7 +202,7 @@ mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap =
         case M.lookup name tasks of
             Nothing ->
                 case M.lookup name sourceMap of
-                    Just (PSUpstream _ Snap _) -> Map.singleton gid
+                    Just (PSUpstream _ Snap _ _) -> Map.singleton gid
                         ( ident
                         , Just "Switching to snapshot installed package"
                         )
@@ -276,7 +276,7 @@ tellExecutables :: PackageName -> PackageSource -> M ()
 tellExecutables _ (PSLocal lp)
     | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp
     | otherwise = return ()
-tellExecutables name (PSUpstream version loc flags) =
+tellExecutables name (PSUpstream version loc flags _) =
     tellExecutablesUpstream name version loc flags
 
 tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M ()
@@ -316,7 +316,7 @@ installPackage :: Bool -- ^ is this being used by a dependency?
 installPackage treatAsDep name ps minstalled = do
     ctx <- ask
     case ps of
-        PSUpstream version _ flags -> do
+        PSUpstream version _ flags _ -> do
             package <- liftIO $ loadPackage ctx name version flags
             resolveDepsAndInstall False treatAsDep ps package minstalled
         PSLocal lp ->
@@ -410,7 +410,7 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL
             , taskType =
                 case ps of
                     PSLocal lp -> TTLocal lp
-                    PSUpstream _ loc _ -> TTUpstream package $ loc <> minLoc
+                    PSUpstream _ loc _ sha -> TTUpstream package (loc <> minLoc) sha
             , taskAllInOne = isAllInOne
             }
 
@@ -667,8 +667,8 @@ stripLocals plan = plan
     checkTask task =
         case taskType task of
             TTLocal _ -> False
-            TTUpstream _ Local -> False
-            TTUpstream _ Snap -> True
+            TTUpstream _ Local _ -> False
+            TTUpstream _ Snap _ -> True
 
 stripNonDeps :: Set PackageName -> Plan -> Plan
 stripNonDeps deps plan = plan

src/Stack/Build/Execute.hs

@@ -113,7 +113,7 @@ preFetch plan
     toIdent (name, task) =
         case taskType task of
             TTLocal _ -> Set.empty
-            TTUpstream package _ -> Set.singleton $ PackageIdentifier
+            TTUpstream package _ _ -> Set.singleton $ PackageIdentifier
                 name
                 (packageVersion package)
 
@@ -187,7 +187,7 @@ displayTask task = T.pack $ concat
         TTLocal lp -> concat
             [ toFilePath $ lpDir lp
             ]
-        TTUpstream _ _ -> "package index"
+        TTUpstream _ _ _ -> "package index"
     , if Set.null missing
         then ""
         else ", after: " ++ intercalate "," (map packageIdentifierString $ Set.toList missing)
@@ -665,7 +665,7 @@ getConfigCache ExecuteEnv {..} Task {..} installedMap enableTest enableBench = d
             , configCacheComponents =
                 case taskType of
                     TTLocal lp -> Set.map renderComponent $ lpComponents lp
-                    TTUpstream _ _ -> Set.empty
+                    TTUpstream _ _ _ -> Set.empty
             , configCacheHaddock =
                 shouldHaddockPackage eeBuildOpts eeWanted (packageIdentifierName taskProvides)
             }
@@ -764,7 +764,7 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
     wanted =
         case taskType of
             TTLocal lp -> lpWanted lp
-            TTUpstream _ _ -> False
+            TTUpstream _ _ _ -> False
 
     console = wanted
            && all (\(ActionId ident _) -> ident == taskProvides) (Set.toList acRemaining)
@@ -773,9 +773,10 @@ withSingleContext runInBase ActionContext {..} ExecuteEnv {..} task@Task {..} md
     withPackage inner =
         case taskType of
             TTLocal lp -> inner (lpPackage lp) (lpCabalFile lp) (lpDir lp)
-            TTUpstream package _ -> do
+            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
@@ -1078,7 +1079,7 @@ singleBuild runInBase ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} in
             TTLocal lp -> do
                 when enableTests $ unsetTestSuccess pkgDir
                 writeBuildCache pkgDir $ lpNewBuildCache lp
-            TTUpstream _ _ -> return ()
+            TTUpstream _ _ _ -> return ()
 
         () <- announce ("build" <> annSuffix)
         config <- asks getConfig
@@ -1170,7 +1171,7 @@ checkForUnlistedFiles (TTLocal lp) preBuildTime pkgDir = do
     unless (null addBuildCache) $
         writeBuildCache pkgDir $
         Map.unions (lpNewBuildCache lp : addBuildCache)
-checkForUnlistedFiles (TTUpstream _ _) _ _ = return ()
+checkForUnlistedFiles (TTUpstream _ _ _) _ _ = return ()
 
 -- | Determine if all of the dependencies given are installed
 depsPresent :: InstalledMap -> Map PackageName VersionRange -> Bool

src/Stack/Build/Source.hs

@@ -23,7 +23,7 @@ import           Control.Applicative
 import           Control.Arrow ((&&&))
 import           Control.Exception (assert, catch)
 import           Control.Monad
-import           Control.Monad.Catch (MonadCatch)
+import           Control.Monad.Catch (MonadMask)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
 import           Control.Monad.Reader (MonadReader, asks)
@@ -68,7 +68,7 @@ import qualified System.Directory as D
 import           System.IO (withBinaryFile, IOMode (ReadMode))
 import           System.IO.Error (isDoesNotExistError)
 
-loadSourceMap :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
+loadSourceMap :: (MonadIO m, MonadMask m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
               => NeedTargets
               -> BuildOptsCLI
               -> m ( Map PackageName SimpleTarget
@@ -116,8 +116,8 @@ loadSourceMap needTargets boptsCli = do
 
         -- Overwrite any flag settings with those from the config file
         extraDeps3 = Map.mapWithKey
-            (\n (v, f) -> PSUpstream v Local $
-                case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli
+            (\n (v, f) -> PSUpstream v Local
+               (case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli
                      , Map.lookup Nothing $ boptsCLIFlags boptsCli
                      , Map.lookup n $ bcFlags bconfig
                      ) of
@@ -132,6 +132,10 @@ loadSourceMap needTargets boptsCli = do
                         , fromMaybe Map.empty y
                         , fromMaybe Map.empty z
                         ])
+
+                 -- currently have no ability for extra-deps to specify their
+                 -- cabal file hashes
+                 Nothing)
             extraDeps2
 
     let sourceMap = Map.unions
@@ -140,14 +144,14 @@ loadSourceMap needTargets boptsCli = do
                  in (packageName p, PSLocal lp)
             , extraDeps3
             , flip fmap (mbpPackages mbp) $ \mpi ->
-                PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi)
+                PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGitSHA1 mpi)
             ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))
 
     return (targets, mbp, locals, nonLocalTargets, sourceMap)
 
 -- | Use the build options and environment to parse targets.
 parseTargetsFromBuildOpts
-    :: (MonadIO m, MonadCatch m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
+    :: (MonadIO m, MonadMask m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
     => NeedTargets
     -> BuildOptsCLI
     -> m (MiniBuildPlan, M.Map PackageName Version, M.Map PackageName SimpleTarget)
@@ -275,7 +279,7 @@ splitComponents =
 -- based on the selected components
 loadLocalPackage
     :: forall m env.
-       (MonadReader env m, HasEnvConfig env, MonadCatch m, MonadLogger m, MonadIO m)
+       (MonadReader env m, HasEnvConfig env, MonadMask m, MonadLogger m, MonadIO m)
     => BuildOptsCLI
     -> Map PackageName SimpleTarget
     -> (PackageName, (LocalPackageView, GenericPackageDescription))
@@ -428,7 +432,7 @@ localFlags boptsflags bconfig name = Map.unions
 -- this was then superseded by
 -- https://github.com/commercialhaskell/stack/issues/651
 extendExtraDeps
-    :: (HasBuildConfig env, MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m)
+    :: (HasBuildConfig env, MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadBaseControl IO m, MonadMask m)
     => Map PackageName Version -- ^ original extra deps
     -> Map PackageName Version -- ^ package identifiers from the command line
     -> Set PackageName -- ^ all packages added on the command line
@@ -489,7 +493,7 @@ checkBuildCache oldCache files = liftIO $ do
 
 -- | Returns entries to add to the build cache for any newly found unlisted modules
 addUnlistedToBuildCache
-    :: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env)
+    :: (MonadIO m, MonadReader env m, MonadMask m, MonadLogger m, HasEnvConfig env)
     => ModTime
     -> Package
     -> Path Abs File
@@ -516,7 +520,7 @@ addUnlistedToBuildCache preBuildTime pkg cabalFP buildCache = do
 
 -- | Gets list of Paths for files in a package
 getPackageFilesSimple
-    :: (MonadIO m, MonadReader env m, MonadCatch m, MonadLogger m, HasEnvConfig env)
+    :: (MonadIO m, MonadReader env m, MonadMask m, MonadLogger m, HasEnvConfig env)
     => Package -> Path Abs File -> m (Set (Path Abs File), [PackageWarning])
 getPackageFilesSimple pkg cabalFP = do
     (_,compFiles,cabalFiles,warnings) <-
@@ -565,7 +569,7 @@ checkComponentsBuildable lps =
         ]
 
 -- | Get 'PackageConfig' for package given its name.
-getPackageConfig :: (MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m, MonadReader env m, HasEnvConfig env)
+getPackageConfig :: (MonadIO m, MonadThrow m, MonadMask m, MonadLogger m, MonadReader env m, HasEnvConfig env)
   => BuildOptsCLI
   -> PackageName
   -> m PackageConfig