[commit: Cabal] master: Insert a separate fetch stage to the install process (468946e)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/468946e23ef6240c8bc7d778f1cd4736b090b9cd

>---------------------------------------------------------------

commit 468946e23ef6240c8bc7d778f1cd4736b090b9cd
Author: Duncan Coutts <duncan at community.haskell.org>
Date:   Sun Feb 13 20:08:24 2011 +0000

    Insert a separate fetch stage to the install process
    Helps to clarify things now that different kinds of packages
    are fetched in different ways.

>---------------------------------------------------------------

 cabal-install/Distribution/Client/FetchUtils.hs |   22 +++++
 cabal-install/Distribution/Client/Install.hs    |   98 +++++++++++------------
 2 files changed, 69 insertions(+), 51 deletions(-)

diff --git a/cabal-install/Distribution/Client/FetchUtils.hs b/cabal-install/Distribution/Client/FetchUtils.hs
index ed807c0..3f5be0a 100644
--- a/cabal-install/Distribution/Client/FetchUtils.hs
+++ b/cabal-install/Distribution/Client/FetchUtils.hs
@@ -16,6 +16,7 @@ module Distribution.Client.FetchUtils (
     -- * fetching packages
     fetchPackage,
     isFetched,
+    checkFetched,
 
     -- ** specifically for repo packages
     fetchRepoTarball,
@@ -64,6 +65,27 @@ isFetched loc = case loc of
     RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)
 
 
+checkFetched :: PackageLocation (Maybe FilePath)
+             -> IO (Maybe (PackageLocation FilePath))
+checkFetched loc = case loc of
+    LocalUnpackedPackage dir  ->
+      return (Just $ LocalUnpackedPackage dir)
+    LocalTarballPackage  file ->
+      return (Just $ LocalTarballPackage  file)
+    RemoteTarballPackage uri (Just file) ->
+      return (Just $ RemoteTarballPackage uri file)
+    RepoTarballPackage repo pkgid (Just file) ->
+      return (Just $ RepoTarballPackage repo pkgid file)
+
+    RemoteTarballPackage _uri Nothing -> return Nothing
+    RepoTarballPackage repo pkgid Nothing -> do
+      let file = packageFile repo pkgid
+      exists <- doesFileExist file
+      if exists
+        then return (Just $ RepoTarballPackage repo pkgid file)
+        else return Nothing
+
+
 -- | Fetch a package if we don't have it already.
 --
 fetchPackage :: Verbosity
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index 0136380..b3a8ee5 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -53,9 +53,6 @@ import Distribution.Client.Dependency
          , PackagePreference(..)
          , Progress(..), foldProgress, )
 import Distribution.Client.FetchUtils
-         ( fetchRepoTarball )
-import Distribution.Client.HttpUtils
-         ( downloadURI )
 import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
 -- import qualified Distribution.Client.Info as Info
 import Distribution.Client.IndexUtils as IndexUtils
@@ -658,10 +655,11 @@ performInstallations verbosity
   executeInstallPlan installPlan $ \cpkg ->
     installConfiguredPackage platform compid configFlags
                              cpkg $ \configFlags' src pkg ->
-      installAvailablePackage verbosity (packageId pkg) src $ \mpath ->
-        installUnpackedPackage verbosity (setupScriptOptions installed)
-                               miscOptions configFlags' installFlags
-                               compid pkg mpath useLogFile
+      fetchAvailablePackage verbosity src $ \src' ->
+        installLocalPackage verbosity (packageId pkg) src' $ \mpath ->
+          installUnpackedPackage verbosity (setupScriptOptions installed)
+                                 miscOptions configFlags' installFlags
+                                 compid pkg mpath useLogFile
 
   where
     platform = InstallPlan.planPlatform installPlan
@@ -759,59 +757,57 @@ installConfiguredPackage platform comp configFlags
       Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
       Right (desc, _) -> desc
 
+fetchAvailablePackage
+  :: Verbosity
+  -> PackageLocation (Maybe FilePath)
+  -> (PackageLocation FilePath -> IO BuildResult)
+  -> IO BuildResult
+fetchAvailablePackage verbosity src installPkg = do
+  fetched <- checkFetched src
+  case fetched of
+    Just src' -> installPkg src'
+    Nothing   -> onFailure DownloadFailed $
+                   fetchPackage verbosity src >>= installPkg
+
 
