[commit: Cabal] : Refactor and update the hackage index reading code (b21f541)

[Ian Lynagh]

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

On branch  : 

http://hackage.haskell.org/trac/ghc/changeset/b21f541498c6b7ff69bd530dbab219d43627b8f2

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

commit b21f541498c6b7ff69bd530dbab219d43627b8f2
Author: Duncan Coutts <duncan at haskell.org>
Date:   Sun Oct 5 20:27:47 2008 +0000

    Refactor and update the hackage index reading code

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

 cabal-install/Distribution/Client/IndexUtils.hs |  138 +++++++++++++++-------
 1 files changed, 94 insertions(+), 44 deletions(-)

diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs
index 43d4a5e..9d238e1 100644
--- a/cabal-install/Distribution/Client/IndexUtils.hs
+++ b/cabal-install/Distribution/Client/IndexUtils.hs
@@ -12,7 +12,10 @@
 -----------------------------------------------------------------------------
 module Distribution.Client.IndexUtils (
   getAvailablePackages,
-  readRepoIndex,
+
+  readPackageIndexFile,
+  parseRepoIndex,
+
   disambiguatePackageName,
   disambiguateDependencies
   ) where
@@ -23,10 +26,12 @@ import Distribution.Client.Types
          , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )
 
 import Distribution.Package
-         ( PackageIdentifier(..), PackageName(..), Package(..)
+         ( PackageId, PackageIdentifier(..), PackageName(..), Package(..)
          , Dependency(Dependency) )
 import Distribution.Simple.PackageIndex (PackageIndex)
 import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.PackageDescription
+         ( GenericPackageDescription )
 import Distribution.PackageDescription.Parse
          ( parsePackageDescription )
 import Distribution.ParseUtils
@@ -36,16 +41,24 @@ import Distribution.Text
 import Distribution.Verbosity (Verbosity)
 import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8)
 
-import Data.Maybe  (catMaybes)
+import Data.Maybe  (fromMaybe)
 import Data.Monoid (Monoid(..))
 import Control.Exception (evaluate)
 import qualified Data.ByteString.Lazy as BS
 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 import Data.ByteString.Lazy (ByteString)
+import qualified Codec.Compression.GZip as GZip (decompress)
 import System.FilePath ((</>), takeExtension, splitDirectories, normalise)
 import System.IO.Error (isDoesNotExistError)
 
-
+-- | Read a repository index from disk, from the local files specified by
+-- a list of 'Repo's.
+--
+-- All the 'AvailablePackage's are marked as having come from the appropriate
+-- 'Repo'.
+--
+-- This is a higher level wrapper used internally in cabal-install.
+--
 getAvailablePackages :: Verbosity -> [Repo]
                      -> IO (PackageIndex AvailablePackage)
 getAvailablePackages verbosity repos = do
@@ -56,48 +69,29 @@ getAvailablePackages verbosity repos = do
 -- | Read a repository index from disk, from the local file specified by
 -- the 'Repo'.
 --
-readRepoIndex :: Verbosity -> Repo -> IO (PackageIndex AvailablePackage)
-readRepoIndex verbosity repo =
-  handleNotFound $ do
-    let indexFile = repoLocalDir repo </> "00-index.tar"
-    pkgs <- either fail return . parseRepoIndex =<< BS.readFile indexFile
-    evaluate (PackageIndex.fromList pkgs)
-
-  where
-    -- | Parse a repository index file from a 'ByteString'.
-    --
-    -- All the 'AvailablePackage's are marked as having come from the given 'Repo'.
-    --
-    parseRepoIndex :: ByteString -> Either String [AvailablePackage]
-    parseRepoIndex = either Left (Right . catMaybes . map extractPkg)
-                   . check [] . Tar.read
+-- All the 'AvailablePackage's are marked as having come from the given 'Repo'.
+--
+-- This is a higher level wrapper used internally in cabal-install.
+--
+readRepoIndex :: Verbosity -> Repo
+              -> IO (PackageIndex AvailablePackage)
+readRepoIndex verbosity repo = handleNotFound $ do
+  let indexFile = repoLocalDir repo </> "00-index.tar"
+  pkgs <- either fail return
+        . foldlTarball extract []
+      =<< BS.readFile indexFile
 
-    check _  (Tar.Fail err)  = Left  err
-    check ok Tar.Done        = Right ok
-    check ok (Tar.Next e es) = check (e:ok) es
+  evaluate $ PackageIndex.fromList
+    [ AvailablePackage {
+        packageInfoId      = pkgid,
+        packageDescription = pkg,
+        packageSource      = RepoTarballPackage repo
+      }
+    | (pkgid, pkg) <- pkgs]
 
-    extractPkg :: Tar.Entry -> Maybe AvailablePackage
-    extractPkg entry
-      | takeExtension fileName == ".cabal"
-      = case splitDirectories (normalise fileName) of
-          [pkgname,vers,_] -> case simpleParse vers of
-            Just ver -> Just AvailablePackage {
-                packageInfoId      = PackageIdentifier (PackageName pkgname) ver,
-                packageDescription = descr,
-                packageSource      = RepoTarballPackage repo
-              }
-            _ -> Nothing
-            where
-              parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack
-                                               . Tar.fileContent $ entry
-              descr  = case parsed of
-                ParseOk _ d -> d
-                _           -> error $ "Couldn't read cabal file "
-                                    ++ show fileName
-          _ -> Nothing
-      | otherwise = Nothing
-      where
-        fileName = Tar.fileName entry
+  where
+    extract pkgs entry = fromMaybe pkgs $
+              (do pkg <- extractPkg entry; return (pkg:pkgs))
 
     handleNotFound action = catch action $ \e -> if isDoesNotExistError e
       then do
@@ -111,6 +105,62 @@ readRepoIndex verbosity repo =
         return mempty
       else ioError e
 
+-- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'.
+--
+-- This is supposed to be an \"all in one\" way to easily get at the info in
+-- the hackage package index.
+--
+-- It takes a function to map a 'GenericPackageDescription' into any more
+-- specific instance of 'Package' that you might want to use. In the simple
+-- case you can just use @\_ p -> p@ here.
+--
+readPackageIndexFile :: Package pkg
+                     => (PackageId -> GenericPackageDescription -> pkg)
+                     -> FilePath -> IO (PackageIndex pkg)
+readPackageIndexFile mkPkg indexFile = do
+  pkgs <- either fail return
+        . parseRepoIndex
+        . GZip.decompress
+      =<< BS.readFile indexFile
+  
+  evaluate $ PackageIndex.fromList
+   [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs]
+
+-- | Parse an uncompressed \"00-index.tar\" repository index file represented
+-- as a 'ByteString'.
+--
+parseRepoIndex :: ByteString
+               -> Either String [(PackageId, GenericPackageDescription)]
+parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) []
+
+extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription)
+extractPkg entry
+  | takeExtension fileName == ".cabal"
+  = case splitDirectories (normalise fileName) of
+      [pkgname,vers,_] -> case simpleParse vers of
+        Just ver -> Just (pkgid, descr)
+          where
+            pkgid  = PackageIdentifier (PackageName pkgname) ver
+            parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack
+                                             . Tar.fileContent $ entry
+            descr  = case parsed of
+              ParseOk _ d -> d
+              _           -> error $ "Couldn't read cabal file "
+                                  ++ show fileName
+        _ -> Nothing
+      _ -> Nothing
+  | otherwise = Nothing
+  where
+    fileName = Tar.fileName entry
+
+foldlTarball :: (a -> Tar.Entry -> a) -> a
+             -> ByteString -> Either String a
+foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read
+  where
+    check _  (Tar.Fail err)  = Left  err
+    check ok Tar.Done        = Right ok
+    check ok (Tar.Next e es) = check (e:ok) es
+
 -- | Disambiguate a set of packages using 'disambiguatePackage' and report any
 -- ambiguities to the user.
 --