IndexUtils.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.IndexUtils
-- Copyright   :  (c) Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  duncan@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Extra utils related to the package indexes.
-----------------------------------------------------------------------------
module Distribution.Client.IndexUtils (
  getAvailablePackages,
  readRepoIndex,
  disambiguatePackageName,
  disambiguateDependencies
  ) where

import qualified Distribution.Client.Tar as Tar
import Distribution.Client.Types
         ( UnresolvedDependency(..), AvailablePackage(..)
         , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )

import Distribution.Package
         ( PackageIdentifier(..), Package(..), Dependency(Dependency) )
import Distribution.Simple.PackageIndex (PackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.PackageDescription
         ( parsePackageDescription )
import Distribution.ParseUtils
         ( ParseResult(..) )
import Distribution.Text
         ( simpleParse )
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8)

import Data.Maybe  (catMaybes)
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 System.FilePath ((</>), takeExtension, splitDirectories, normalise)
import System.IO.Error (isDoesNotExistError)


getAvailablePackages :: Verbosity -> [Repo]
                     -> IO (PackageIndex AvailablePackage)
getAvailablePackages verbosity repos = do
  info verbosity "Reading available packages..."
  pkgss <- mapM (readRepoIndex verbosity) repos
  evaluate (mconcat pkgss)

-- | 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

    check _  (Tar.Fail err)  = Left  err
    check ok Tar.Done        = Right ok
    check ok (Tar.Next e es) = check (e:ok) es

    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 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

    handleNotFound action = catch action $ \e -> if isDoesNotExistError e
      then do
        case repoKind repo of
          Left  remoteRepo -> warn verbosity $
               "The package list for '" ++ remoteRepoName remoteRepo
            ++ "' does not exist. Run 'cabal update' to download it."
          Right _localRepo -> warn verbosity $
               "The package list for the local repo '" ++ repoLocalDir repo
            ++ "' is missing. The repo is invalid."
        return mempty
      else ioError e

-- | Disambiguate a set of packages using 'disambiguatePackage' and report any
-- ambiguities to the user.
--
disambiguateDependencies :: PackageIndex AvailablePackage
                         -> [UnresolvedDependency]
                         -> IO [UnresolvedDependency]
disambiguateDependencies index deps = do
  let names = [ (name, disambiguatePackageName index name)
              | UnresolvedDependency (Dependency name _) _ <- deps ]
   in case [ (name, matches) | (name, Right matches) <- names ] of
        []        -> return
          [ UnresolvedDependency (Dependency name vrange) flags
          | (UnresolvedDependency (Dependency _ vrange) flags,
             (_, Left name)) <- zip deps names ]
        ambigious -> die $ unlines
          [ if null matches
              then "There is no package named " ++ name
              else "The package name " ++ name ++ "is ambigious. "
                ++ "It could be: " ++ intercalate ", " matches
          | (name, matches) <- ambigious ]

-- | Given an index of known packages and a package name, figure out which one it
-- might be referring to. If there is an exact case-sensitive match then that's
-- ok. If it matches just one package case-insensitively then that's also ok.
-- The only problem is if it matches multiple packages case-insensitively, in
-- that case it is ambigious.
--
disambiguatePackageName :: PackageIndex AvailablePackage
                        -> String
                        -> Either String [String]
disambiguatePackageName index name =
    case PackageIndex.searchByName index name of
      PackageIndex.None              -> Right []
      PackageIndex.Unambiguous pkgs  -> Left (pkgName (packageId (head pkgs)))
      PackageIndex.Ambiguous   pkgss -> Right [ pkgName (packageId pkg)
                                           | (pkg:_) <- pkgss ]