From 6ae39cb76f68abe709235b22c0607ad235c26d54 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 26 Apr 2016 10:49:43 +0300 Subject: [PATCH 1/6] Populate cabal file Git SHA from snapshots --- src/Stack/BuildPlan.hs | 26 +++++++++++++++++++------- src/Stack/Types/BuildPlan.hs | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 7 deletions(-) diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 9be987cec5..6a8134e712 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -217,7 +217,7 @@ data ResolveState = ResolveState toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m) => CompilerVersion -- ^ Compiler version -> Map PackageName Version -- ^ cores - -> Map PackageName (Version, Map FlagName Bool) -- ^ non-core packages + -> Map PackageName (Version, Map FlagName Bool, Maybe GitSHA1) -- ^ non-core packages -> m MiniBuildPlan toMiniBuildPlan compilerVersion corePackages packages = do $logInfo "Caching build plan" @@ -228,7 +228,7 @@ toMiniBuildPlan compilerVersion corePackages packages = do -- remove those from the list of dependencies, since there's no way we'll -- ever reinstall them anyway. (cores, missingCores) <- addDeps True compilerVersion - $ fmap (, Map.empty) corePackages + $ fmap (, Map.empty, Nothing) corePackages (extras, missing) <- addDeps False compilerVersion packages @@ -248,6 +248,7 @@ toMiniBuildPlan compilerVersion corePackages packages = do , mpiToolDeps = Set.empty , mpiExes = Set.empty , mpiHasLibrary = True + , mpiGitSHA1 = Nothing }) removeMissingDeps cores mpi = mpi @@ -258,7 +259,7 @@ toMiniBuildPlan compilerVersion corePackages packages = do addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m) => Bool -- ^ allow missing -> CompilerVersion -- ^ Compiler version - -> Map PackageName (Version, Map FlagName Bool) + -> Map PackageName (Version, Map FlagName Bool, Maybe GitSHA1) -> m (Map PackageName MiniPackageInfo, Set PackageIdentifier) addDeps allowMissing compilerVersion toCalc = do menv <- getMinimalEnvOverride @@ -278,10 +279,11 @@ addDeps allowMissing compilerVersion toCalc = do (indexName $ rpIndex rp, [( ident , rpCache rp - , maybe Map.empty snd $ Map.lookup (packageIdentifierName ident) toCalc + , maybe (Map.empty, Nothing) sndthd3 + $ Map.lookup (packageIdentifierName ident) toCalc )]) res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs - $ \ident flags cabalBS -> do + $ \ident (flags, mgitSha) cabalBS -> do (_warnings,gpd) <- readPackageUnresolvedBS Nothing cabalBS let packageConfig = PackageConfig { packageConfigEnableTests = False @@ -304,13 +306,16 @@ addDeps allowMissing compilerVersion toCalc = do False (buildable . libBuildInfo) (library pd) + , mpiGitSHA1 = mgitSha }) return (Map.fromList $ concat res, missingIdents) where idents0 = Map.fromList - $ map (\(n, (v, f)) -> (PackageIdentifier n v, Left f)) + $ map (\(n, (v, f, _gitsha)) -> (PackageIdentifier n v, Left f)) $ Map.toList toCalc + sndthd3 (_, x, y) = (x, y) + -- | Resolve all packages necessary to install for the needed packages. getDeps :: MiniBuildPlan -> (PackageName -> Bool) -- ^ is it shadowed by a local package? @@ -414,6 +419,10 @@ loadMiniBuildPlan name = do goPP pp = ( ppVersion pp , pcFlagOverrides $ ppConstraints pp + , ppCabalFileInfo pp + >>= fmap (GitSHA1 . encodeUtf8) + . Map.lookup "GitSHA1" + . cfiHashes ) -- | Some hard-coded fixes for build plans, hopefully to be irrelevant over @@ -891,7 +900,7 @@ parseCustomMiniBuildPlan stackYamlFP url0 = do toMiniBuildPlan (csCompilerVersion cs) Map.empty - (Map.fromList $ map addFlags $ Set.toList $ csPackages cs) + (fmap addGitSHA $ Map.fromList $ map addFlags $ Set.toList $ csPackages cs) where getCustomPlanDir = do root <- asks $ configStackRoot . getConfig @@ -917,6 +926,9 @@ parseCustomMiniBuildPlan stackYamlFP url0 = do T.stripPrefix "file://" url <|> T.stripPrefix "file:" url) parseAbsFile fp + -- we add a Nothing since we don't yet collect Git SHAs for custom snapshots + addGitSHA (x, y) = (x, y, Nothing) + data CustomSnapshot = CustomSnapshot { csCompilerVersion :: !CompilerVersion , csPackages :: !(Set PackageIdentifier) diff --git a/src/Stack/Types/BuildPlan.hs b/src/Stack/Types/BuildPlan.hs index f44f7593d2..6ca42f9317 100644 --- a/src/Stack/Types/BuildPlan.hs +++ b/src/Stack/Types/BuildPlan.hs @@ -21,6 +21,8 @@ module Stack.Types.BuildPlan , SnapName (..) , MiniBuildPlan (..) , MiniPackageInfo (..) + , CabalFileInfo (..) + , GitSHA1 (..) , renderSnapName , parseSnapName ) where @@ -33,6 +35,7 @@ import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, withText, (.!=), (.:), (.:?), (.=)) import Data.Binary.VersionTagged +import Data.ByteString (ByteString) import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HashMap import Data.IntMap (IntMap) @@ -101,6 +104,7 @@ instance FromJSON BuildPlan where data PackagePlan = PackagePlan { ppVersion :: Version + , ppCabalFileInfo :: Maybe CabalFileInfo , ppGithubPings :: Set Text , ppUsers :: Set PackageName , ppConstraints :: PackageConstraints @@ -110,6 +114,7 @@ data PackagePlan = PackagePlan instance ToJSON PackagePlan where toJSON PackagePlan {..} = object + $ maybe id (\cfi -> (("cabal-file-info" .= cfi):)) ppCabalFileInfo $ [ "version" .= ppVersion , "github-pings" .= ppGithubPings , "users" .= ppUsers @@ -119,12 +124,32 @@ instance ToJSON PackagePlan where instance FromJSON PackagePlan where parseJSON = withObject "PackageBuild" $ \o -> do ppVersion <- o .: "version" + ppCabalFileInfo <- o .:? "cabal-file-info" ppGithubPings <- o .:? "github-pings" .!= mempty ppUsers <- o .:? "users" .!= mempty ppConstraints <- o .: "constraints" ppDesc <- o .: "description" return PackagePlan {..} +-- | Information on the contents of a cabal file +data CabalFileInfo = CabalFileInfo + { cfiSize :: !Int + -- ^ File size in bytes + , cfiHashes :: !(Map.Map Text Text) + -- ^ Various hashes of the file contents + } + deriving (Show, Eq, Generic) +instance ToJSON CabalFileInfo where + toJSON CabalFileInfo {..} = object + [ "size" .= cfiSize + , "hashes" .= cfiHashes + ] +instance FromJSON CabalFileInfo where + parseJSON = withObject "CabalFileInfo" $ \o -> do + cfiSize <- o .: "size" + cfiHashes <- o .: "hashes" + return CabalFileInfo {..} + display :: DT.Text a => a -> Text display = fromString . DT.display @@ -420,8 +445,15 @@ data MiniPackageInfo = MiniPackageInfo -- ^ Executables provided by this package , mpiHasLibrary :: !Bool -- ^ Is there a library present? + , mpiGitSHA1 :: !(Maybe GitSHA1) + -- ^ An optional SHA1 representation in hex format of the blob containing + -- the cabal file contents. Useful for grabbing the correct cabal file + -- revision directly from a Git repo } deriving (Generic, Show, Eq) instance Binary MiniPackageInfo instance HasStructuralInfo MiniPackageInfo instance NFData MiniPackageInfo + +newtype GitSHA1 = GitSHA1 ByteString + deriving (Generic, Show, Eq, NFData, HasStructuralInfo, Binary) From af59b780651a08dde481c597359998494d9baacd Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 27 Apr 2016 18:21:36 +0300 Subject: [PATCH 2/6] Upgrade a bunch of constraints to MonadMask and MonadBaseUnlift --- src/Stack/Build.hs | 9 +++++---- src/Stack/Build/Source.hs | 18 +++++++++--------- src/Stack/BuildPlan.hs | 12 ++++++------ src/Stack/Coverage.hs | 22 +++++++++++----------- src/Stack/Dot.hs | 8 ++++---- src/Stack/Fetch.hs | 17 +++++++++-------- src/Stack/Ghci.hs | 6 +++--- src/Stack/Ide.hs | 4 ++-- src/Stack/Solver.hs | 2 +- stack.cabal | 1 + 10 files changed, 51 insertions(+), 48 deletions(-) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 5c2bed3af5..b3ba26321b 100644 --- a/src/Stack/Build.hs +++ b/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 diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index d26b81d5d9..21c78ddba1 100644 --- a/src/Stack/Build/Source.hs +++ b/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 @@ -140,14 +140,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 +275,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 +428,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 +489,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 +516,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 +565,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 diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 6a8134e712..bb55cb4e95 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -214,7 +214,7 @@ data ResolveState = ResolveState , rsUsedBy :: Map PackageName (Set PackageName) } -toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m) +toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadMask m, HasConfig env, MonadBaseControl IO m) => CompilerVersion -- ^ Compiler version -> Map PackageName Version -- ^ cores -> Map PackageName (Version, Map FlagName Bool, Maybe GitSHA1) -- ^ non-core packages @@ -256,7 +256,7 @@ toMiniBuildPlan compilerVersion corePackages packages = do } -- | Add in the resolved dependencies from the package index -addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m, MonadCatch m) +addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadMask m, HasConfig env, MonadBaseControl IO m) => Bool -- ^ allow missing -> CompilerVersion -- ^ Compiler version -> Map PackageName (Version, Map FlagName Bool, Maybe GitSHA1) @@ -404,7 +404,7 @@ getToolMap mbp = -- | Load up a 'MiniBuildPlan', preferably from cache loadMiniBuildPlan - :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadCatch m) + :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadMask m) => SnapName -> m MiniBuildPlan loadMiniBuildPlan name = do @@ -681,7 +681,7 @@ instance Show BuildPlanCheck where -- given snapshot. Returns how well the snapshot satisfies the dependencies of -- the packages. checkSnapBuildPlan - :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m + :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env , MonadBaseControl IO m) => [GenericPackageDescription] @@ -716,7 +716,7 @@ checkSnapBuildPlan gpds flags snap = do -- | Find a snapshot and set of flags that is compatible with and matches as -- best as possible with the given 'GenericPackageDescription's. selectBestSnapshot - :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m + :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env , MonadBaseControl IO m) => [GenericPackageDescription] @@ -880,7 +880,7 @@ shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed = Just False -> Right Nothing -> assert False Right -parseCustomMiniBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m) +parseCustomMiniBuildPlan :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m) => Path Abs File -- ^ stack.yaml file location -> T.Text -> m MiniBuildPlan parseCustomMiniBuildPlan stackYamlFP url0 = do diff --git a/src/Stack/Coverage.hs b/src/Stack/Coverage.hs index ca46ff2481..e7dd3af98d 100644 --- a/src/Stack/Coverage.hs +++ b/src/Stack/Coverage.hs @@ -18,7 +18,7 @@ module Stack.Coverage import Control.Applicative import Control.Exception.Lifted import Control.Monad (liftM, when, unless, void) -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) @@ -53,7 +53,7 @@ import Text.Hastache (htmlEscape) import Trace.Hpc.Tix -- | Invoked at the beginning of running with "--coverage" -deleteHpcReports :: (MonadIO m, MonadCatch m, MonadReader env m, HasEnvConfig env) +deleteHpcReports :: (MonadIO m, MonadMask m, MonadReader env m, HasEnvConfig env) => m () deleteHpcReports = do hpcDir <- hpcReportDir @@ -61,7 +61,7 @@ deleteHpcReports = do -- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is -- present. -updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) +updateTixFile :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => PackageName -> Path Abs File -> String -> m () updateTixFile pkgName tixSrc testName = do exists <- doesFileExist tixSrc @@ -79,7 +79,7 @@ updateTixFile pkgName tixSrc testName = do ignoringAbsence (removeFile tixSrc) -- | Get the directory used for hpc reports for the given pkgId. -hpcPkgPath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) +hpcPkgPath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => PackageName -> m (Path Abs Dir) hpcPkgPath pkgName = do outputDir <- hpcReportDir @@ -88,7 +88,7 @@ hpcPkgPath pkgName = do -- | Get the tix file location, given the name of the file (without extension), and the package -- identifier string. -tixFilePath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) +tixFilePath :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => PackageName -> String -> m (Path Abs File) tixFilePath pkgName testName = do pkgPath <- hpcPkgPath pkgName @@ -96,7 +96,7 @@ tixFilePath pkgName testName = do return (pkgPath tixRel) -- | Generates the HTML coverage report and shows a textual coverage summary for a package. -generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) +generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => Path Abs Dir -> Package -> [Text] -> m () generateHpcReport pkgDir package tests = do -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See @@ -133,7 +133,7 @@ generateHpcReport pkgDir package tests = do Nothing -> [] generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs -generateHpcReportInternal :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) +generateHpcReportInternal :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String] -> m () generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do -- If a .tix file exists, move it to the HPC output directory and generate a report for it. @@ -204,7 +204,7 @@ data HpcReportOpts = HpcReportOpts , hroptsDestDir :: Maybe String } deriving (Show) -generateHpcReportForTargets :: (MonadIO m, HasHttpManager env, MonadReader env m, MonadBaseControl IO m, MonadCatch m, MonadLogger m, HasEnvConfig env) +generateHpcReportForTargets :: (MonadIO m, HasHttpManager env, MonadReader env m, MonadBaseControl IO m, MonadMask m, MonadLogger m, HasEnvConfig env) => HpcReportOpts -> m () generateHpcReportForTargets opts = do let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts) @@ -257,7 +257,7 @@ generateHpcReportForTargets opts = do return dest generateUnionReport "combined report" reportDir tixPaths -generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) +generateHpcUnifiedReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => m () generateHpcUnifiedReport = do outputDir <- hpcReportDir @@ -278,7 +278,7 @@ generateHpcUnifiedReport = do ] else generateUnionReport "unified report" reportDir tixFiles -generateUnionReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env) +generateUnionReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasEnvConfig env) => Text -> Path Abs Dir -> [Path Abs File] -> m () generateUnionReport report reportDir tixFiles = do (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles) @@ -315,7 +315,7 @@ unionTixes tixes = (Map.keys errs, Tix (Map.elems outputs)) | hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2)) merge _ _ = Left () -generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env) +generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadMask m,HasEnvConfig env) => m () generateHpcMarkupIndex = do outputDir <- hpcReportDir diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index cab85e2b57..b1bdce55be 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -16,7 +16,7 @@ import Control.Monad.Catch (MonadCatch,MonadMask) import Control.Monad.IO.Class import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader) -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.Foldable as F import qualified Data.HashSet as HashSet import Data.Map (Map) @@ -55,7 +55,7 @@ data DotOpts = DotOpts dot :: (HasEnvConfig env ,HasHttpManager env ,HasLogLevel env - ,MonadBaseControl IO m + ,MonadBaseUnlift IO m ,MonadCatch m ,MonadLogger m ,MonadIO m @@ -81,7 +81,7 @@ createDependencyGraph :: (HasEnvConfig env ,HasHttpManager env ,HasLogLevel env ,MonadLogger m - ,MonadBaseControl IO m + ,MonadBaseUnlift IO m ,MonadCatch m ,MonadIO m ,MonadMask m @@ -111,7 +111,7 @@ createDependencyGraph dotOpts = do listDependencies :: (HasEnvConfig env ,HasHttpManager env ,HasLogLevel env - ,MonadBaseControl IO m + ,MonadBaseUnlift IO m ,MonadCatch m ,MonadLogger m ,MonadMask m diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 0471abfa85..afa334be12 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -41,6 +41,7 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader (asks, runReaderT) import Control.Monad.Trans.Control +import Control.Monad.Trans.Unlift (MonadBaseUnlift, askRunBase) import "cryptohash" Crypto.Hash (SHA512 (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as S @@ -117,7 +118,7 @@ instance Show FetchException where (if null suggestions then "" else "\n" ++ suggestions) -- | Fetch packages into the cache without unpacking -fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m) +fetchPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m) => EnvOverride -> Set PackageIdentifier -> m () @@ -129,7 +130,7 @@ fetchPackages menv idents = do assert (Map.null nowUnpacked) (return ()) -- | Intended to work for the command line command. -unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m) +unpackPackages :: (MonadIO m, MonadBaseControl IO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m) => EnvOverride -> FilePath -- ^ destination -> [String] -- ^ names or identifiers @@ -163,7 +164,7 @@ unpackPackages menv dest input = do -- | Ensure that all of the given package idents are unpacked into the build -- unpack directory, and return the paths to all of the subdirectories. unpackPackageIdents - :: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadThrow m, MonadLogger m, MonadCatch m) + :: (MonadBaseControl IO m, MonadIO m, MonadReader env m, HasHttpManager env, HasConfig env, MonadMask m, MonadLogger m) => EnvOverride -> Path Abs Dir -- ^ unpack directory -> Maybe (Path Rel Dir) -- ^ the dist rename directory, see: https://github.com/fpco/stack/issues/157 @@ -242,7 +243,7 @@ data ToFetchResult = ToFetchResult -- | Add the cabal files to a list of idents with their caches. withCabalFiles - :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env) + :: (MonadMask m, MonadIO m, MonadLogger m, MonadReader env m, HasConfig env) => IndexName -> [(PackageIdentifier, PackageCache, a)] -> (PackageIdentifier -> a -> ByteString -> IO b) @@ -260,7 +261,7 @@ withCabalFiles name pkgs f = do -- | Provide a function which will load up a cabal @ByteString@ from the -- package indices. withCabalLoader - :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseControl IO m, MonadCatch m) + :: (MonadIO m, MonadReader env m, HasConfig env, MonadLogger m, HasHttpManager env, MonadBaseUnlift IO m, MonadMask m) => EnvOverride -> ((PackageIdentifier -> IO ByteString) -> m a) -> m a @@ -316,11 +317,11 @@ withCabalLoader menv inner = do inner doLookup lookupPackageIdentifierExact - :: HasConfig env + :: (MonadMask m, MonadIO m, MonadLogger m, HasConfig env) => PackageIdentifier -> env -> PackageCaches - -> IO (Maybe ByteString) + -> m (Maybe ByteString) lookupPackageIdentifierExact ident env caches = case Map.lookup ident caches of Nothing -> return Nothing @@ -361,7 +362,7 @@ typoCorrectionCandidates ident = . Map.mapKeys getName -- | Figure out where to fetch from. -getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env) +getToFetch :: (MonadMask m, MonadLogger m, MonadIO m, MonadReader env m, HasConfig env) => Maybe (Path Abs Dir) -- ^ directory to unpack into, @Nothing@ means no unpack -> Map PackageIdentifier ResolvedPackage -> m ToFetchResult diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 8593fef647..e89bcbf6b9 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -23,7 +23,7 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.RWS.Strict import Control.Monad.State.Strict -import Control.Monad.Trans.Resource +import Control.Monad.Trans.Unlift (MonadBaseUnlift) import qualified Data.ByteString.Char8 as S8 import Data.Either import Data.Function @@ -105,7 +105,7 @@ instance Show GhciException where -- given options and configure it with the load paths and extensions -- of those targets. ghci - :: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) + :: (HasConfig r, HasBuildConfig r, HasHttpManager r, MonadMask m, HasLogLevel r, HasTerminal r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m) => GhciOpts -> m () ghci opts@GhciOpts{..} = do bopts <- asks (configBuild . getConfig) @@ -256,7 +256,7 @@ figureOutMainFile bopts mainIsTargets targets0 packages = -- | Create a list of infos for each target containing necessary -- information to load that package/components. ghciSetup - :: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m) + :: (HasConfig r, HasHttpManager r, HasBuildConfig r, MonadMask m, HasTerminal r, HasLogLevel r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseUnlift IO m) => GhciOpts -> m (Map PackageName SimpleTarget, Maybe (Map PackageName SimpleTarget), [GhciPkgInfo]) ghciSetup GhciOpts{..} = do diff --git a/src/Stack/Ide.hs b/src/Stack/Ide.hs index 6f09903e31..3aa0053ca4 100644 --- a/src/Stack/Ide.hs +++ b/src/Stack/Ide.hs @@ -15,7 +15,7 @@ import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader -import Control.Monad.Trans.Control (MonadBaseControl) +import Control.Monad.Trans.Unlift (MonadBaseUnlift) import Data.List import Data.Maybe import Data.Monoid @@ -39,7 +39,7 @@ import System.Process.Run -- given options and configure it with the load paths and extensions -- of those targets. ide - :: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadBaseControl IO m, HasHttpManager r) + :: (HasConfig r, HasBuildConfig r, HasTerminal r, HasLogLevel r, MonadMask m, HasEnvConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadBaseUnlift IO m, HasHttpManager r) => [Text] -- ^ Targets. -> [String] -- ^ GHC options. -> m () diff --git a/src/Stack/Solver.hs b/src/Stack/Solver.hs index 0b78c1d24c..4b3b3a3a1c 100644 --- a/src/Stack/Solver.hs +++ b/src/Stack/Solver.hs @@ -496,7 +496,7 @@ getResolverConstraints stackYaml resolver = -- If the package flags are passed as 'Nothing' then flags are chosen -- automatically. checkResolverSpec - :: ( MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m + :: ( MonadIO m, MonadMask m, MonadLogger m, MonadReader env m , HasHttpManager env, HasConfig env, HasGHCVariant env , MonadBaseControl IO m) => [C.GenericPackageDescription] diff --git a/stack.cabal b/stack.cabal index eeb08833c3..b9d5ea73ca 100644 --- a/stack.cabal +++ b/stack.cabal @@ -177,6 +177,7 @@ library , microlens >= 0.3.0.0 , monad-control , monad-logger >= 0.3.13.1 + , monad-unlift , mtl >= 2.1.3.1 , open-browser >= 0.2.1 , optparse-applicative >= 0.11 && < 0.13 From ee71d62177c8c28e0c675f12acc677af325a751d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 27 Apr 2016 18:24:21 +0300 Subject: [PATCH 3/6] Plumb the GitSHA1 through a bunch of the codebase --- src/Stack/Build/ConstructPlan.hs | 12 ++++++------ src/Stack/Build/Execute.hs | 14 +++++++------- src/Stack/Build/Source.hs | 8 ++++++-- src/Stack/BuildPlan.hs | 18 ++++++++++-------- src/Stack/Dot.hs | 2 +- src/Stack/Package.hs | 2 +- src/Stack/SDist.hs | 2 +- src/Stack/Types/Build.hs | 5 +++-- src/Stack/Types/Package.hs | 7 ++++--- 9 files changed, 39 insertions(+), 31 deletions(-) diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 74378b4d28..b4631695b5 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/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 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 067bc61229..12b04df305 100644 --- a/src/Stack/Build/Execute.hs +++ b/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,7 +773,7 @@ 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 case Map.toList m of @@ -1078,7 +1078,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 +1170,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 diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 21c78ddba1..1dd9e363c5 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -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 diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index bb55cb4e95..71612d1fa3 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -268,19 +268,23 @@ addDeps allowMissing compilerVersion toCalc = do if allowMissing then do (missingNames, missingIdents, m) <- - resolvePackagesAllowMissing (Map.keysSet idents0) Set.empty + resolvePackagesAllowMissing (fmap snd idents0) Set.empty assert (Set.null missingNames) $ return (m, missingIdents) else do - m <- resolvePackages menv (Map.keysSet idents0) Set.empty + m <- resolvePackages menv (fmap snd idents0) Set.empty return (m, Set.empty) let byIndex = Map.fromListWith (++) $ flip map (Map.toList resolvedMap) $ \(ident, rp) -> - (indexName $ rpIndex rp, + let (cache, sha) = + case Map.lookup (packageIdentifierName ident) toCalc of + Nothing -> (Map.empty, Nothing) + Just (_, x, y) -> (x, y) + in (indexName $ rpIndex rp, [( ident , rpCache rp - , maybe (Map.empty, Nothing) sndthd3 - $ Map.lookup (packageIdentifierName ident) toCalc + , sha + , (cache, sha) )]) res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs $ \ident (flags, mgitSha) cabalBS -> do @@ -311,11 +315,9 @@ addDeps allowMissing compilerVersion toCalc = do return (Map.fromList $ concat res, missingIdents) where idents0 = Map.fromList - $ map (\(n, (v, f, _gitsha)) -> (PackageIdentifier n v, Left f)) + $ map (\(n, (v, f, gitsha)) -> (PackageIdentifier n v, (Left f, gitsha))) $ Map.toList toCalc - sndthd3 (_, x, y) = (x, y) - -- | Resolve all packages necessary to install for the needed packages. getDeps :: MiniBuildPlan -> (PackageName -> Bool) -- ^ is it shadowed by a local package? diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index b1bdce55be..24149e1326 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -189,7 +189,7 @@ createDepLoader :: Applicative m createDepLoader sourceMap installed loadPackageDeps pkgName = case Map.lookup pkgName sourceMap of Just (PSLocal lp) -> pure ((packageAllDeps &&& (Just . packageVersion)) (lpPackage lp)) - Just (PSUpstream version _ flags) -> loadPackageDeps pkgName version flags + Just (PSUpstream version _ flags _) -> loadPackageDeps pkgName version flags Nothing -> pure (Set.empty, fmap installedVersion (Map.lookup pkgName installed)) -- | Resolve the direct (depth 0) external dependencies of the given local packages diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index b5f98a5684..36fa49fe17 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -351,7 +351,7 @@ generateBuildInfoOpts sourceMap installedMap mcabalMacros cabalDir distDir omitP , let name = fromCabalPackageName cname , name `notElem` omitPkgs] -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ... - sourceVersion (PSUpstream ver _ _) = ver + sourceVersion (PSUpstream ver _ _ _) = ver sourceVersion (PSLocal localPkg) = packageVersion (lpPackage localPkg) ghcOpts = concatMap snd . filter (isGhc . fst) . options where diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 3dabb5fba2..66bdea6c2a 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -144,7 +144,7 @@ getCabalLbs pvpBounds fp = do lookupVersion name = case Map.lookup name sourceMap of Just (PSLocal lp) -> Just $ packageVersion $ lpPackage lp - Just (PSUpstream version _ _) -> Just version + Just (PSUpstream version _ _ _) -> Just version Nothing -> case Map.lookup name installedMap of Just (_, installed) -> Just (installedVersion installed) diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index c41c02ecac..6efe171372 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -71,6 +71,7 @@ import GHC.Generics (Generic, from, to) import Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, ()) import Path.Extra (toFilePathNoTrailingSep) import Prelude +import Stack.Types.BuildPlan (GitSHA1) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -519,14 +520,14 @@ instance Show TaskConfigOpts where -- | The type of a task, either building local code or something from the -- package index (upstream) data TaskType = TTLocal LocalPackage - | TTUpstream Package InstallLocation + | TTUpstream Package InstallLocation (Maybe GitSHA1) deriving Show taskLocation :: Task -> InstallLocation taskLocation task = case taskType task of TTLocal _ -> Local - TTUpstream _ loc -> loc + TTUpstream _ loc _ -> loc -- | A complete plan of what needs to be built and how to do it data Plan = Plan diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index 632c82b00c..a28b7a1402 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -37,6 +37,7 @@ import Distribution.Text (display) import GHC.Generics (Generic) import Path as FL import Prelude +import Stack.Types.BuildPlan (GitSHA1) import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.FlagName @@ -219,17 +220,17 @@ type SourceMap = Map PackageName PackageSource -- | Where the package's source is located: local directory or package index data PackageSource = PSLocal LocalPackage - | PSUpstream Version InstallLocation (Map FlagName Bool) + | PSUpstream Version InstallLocation (Map FlagName Bool) (Maybe GitSHA1) -- ^ Upstream packages could be installed in either local or snapshot -- databases; this is what 'InstallLocation' specifies. deriving Show instance PackageInstallInfo PackageSource where piiVersion (PSLocal lp) = packageVersion $ lpPackage lp - piiVersion (PSUpstream v _ _) = v + piiVersion (PSUpstream v _ _ _) = v piiLocation (PSLocal _) = Local - piiLocation (PSUpstream _ loc _) = loc + piiLocation (PSUpstream _ loc _ _) = loc -- | Datatype which tells how which version of a package to install and where -- to install it into From f483e820d23707ec4ddd3fcdf38385e36f769203 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 27 Apr 2016 18:25:47 +0300 Subject: [PATCH 4/6] Actually grab .cabal files via Git SHA when possible --- src/Stack/Build/Execute.hs | 3 +- src/Stack/Fetch.hs | 75 ++++++++++++++++++++++++++++++-------- src/Stack/Setup.hs | 5 ++- src/Stack/Types/Config.hs | 25 +++++++++++++ src/Stack/Upgrade.hs | 5 ++- stack.cabal | 1 + 6 files changed, 93 insertions(+), 21 deletions(-) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 12b04df305..d398109b60 100644 --- a/src/Stack/Build/Execute.hs +++ b/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 diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index afa334be12..0af758af04 100644 --- a/src/Stack/Fetch.hs +++ b/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 diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 8378b4bd45..17bb49c898 100644 --- a/src/Stack/Setup.hs +++ b/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 diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index e3e8aa1fb1..77f0c59795 100644 --- a/src/Stack/Types/Config.hs +++ b/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 diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 77d2df2bd8..9fb9612f61 100644 --- a/src/Stack/Upgrade.hs +++ b/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 diff --git a/stack.cabal b/stack.cabal index b9d5ea73ca..6835f262fd 100644 --- a/stack.cabal +++ b/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 From 44f433f7d3354a51d53e9e8091678f2cabfc1df7 Mon Sep 17 00:00:00 2001 From: Michael Sloan Date: Wed, 27 Apr 2016 17:25:56 -0700 Subject: [PATCH 5/6] Fix build on GHC 7.8 --- src/Stack/Fetch.hs | 2 +- stack-7.8.yaml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 0af758af04..69bddd2152 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -60,7 +60,7 @@ import qualified Data.List.NonEmpty as NE import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (maybeToList, catMaybes) -import Data.Monoid ((<>)) +import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import Data.String (fromString) diff --git a/stack-7.8.yaml b/stack-7.8.yaml index bd87186e93..5dce00f3fb 100644 --- a/stack-7.8.yaml +++ b/stack-7.8.yaml @@ -46,3 +46,4 @@ extra-deps: - http-client-tls-0.2.4 - connection-0.2.5 - regex-applicative-text-0.1.0.1 +- monad-unlift-0.1.1.0 From e18d8b55c44fbbffeee68a57b195d1bda397f55c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 3 May 2016 08:07:55 +0300 Subject: [PATCH 6/6] Changelog and compilation fixes --- ChangeLog.md | 3 +++ src/Stack/Fetch.hs | 2 +- src/test/Stack/BuildPlanSpec.hs | 1 + 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 4eefdc4582..0c51e2e6b1 100644 --- a/ChangeLog.md +++ b/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 diff --git a/src/Stack/Fetch.hs b/src/Stack/Fetch.hs index 69bddd2152..960b6b7f49 100644 --- a/src/Stack/Fetch.hs +++ b/src/Stack/Fetch.hs @@ -326,7 +326,7 @@ withCabalLoader menv inner = do -> IO ByteString doLookup ident = do caches <- loadCaches - eres <- unlift $ lookupPackageIdentifierExact ident env cachesCurr + eres <- unlift $ lookupPackageIdentifierExact ident env caches case eres of Just bs -> return bs -- Update the cache and try again diff --git a/src/test/Stack/BuildPlanSpec.hs b/src/test/Stack/BuildPlanSpec.hs index 35e7af5341..73e198b232 100644 --- a/src/test/Stack/BuildPlanSpec.hs +++ b/src/test/Stack/BuildPlanSpec.hs @@ -87,6 +87,7 @@ spec = beforeAll setup $ afterAll teardown $ do , mpiToolDeps = Set.empty , mpiExes = Set.empty , mpiHasLibrary = True + , mpiGitSHA1 = Nothing } go x y = (pn x, mkMPI y) resourcet = go "resourcet" ""