/packages/cabal-install-0.10.2/Distribution/Client/IndexUtils.hs
Haskell | 265 lines | 188 code | 22 blank | 55 comment | 7 complexity | 9d145d40aecefa38fbaeb71a1e250367 MD5 | raw file
- -----------------------------------------------------------------------------
- -- |
- -- Module : Distribution.Client.IndexUtils
- -- Copyright : (c) Duncan Coutts 2008
- -- License : BSD-like
- --
- -- Maintainer : duncan@community.haskell.org
- -- Stability : provisional
- -- Portability : portable
- --
- -- Extra utils related to the package indexes.
- -----------------------------------------------------------------------------
- module Distribution.Client.IndexUtils (
- getInstalledPackages,
- getAvailablePackages,
- readPackageIndexFile,
- parseRepoIndex,
- ) where
- import qualified Distribution.Client.Tar as Tar
- import Distribution.Client.Types
- import Distribution.Package
- ( PackageId, PackageIdentifier(..), PackageName(..)
- , Package(..), packageVersion
- , Dependency(Dependency), InstalledPackageId(..) )
- import Distribution.Client.PackageIndex (PackageIndex)
- import qualified Distribution.Client.PackageIndex as PackageIndex
- import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
- import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
- import Distribution.PackageDescription
- ( GenericPackageDescription )
- import Distribution.PackageDescription.Parse
- ( parsePackageDescription )
- import Distribution.Simple.Compiler
- ( Compiler, PackageDBStack )
- import Distribution.Simple.Program
- ( ProgramConfiguration )
- import qualified Distribution.Simple.Configure as Configure
- ( getInstalledPackages )
- import Distribution.ParseUtils
- ( ParseResult(..) )
- import Distribution.Version
- ( Version(Version), intersectVersionRanges )
- import Distribution.Text
- ( simpleParse )
- import Distribution.Verbosity
- ( Verbosity, lessVerbose )
- import Distribution.Simple.Utils
- ( warn, info, fromUTF8, equating )
- import Data.Maybe (catMaybes, fromMaybe)
- import Data.List (isPrefixOf, groupBy)
- import Data.Monoid (Monoid(..))
- import qualified Data.Map as Map
- import Control.Monad (MonadPlus(mplus), when)
- 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 Distribution.Client.GZipUtils (maybeDecompress)
- import System.FilePath ((</>), takeExtension, splitDirectories, normalise)
- import System.FilePath.Posix as FilePath.Posix
- ( takeFileName )
- import System.IO.Error (isDoesNotExistError)
- import System.Directory
- ( getModificationTime )
- import System.Time
- ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) )
- getInstalledPackages :: Verbosity -> Compiler
- -> PackageDBStack -> ProgramConfiguration
- -> IO (PackageIndex InstalledPackage)
- getInstalledPackages verbosity comp packageDbs conf =
- fmap convert (Configure.getInstalledPackages verbosity'
- comp packageDbs conf)
- where
- --FIXME: make getInstalledPackages use sensible verbosity in the first place
- verbosity' = lessVerbose verbosity
- convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage
- convert index = PackageIndex.fromList
- -- There can be multiple installed instances of each package version,
- -- like when the same package is installed in the global & user dbs.
- -- InstalledPackageIndex.allPackagesByName gives us the installed
- -- packages with the most preferred instances first, so by picking the
- -- first we should get the user one. This is almost but not quite the
- -- same as what ghc does.
- [ InstalledPackage ipkg (sourceDeps index ipkg)
- | ipkgs <- InstalledPackageIndex.allPackagesByName index
- , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]
- -- The InstalledPackageInfo only lists dependencies by the
- -- InstalledPackageId, which means we do not directly know the corresponding
- -- source dependency. The only way to find out is to lookup the
- -- InstalledPackageId to get the InstalledPackageInfo and look at its
- -- source PackageId. But if the package is broken because it depends on
- -- other packages that do not exist then we have a problem we cannot find
- -- the original source package id. Instead we make up a bogus package id.
- -- This should have the same effect since it should be a dependency on a
- -- non-existant package.
- sourceDeps index ipkg =
- [ maybe (brokenPackageId depid) packageId mdep
- | let depids = InstalledPackageInfo.depends ipkg
- getpkg = InstalledPackageIndex.lookupInstalledPackageId index
- , (depid, mdep) <- zip depids (map getpkg depids) ]
- brokenPackageId (InstalledPackageId str) =
- PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])
- -- | 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 AvailablePackageDb
- getAvailablePackages verbosity [] = do
- warn verbosity $ "No remote package servers have been specified. Usually "
- ++ "you would have one specified in the config file."
- return AvailablePackageDb {
- packageIndex = mempty,
- packagePreferences = mempty
- }
- getAvailablePackages verbosity repos = do
- info verbosity "Reading available packages..."
- pkgss <- mapM (readRepoIndex verbosity) repos
- let (pkgs, prefs) = mconcat pkgss
- prefs' = Map.fromListWith intersectVersionRanges
- [ (name, range) | Dependency name range <- prefs ]
- _ <- evaluate pkgs
- _ <- evaluate prefs'
- return AvailablePackageDb {
- packageIndex = pkgs,
- packagePreferences = prefs'
- }
- -- | Read a repository index from disk, from the local file specified by
- -- the 'Repo'.
- --
- -- 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, [Dependency])
- readRepoIndex verbosity repo = handleNotFound $ do
- let indexFile = repoLocalDir repo </> "00-index.tar"
- (pkgs, prefs) <- either fail return
- . foldlTarball extract ([], [])
- =<< BS.readFile indexFile
- pkgIndex <- evaluate $ PackageIndex.fromList
- [ AvailablePackage {
- packageInfoId = pkgid,
- packageDescription = pkg,
- packageSource = RepoTarballPackage repo pkgid Nothing
- }
- | (pkgid, pkg) <- pkgs]
- warnIfIndexIsOld indexFile
- return (pkgIndex, prefs)
- where
- extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $
- (do pkg <- extractPkg entry; return (pkg:pkgs, prefs))
- `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs))
- extractPrefs :: Tar.Entry -> Maybe [Dependency]
- extractPrefs entry = case Tar.entryContent entry of
- Tar.NormalFile content _
- | takeFileName (Tar.entryPath entry) == "preferred-versions"
- -> Just . parsePreferredVersions
- . BS.Char8.unpack $ content
- _ -> Nothing
- 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
- isOldThreshold = 15 --days
- warnIfIndexIsOld indexFile = do
- indexTime <- getModificationTime indexFile
- currentTime <- getClockTime
- let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime)
- when (tdDay diff >= isOldThreshold) $ case repoKind repo of
- Left remoteRepo -> warn verbosity $
- "The package list for '" ++ remoteRepoName remoteRepo
- ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun "
- ++ "'cabal update' to get the latest list of available packages."
- Right _localRepo -> return ()
- parsePreferredVersions :: String -> [Dependency]
- parsePreferredVersions = catMaybes
- . map simpleParse
- . filter (not . isPrefixOf "--")
- . lines
- -- | 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
- . maybeDecompress
- =<< 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 = case Tar.entryContent entry of
- Tar.NormalFile content _
- | 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
- $ content
- descr = case parsed of
- ParseOk _ d -> d
- _ -> error $ "Couldn't read cabal file "
- ++ show fileName
- _ -> Nothing
- _ -> Nothing
- _ -> Nothing
- where
- fileName = Tar.entryPath 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