-installAvailablePackage
-  :: Verbosity -> PackageIdentifier -> PackageLocation (Maybe FilePath)
+installLocalPackage
+  :: Verbosity -> PackageIdentifier -> PackageLocation FilePath
   -> (Maybe FilePath -> IO BuildResult)
   -> IO BuildResult
-installAvailablePackage _ _ (LocalUnpackedPackage dir) installPkg =
-  installPkg (Just dir)
+installLocalPackage verbosity pkgid location installPkg = case location of
 
-installAvailablePackage verbosity pkgid
-                        (LocalTarballPackage tarballPath) installPkg = do
-  tmp <- getTemporaryDirectory
-  withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
-    installLocalTarballPackage verbosity pkgid
-                               tarballPath tmpDirPath installPkg
+    LocalUnpackedPackage dir ->
+      installPkg (Just dir)
+
+    LocalTarballPackage tarballPath ->
+      installLocalTarballPackage verbosity pkgid tarballPath installPkg
+
+    RemoteTarballPackage _ tarballPath ->
+      installLocalTarballPackage verbosity pkgid tarballPath installPkg
+
+    RepoTarballPackage _ _ tarballPath ->
+      installLocalTarballPackage verbosity pkgid tarballPath installPkg
 
-installAvailablePackage verbosity pkgid
-                        (RemoteTarballPackage tarballURL _) installPkg = do
-  tmp <- getTemporaryDirectory
-  withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
-    onFailure DownloadFailed $ do
-      let tarballPath = tmpDirPath </> display pkgid <.> "tar.gz"
-      --TODO: perhaps we've already had to download this to a local cache
-      --      so we even know what package version it is. So might be able
-      --      to get it from the local cache rather than from remote.
-      downloadURI verbosity tarballURL tarballPath
-      installLocalTarballPackage verbosity pkgid
-                                 tarballPath tmpDirPath installPkg
-
-installAvailablePackage verbosity pkgid (RepoTarballPackage repo _ _) installPkg =
-  onFailure DownloadFailed $ do
-    tarballPath <- fetchRepoTarball verbosity repo pkgid
-    tmp <- getTemporaryDirectory
-    withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
-      installLocalTarballPackage verbosity pkgid
-                                 tarballPath tmpDirPath installPkg
 
 installLocalTarballPackage
-  :: Verbosity -> PackageIdentifier -> FilePath -> FilePath
+  :: Verbosity -> PackageIdentifier -> FilePath
   -> (Maybe FilePath -> IO BuildResult)
   -> IO BuildResult
-installLocalTarballPackage verbosity pkgid tarballPath tmpDirPath installPkg =
-  onFailure UnpackFailed $ do
-    info verbosity $ "Extracting " ++ tarballPath
-                  ++ " to " ++ tmpDirPath ++ "..."
-    let relUnpackedPath = display pkgid
-        absUnpackedPath = tmpDirPath </> relUnpackedPath
-        descFilePath = absUnpackedPath
-                   </> display (packageName pkgid) <.> "cabal"
-    extractTarGzFile tmpDirPath relUnpackedPath tarballPath
-    exists <- doesFileExist descFilePath
-    when (not exists) $
-      die $ "Package .cabal file not found: " ++ show descFilePath
-    installPkg (Just absUnpackedPath)
+installLocalTarballPackage verbosity pkgid tarballPath installPkg = do
+  tmp <- getTemporaryDirectory
+  withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->
+    onFailure UnpackFailed $ do
+      info verbosity $ "Extracting " ++ tarballPath
+                    ++ " to " ++ tmpDirPath ++ "..."
+      let relUnpackedPath = display pkgid
+          absUnpackedPath = tmpDirPath </> relUnpackedPath
+          descFilePath = absUnpackedPath
+                     </> display (packageName pkgid) <.> "cabal"
+      extractTarGzFile tmpDirPath relUnpackedPath tarballPath
+      exists <- doesFileExist descFilePath
+      when (not exists) $
+        die $ "Package .cabal file not found: " ++ show descFilePath
+      installPkg (Just absUnpackedPath)
 
 
 installUnpackedPackage :: Verbosity