Commit db785667 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

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.
parent cdacc518
......@@ -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
-- ------------------------------------------------------------
......
......@@ -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
......
......@@ -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,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment