From cdacc518807e479855abc4981c1871a8fc651cec Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 26 Jul 2016 18:28:36 +0100 Subject: [PATCH 1/5] Convert new-build to use the common BuildSuccess/Failure types As a result of the previous InstallPlan refactoring, we can now use the non-serialisable BuildFailure type from D.C.Types which uses SomeException, where previously we had to use a copy of that type that used String for the errors. So now there's no longer any need to have a separate set of types for BuildResult, BuildResults, BuildSuccess or BuildFailure. There was a minor difference in the structure of the BuildSuccess, where in the new build code we need to be able to produce the InstalledPackageInfo at a different point from the rest of the info in the BuildSuccess. This can be kept local to the ProjecBuilding module, but accounts for the somewhat larger number of changes in that module. --- .../Distribution/Client/ProjectBuilding.hs | 66 ++++++++++--------- .../Client/ProjectOrchestration.hs | 4 +- .../Distribution/Client/ProjectPlanning.hs | 12 ---- .../Client/ProjectPlanning/Types.hs | 56 ---------------- cabal-install/Distribution/Client/Types.hs | 11 +++- 5 files changed, 45 insertions(+), 104 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index bbeb7385d26..f0e36774dcf 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -5,12 +5,19 @@ -- | -- module Distribution.Client.ProjectBuilding ( + -- * Dry run phase BuildStatus(..), BuildStatusMap, BuildStatusRebuild(..), BuildReason(..), MonitorChangedReason(..), rebuildTargetsDryRun, + + -- * Build phase + BuildResult, + BuildResults, + BuildFailure(..), + BuildSuccess(..), rebuildTargets ) where @@ -20,8 +27,6 @@ import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning import Distribution.Client.Types - ( PackageLocation(..), GenericReadyPackage(..) - , InstalledPackageId, installedPackageId ) import Distribution.Client.InstallPlan ( GenericInstallPlan, GenericPlanPackage ) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -152,7 +157,7 @@ data BuildStatus = -- | The package exists in a local dir already, and is fully up to date. -- So this package can be put into the 'InstallPlan.Installed' state -- and it does not need to be built. - | BuildStatusUpToDate [InstalledPackageInfo] BuildSuccess + | BuildStatusUpToDate BuildSuccess -- | For a package that is going to be built or rebuilt, the state it's in now. -- @@ -293,8 +298,8 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do return (BuildStatusRebuild srcdir rebuild) -- No changes, the package is up to date. Use the saved build results. - Right (ipkgs, buildSuccess) -> - return (BuildStatusUpToDate ipkgs buildSuccess) + Right buildSuccess -> + return (BuildStatusUpToDate buildSuccess) where packageFileMonitor = newPackageFileMonitor distDirLayout (packageId pkg) @@ -346,7 +351,7 @@ improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus = <- InstallPlan.reverseTopologicalOrder installPlan , let ipkgid = installedPackageId pkg Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus - , BuildStatusUpToDate ipkgs _buildSuccess <- [pkgBuildStatus] + , BuildStatusUpToDate (BuildOk _ _ ipkgs) <- [pkgBuildStatus] ] where replaceWithPrePreExisting = @@ -374,10 +379,18 @@ improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus = -- data PackageFileMonitor = PackageFileMonitor { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), - pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildSuccess, + pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildSuccessMisc, pkgFileMonitorReg :: FileMonitor () [InstalledPackageInfo] } +-- | This is all the components of the 'BuildSuccess' other than the +-- @['InstalledPackageInfo']@. +-- +-- We have to split up the 'BuildSuccess' components since they get produced +-- at different times (or rather, when different things change). +-- +type BuildSuccessMisc = (DocsResult, TestsResult) + newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid = PackageFileMonitor { @@ -433,9 +446,7 @@ checkPackageFileMonitorChanged :: PackageFileMonitor -> ElaboratedConfiguredPackage -> FilePath -> ComponentDeps [BuildStatus] - -> IO (Either BuildStatusRebuild - ([InstalledPackageInfo], - BuildSuccess)) + -> IO (Either BuildStatusRebuild BuildSuccess) checkPackageFileMonitorChanged PackageFileMonitor{..} pkg srcdir depsBuildStatus = do --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged @@ -490,7 +501,9 @@ checkPackageFileMonitorChanged PackageFileMonitor{..} buildReason = BuildReasonEphemeralTargets (MonitorUnchanged buildSuccess _, MonitorUnchanged ipkgs _) -> - return (Right (ipkgs, buildSuccess)) + return (Right (BuildOk docsResult testsResult ipkgs)) + where + (docsResult, testsResult) = buildSuccess where (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg changedToMaybe (MonitorChanged _) = Nothing @@ -514,7 +527,7 @@ updatePackageBuildFileMonitor :: PackageFileMonitor -> ElaboratedConfiguredPackage -> BuildStatusRebuild -> [FilePath] - -> BuildSuccess + -> BuildSuccessMisc -> IO () updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} srcdir timestamp pkg pkgBuildStatus @@ -602,9 +615,7 @@ rebuildTargets verbosity -- For each package in the plan, in dependency order, but in parallel... InstallPlan.execute jobControl keepGoing (DependentFailed . packageId) installPlan $ \pkg -> - fmap (\x -> case x of BuildFailure f -> Left f - BuildSuccess _ s -> Right s) $ - handle (return . BuildFailure) $ --TODO: review exception handling + handle (return . Left) $ fmap Right $ --TODO: review exception handling let ipkgid = installedPackageId pkg Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus in @@ -641,7 +652,7 @@ rebuildTarget :: Verbosity -> ElaboratedSharedConfig -> ElaboratedReadyPackage -> BuildStatus - -> IO BuildResult + -> IO BuildSuccess rebuildTarget verbosity distDirLayout@DistDirLayout{distBuildDirectory} buildSettings downloadMap @@ -900,7 +911,7 @@ buildAndInstallUnpackedPackage :: Verbosity -> ElaboratedSharedConfig -> ElaboratedReadyPackage -> FilePath -> FilePath - -> IO BuildResult + -> IO BuildSuccess buildAndInstallUnpackedPackage verbosity DistDirLayout{distTempDirectory} BuildTimeSettings { @@ -942,7 +953,7 @@ buildAndInstallUnpackedPackage verbosity setup buildCommand buildFlags -- Install phase - mipkg <- + ipkgs <- annotateFailure InstallFailed $ do --TODO: [required eventually] need to lock installing this ipkig so other processes don't -- stomp on our files, since we don't have ABI compat, not safe to replace @@ -997,7 +1008,7 @@ buildAndInstallUnpackedPackage verbosity let docsResult = DocsNotTried testsResult = TestsNotTried - return (BuildSuccess mipkg (BuildOk docsResult testsResult)) + return (BuildOk docsResult testsResult ipkgs) where pkgid = packageId rpkg @@ -1063,7 +1074,7 @@ buildInplaceUnpackedPackage :: Verbosity -> ElaboratedReadyPackage -> BuildStatusRebuild -> FilePath -> FilePath - -> IO BuildResult + -> IO BuildSuccess buildInplaceUnpackedPackage verbosity distDirLayout@DistDirLayout { distTempDirectory, @@ -1097,8 +1108,8 @@ buildInplaceUnpackedPackage verbosity let docsResult = DocsNotTried testsResult = TestsNotTried - buildSuccess :: BuildSuccess - buildSuccess = BuildOk docsResult testsResult + buildSuccess :: BuildSuccessMisc + buildSuccess = (docsResult, testsResult) whenRebuild $ do timestamp <- beginUpdateFileMonitor @@ -1197,7 +1208,7 @@ buildInplaceUnpackedPackage verbosity annotateFailure BuildFailed $ setup haddockCommand haddockFlags [] - return (BuildSuccess ipkgs buildSuccess) + return (BuildOk docsResult testsResult ipkgs) where pkgid = packageId rpkg @@ -1270,7 +1281,7 @@ buildInplaceUnpackedPackage verbosity -- helper -annotateFailure :: (String -> BuildFailure) -> IO a -> IO a +annotateFailure :: (SomeException -> BuildFailure) -> IO a -> IO a annotateFailure annotate action = action `catches` [ Handler $ \ioe -> handler (ioe :: IOException) @@ -1278,12 +1289,7 @@ annotateFailure annotate action = ] where handler :: Exception e => e -> IO a - handler = throwIO . annotate -#if MIN_VERSION_base(4,8,0) - . displayException -#else - . show -#endif + handler = throwIO . annotate . toException withTempInstalledPackageInfoFiles :: Verbosity -> FilePath diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 924ee0d6442..6b332102c7b 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -60,8 +60,6 @@ import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectBuilding import Distribution.Client.Types - hiding ( BuildResult, BuildResults, BuildSuccess(..) - , BuildFailure(..), DocsResult(..), TestsResult(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.BuildTarget ( UserBuildTarget, resolveUserBuildTargets @@ -208,7 +206,7 @@ runProjectBuildPhase verbosity ProjectBuildContext {..} = previousBuildResults :: BuildStatusMap -> BuildResults previousBuildResults = Map.mapMaybe $ \status -> case status of - BuildStatusUpToDate _ buildSuccess -> Just (Right buildSuccess) + BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess) --TODO: [nice to have] record build failures persistently _ -> Nothing diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 55530e42f26..aea11ebea94 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -12,16 +12,6 @@ module Distribution.Client.ProjectPlanning ( BuildStyle(..), CabalFileText, - --TODO: [code cleanup] these types should live with execution, not with - -- plan definition. Need to better separate InstallPlan definition. - GenericBuildResult(..), - BuildResult, - BuildResults, - BuildSuccess(..), - BuildFailure(..), - DocsResult(..), - TestsResult(..), - -- * Producing the elaborated install plan rebuildInstallPlan, @@ -62,8 +52,6 @@ import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanOutput import Distribution.Client.Types - hiding ( BuildResult, BuildResults, BuildSuccess(..) - , BuildFailure(..), DocsResult(..), TestsResult(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Dependency diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index 0d18e565ae5..2eb617a8f22 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -16,17 +16,6 @@ module Distribution.Client.ProjectPlanning.Types ( BuildStyle(..), CabalFileText, - -- * Types used in executing an install plan - --TODO: [code cleanup] these types should live with execution, not with - -- plan definition. Need to better separate InstallPlan definition. - GenericBuildResult(..), - BuildResult, - BuildResults, - BuildSuccess(..), - BuildFailure(..), - DocsResult(..), - TestsResult(..), - -- * Build targets PackageTarget(..), ComponentTarget(..), @@ -68,8 +57,6 @@ import Data.Set (Set) import qualified Data.ByteString.Lazy as LBS import Distribution.Compat.Binary import GHC.Generics (Generic) -import Data.Typeable (Typeable) -import Control.Exception @@ -280,49 +267,6 @@ type CabalFileText = LBS.ByteString type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage ---TODO: [code cleanup] this duplicates the InstalledPackageInfo quite a bit in an install plan --- because the same ipkg is used by many packages. So the binary file will be big. --- Could we keep just (ipkgid, deps) instead of the whole InstalledPackageInfo? --- or transform to a shared form when serialising / deserialising - -data GenericBuildResult ipkg iresult ifailure - = BuildFailure ifailure - | BuildSuccess [ipkg] iresult - deriving (Eq, Show, Generic) - -instance (Binary ipkg, Binary iresult, Binary ifailure) => - Binary (GenericBuildResult ipkg iresult ifailure) - -type BuildResult = GenericBuildResult InstalledPackageInfo - BuildSuccess BuildFailure -type BuildResults = Map UnitId (Either BuildFailure BuildSuccess) - -data BuildSuccess = BuildOk DocsResult TestsResult - deriving (Eq, Show, Generic) - -data DocsResult = DocsNotTried | DocsFailed | DocsOk - deriving (Eq, Show, Generic) - -data TestsResult = TestsNotTried | TestsOk - deriving (Eq, Show, Generic) - -data BuildFailure = PlanningFailed --TODO: [required eventually] not yet used - | DependentFailed PackageId - | DownloadFailed String --TODO: [required eventually] not yet used - | UnpackFailed String --TODO: [required eventually] not yet used - | ConfigureFailed String - | BuildFailed String - | TestsFailed String --TODO: [required eventually] not yet used - | InstallFailed String - deriving (Eq, Show, Typeable, Generic) - -instance Exception BuildFailure - -instance Binary BuildFailure -instance Binary BuildSuccess -instance Binary DocsResult -instance Binary TestsResult - --------------------------- -- Build targets diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index c3362e39011..ed05daa826f 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -39,7 +40,8 @@ import Distribution.Solver.Types.SourcePackage import Data.Map (Map) import Network.URI (URI(..), URIAuth(..), nullURI) import Control.Exception - ( SomeException ) + ( Exception, SomeException ) +import Data.Typeable (Typeable) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary(..)) @@ -266,7 +268,7 @@ maybeRepoRemote (RepoSecure r _localDir) = Just r -- ------------------------------------------------------------ type BuildResult = Either BuildFailure BuildSuccess -type BuildResults = Map UnitId (Either BuildFailure BuildSuccess) +type BuildResults = Map UnitId BuildResult data BuildFailure = PlanningFailed | DependentFailed PackageId @@ -276,7 +278,10 @@ data BuildFailure = PlanningFailed | BuildFailed SomeException | TestsFailed SomeException | InstallFailed SomeException - deriving (Show, Generic) + deriving (Show, Typeable, Generic) + +instance Exception BuildFailure + data BuildSuccess = BuildOk DocsResult TestsResult [InstalledPackageInfo] deriving (Show, Generic) From db785667b83f74a8947358e331327f52f9c20761 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sun, 26 Jun 2016 23:03:41 +0100 Subject: [PATCH 2/5] Refactor async download code Split things up a little so the generic async fetch can live with the other fetch utils. This also makes it easier to test. Change the exception handling so that any exception in fetching is propagated when collecting the fetch result. --- .../Distribution/Client/FetchUtils.hs | 68 ++++++++++++++++- .../Distribution/Client/ProjectBuilding.hs | 73 +++++++------------ cabal-install/cabal-install.cabal | 2 + 3 files changed, 94 insertions(+), 49 deletions(-) diff --git a/cabal-install/Distribution/Client/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs index 017b2d81e63..2b2d02f50e7 100644 --- a/cabal-install/Distribution/Client/FetchUtils.hs +++ b/cabal-install/Distribution/Client/FetchUtils.hs @@ -23,6 +23,11 @@ module Distribution.Client.FetchUtils ( checkRepoTarballFetched, fetchRepoTarball, + -- ** fetching packages asynchronously + asyncFetchPackages, + waitAsyncFetchPackage, + AsyncFetchMap, + -- * fetching other things downloadIndex, ) where @@ -35,7 +40,7 @@ import Distribution.Client.HttpUtils import Distribution.Package ( PackageId, packageName, packageVersion ) import Distribution.Simple.Utils - ( notice, info, setupMessage ) + ( notice, info, debug, setupMessage ) import Distribution.Text ( display ) import Distribution.Verbosity @@ -44,6 +49,12 @@ import Distribution.Client.GlobalFlags ( RepoContext(..) ) import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Monad +import Control.Exception +import Control.Concurrent.Async +import Control.Concurrent.MVar import System.Directory ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.IO @@ -185,6 +196,61 @@ downloadIndex transport verbosity remoteRepo cacheDir = do downloadURI transport verbosity uri path +-- ------------------------------------------------------------ +-- * Async fetch wrapper utilities +-- ------------------------------------------------------------ + +type AsyncFetchMap = Map UnresolvedPkgLoc + (MVar (Either SomeException ResolvedPkgLoc)) + +-- | Fork off an async action to download the given packages (by location). +-- +-- The downloads are initiated in order, so you can arrange for packages that +-- will likely be needed sooner to be earlier in the list. +-- +-- The body action is passed a map from those packages (identified by their +-- location) to a completion var for that package. So the body action should +-- lookup the location and use 'asyncFetchPackage' to get the result. +-- +asyncFetchPackages :: Verbosity + -> RepoContext + -> [UnresolvedPkgLoc] + -> (AsyncFetchMap -> IO a) + -> IO a +asyncFetchPackages verbosity repoCtxt pkglocs body = do + --TODO: [nice to have] use parallel downloads? + + asyncDownloadVars <- sequence [ do v <- newEmptyMVar + return (pkgloc, v) + | pkgloc <- pkglocs ] + + let fetchPackages :: IO () + fetchPackages = + forM_ asyncDownloadVars $ \(pkgloc, var) -> do + result <- try $ fetchPackage verbosity repoCtxt pkgloc + putMVar var result + + withAsync fetchPackages $ \_ -> + body (Map.fromList asyncDownloadVars) + + +-- | Expect to find a download in progress in the given 'AsyncFetchMap' +-- and wait on it to finish. +-- +-- If the download failed with an exception then this will be thrown. +-- +waitAsyncFetchPackage :: Verbosity + -> AsyncFetchMap + -> UnresolvedPkgLoc + -> IO ResolvedPkgLoc +waitAsyncFetchPackage verbosity downloadMap srcloc = + case Map.lookup srcloc downloadMap of + Just hnd -> do + debug verbosity $ "Waiting for download of " ++ show srcloc + either throwIO return =<< takeMVar hnd + Nothing -> fail "waitAsyncFetchPackage: package not being download" + + -- ------------------------------------------------------------ -- * Path utilities -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index f0e36774dcf..4a6a88fe4b3 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -68,13 +68,8 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as LBS -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Control.Monad import Control.Exception -import Control.Concurrent.Async -import Control.Concurrent.MVar import Data.List import Data.Maybe @@ -647,7 +642,7 @@ rebuildTargets verbosity rebuildTarget :: Verbosity -> DistDirLayout -> BuildTimeSettings - -> AsyncDownloadMap + -> AsyncFetchMap -> Lock -> Lock -> ElaboratedSharedConfig -> ElaboratedReadyPackage @@ -727,20 +722,6 @@ rebuildTarget verbosity --TODO: [nice to have] do we need to use a with-style for the temp files for downloading http -- packages, or are we going to cache them persistently? -type AsyncDownloadMap = Map (PackageLocation (Maybe FilePath)) - (MVar DownloadedSourceLocation) - -data DownloadedSourceLocation = DownloadedTarball FilePath - --TODO: [nice to have] git/darcs repos etc - -downloadedSourceLocation :: PackageLocation FilePath - -> Maybe DownloadedSourceLocation -downloadedSourceLocation pkgloc = - case pkgloc of - RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) - RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) - _ -> Nothing - -- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the -- packages we have to download and fork off an async action to download them. -- We download them in dependency order so that the one's we'll need @@ -751,28 +732,16 @@ downloadedSourceLocation pkgloc = -- lookup the location and use 'waitAsyncPackageDownload' to get the result. -- asyncDownloadPackages :: Verbosity - -> ((RepoContext -> IO ()) -> IO ()) + -> ((RepoContext -> IO a) -> IO a) -> ElaboratedInstallPlan -> BuildStatusMap - -> (AsyncDownloadMap -> IO a) + -> (AsyncFetchMap -> IO a) -> IO a asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body | null pkgsToDownload = body Map.empty - | otherwise = do - --TODO: [research required] use parallel downloads? if so, use the fetchLimit - - asyncDownloadVars <- mapM (\loc -> (,) loc <$> newEmptyMVar) pkgsToDownload - - let downloadAction :: IO () - downloadAction = - withRepoCtx $ \repoctx -> - forM_ asyncDownloadVars $ \(pkgloc, var) -> do - Just scrloc <- downloadedSourceLocation <$> - fetchPackage verbosity repoctx pkgloc - putMVar var scrloc - - withAsync downloadAction $ \_ -> - body (Map.fromList asyncDownloadVars) + | otherwise = withRepoCtx $ \repoctx -> + asyncFetchPackages verbosity repoctx + pkgsToDownload body where pkgsToDownload = [ pkgSourceLocation pkg @@ -785,21 +754,29 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body -- | Check if a package needs downloading, and if so expect to find a download --- in progress in the given 'AsyncDownloadMap' and wait on it to finish. +-- in progress in the given 'AsyncFetchMap' and wait on it to finish. -- waitAsyncPackageDownload :: Verbosity - -> AsyncDownloadMap + -> AsyncFetchMap -> ElaboratedConfiguredPackage -> IO DownloadedSourceLocation -waitAsyncPackageDownload verbosity downloadMap pkg = - case Map.lookup (pkgSourceLocation pkg) downloadMap of - Just hnd -> do - debug verbosity $ - "Waiting for download of " ++ display (packageId pkg) ++ " to finish" - --TODO: [required eventually] do the exception handling on download stuff - takeMVar hnd - Nothing -> - fail "waitAsyncPackageDownload: package not being download" +waitAsyncPackageDownload verbosity downloadMap pkg = do + pkgloc <- waitAsyncFetchPackage verbosity downloadMap + (pkgSourceLocation pkg) + case downloadedSourceLocation pkgloc of + Just loc -> return loc + Nothing -> fail "waitAsyncPackageDownload: unexpected source location" + +data DownloadedSourceLocation = DownloadedTarball FilePath + --TODO: [nice to have] git/darcs repos etc + +downloadedSourceLocation :: PackageLocation FilePath + -> Maybe DownloadedSourceLocation +downloadedSourceLocation pkgloc = + case pkgloc of + RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) + RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) + _ -> Nothing diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 55b01bebf39..3a2d5e5baaa 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -396,6 +396,7 @@ Test-Suite unit-tests UnitTests.Options build-depends: base, + async, array, bytestring, Cabal, @@ -460,6 +461,7 @@ Test-Suite solver-quickcheck UnitTests.Distribution.Solver.Modular.QuickCheck build-depends: base, + async, array, bytestring, Cabal, From 49b31ed73057b49026a36471b18d0a7e297b0ceb Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sun, 26 Jun 2016 23:11:18 +0100 Subject: [PATCH 3/5] Annotate exceptions in downloading packages Download errors are now put into the residual install plan, like other build errors. Fixes issue #3387 --- .../Distribution/Client/ProjectBuilding.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index 4a6a88fe4b3..dc43f29899b 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -76,7 +76,6 @@ import Data.Maybe import System.FilePath import System.IO import System.Directory -import System.Exit (ExitCode) ------------------------------------------------------------------------------ @@ -669,7 +668,8 @@ rebuildTarget verbosity unexpectedState = error "rebuildTarget: unexpected package status" downloadPhase = do - downsrcloc <- waitAsyncPackageDownload verbosity downloadMap pkg + downsrcloc <- annotateFailure DownloadFailed $ + waitAsyncPackageDownload verbosity downloadMap pkg case downsrcloc of DownloadedTarball tarball -> unpackTarballPhase tarball --TODO: [nice to have] git/darcs repos etc @@ -1261,8 +1261,16 @@ buildInplaceUnpackedPackage verbosity annotateFailure :: (SomeException -> BuildFailure) -> IO a -> IO a annotateFailure annotate action = action `catches` - [ Handler $ \ioe -> handler (ioe :: IOException) - , Handler $ \exit -> handler (exit :: ExitCode) + -- It's not just IOException and ExitCode we have to deal with, there's + -- lots, including exceptions from the hackage-security and tar packages. + -- So we take the strategy of catching everything except async exceptions. + [ +#if MIN_VERSION_base(4,7,0) + Handler $ \async -> throwIO (async :: SomeAsyncException) +#else + Handler $ \async -> throwIO (async :: AsyncException) +#endif + , Handler $ \other -> handler (other :: SomeException) ] where handler :: Exception e => e -> IO a From 04eb17344777722653f595f11a81dacab13632dc Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 26 Jul 2016 19:06:56 +0100 Subject: [PATCH 4/5] Spelling/grammar --- cabal-install/Distribution/Client/FetchUtils.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-install/Distribution/Client/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs index 2b2d02f50e7..97a996d751a 100644 --- a/cabal-install/Distribution/Client/FetchUtils.hs +++ b/cabal-install/Distribution/Client/FetchUtils.hs @@ -248,7 +248,7 @@ waitAsyncFetchPackage verbosity downloadMap srcloc = Just hnd -> do debug verbosity $ "Waiting for download of " ++ show srcloc either throwIO return =<< takeMVar hnd - Nothing -> fail "waitAsyncFetchPackage: package not being download" + Nothing -> fail "waitAsyncFetchPackage: package not being downloaded" -- ------------------------------------------------------------ From c5db03ccae66859814edde423cb01a6932568d1f Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 26 Jul 2016 19:50:18 +0100 Subject: [PATCH 5/5] Improve documentation of BuildResult vs BuildStatus --- cabal-install/Distribution/Client/ProjectBuilding.hs | 11 ++++++++--- cabal-install/Distribution/Client/Types.hs | 5 +++++ 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index dc43f29899b..70cbb46cd55 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -114,12 +114,17 @@ import System.Directory -- (that would make it harder to reproduce the problem sitation). --- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan' +-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. +-- +-- This is used as the result of the dry-run of building an install plan. -- type BuildStatusMap = Map InstalledPackageId BuildStatus --- | The build status for an individual package. That is, the state that the --- package is in prior to initiating a (re)build. +-- | The build status for an individual package is the state that the +-- package is in /prior/ to initiating a (re)build. +-- +-- This should not be confused with a 'BuildResult' which is the outcome +-- /after/ building a package. -- -- It serves two purposes: -- diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index ed05daa826f..77a21f68eec 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -267,7 +267,12 @@ maybeRepoRemote (RepoSecure r _localDir) = Just r -- * Build results -- ------------------------------------------------------------ +-- | A summary of the outcome for building a single package. +-- type BuildResult = Either BuildFailure BuildSuccess + +-- | A summary of the outcome for building a whole set of packages. +-- type BuildResults = Map UnitId BuildResult data BuildFailure = PlanningFailed