mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-12 07:18:31 +01:00
92 lines
4.2 KiB
Haskell
92 lines
4.2 KiB
Haskell
module Stackage.LoadDatabase where
|
|
|
|
import qualified Codec.Archive.Tar as Tar
|
|
import qualified Codec.Archive.Tar.Entry as TarEntry
|
|
import Control.Exception (throwIO)
|
|
import Control.Monad (guard)
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.ByteString.Lazy.Char8 as L8
|
|
import Data.List (stripPrefix)
|
|
import qualified Data.Map as Map
|
|
import Data.Monoid (Monoid (..))
|
|
import Data.Set (member)
|
|
import qualified Data.Set as Set
|
|
import Distribution.Package (Dependency (Dependency))
|
|
import Distribution.PackageDescription (condExecutables,
|
|
condLibrary,
|
|
condTestSuites,
|
|
condTreeConstraints)
|
|
import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
|
|
parsePackageDescription)
|
|
import Distribution.Text (simpleParse)
|
|
import Distribution.Version (withinRange)
|
|
import Stackage.Types
|
|
import System.Directory (getAppUserDataDirectory)
|
|
import System.FilePath ((</>))
|
|
|
|
-- | Load the raw package database.
|
|
--
|
|
-- We want to put in some restrictions:
|
|
--
|
|
-- * Drop all core packages. We never want to install a new version of
|
|
-- those, nor include them in the package list.
|
|
--
|
|
-- * For packages with a specific version bound, find the maximum matching
|
|
-- version.
|
|
--
|
|
-- * For other packages, select the maximum version number.
|
|
loadPackageDB :: Set PackageName -- ^ core packages
|
|
-> Map PackageName VersionRange -- ^ additional deps
|
|
-> IO PackageDB
|
|
loadPackageDB core deps = do
|
|
c <- getAppUserDataDirectory "cabal"
|
|
let tarName = c </> "packages" </> "hackage.haskell.org" </> "00-index.tar"
|
|
lbs <- L.readFile tarName
|
|
addEntries mempty $ Tar.read lbs
|
|
where
|
|
addEntries :: PackageDB -> Tar.Entries Tar.FormatError -> IO PackageDB
|
|
addEntries _ (Tar.Fail e) = throwIO e
|
|
addEntries db Tar.Done = return db
|
|
addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
|
|
|
|
addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
|
|
addEntry pdb e =
|
|
case getPackageVersion $ TarEntry.fromTarPathToPosixPath (TarEntry.entryTarPath e) of
|
|
Nothing -> return pdb
|
|
Just (p, v)
|
|
| p `member` core -> return pdb
|
|
| otherwise ->
|
|
case Map.lookup p deps of
|
|
Just vrange
|
|
| not $ withinRange v vrange -> return pdb
|
|
_ ->
|
|
case Tar.entryContent e of
|
|
Tar.NormalFile bs _ -> return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
|
|
{ piVersion = v
|
|
, piDeps = parseDeps bs
|
|
}
|
|
_ -> return pdb
|
|
|
|
parseDeps lbs =
|
|
case parsePackageDescription $ L8.unpack lbs of
|
|
ParseOk _ gpd -> mconcat
|
|
[ maybe mempty go $ condLibrary gpd
|
|
, mconcat $ map (go . snd) $ condExecutables gpd
|
|
, mconcat $ map (go . snd) $ condTestSuites gpd
|
|
-- , mconcat $ map (go . snd) $ condBenchmarks gpd
|
|
]
|
|
_ -> mempty
|
|
where
|
|
go = Set.fromList . map (\(Dependency p _) -> p) . condTreeConstraints
|
|
|
|
getPackageVersion :: FilePath -> Maybe (PackageName, Version)
|
|
getPackageVersion fp = do
|
|
let (package', s1) = break (== '/') fp
|
|
package = PackageName package'
|
|
s2 <- stripPrefix "/" s1
|
|
let (version', s3) = break (== '/') s2
|
|
version <- simpleParse version'
|
|
s4 <- stripPrefix "/" s3
|
|
guard $ s4 == package' ++ ".cabal"
|
|
Just (package, version)
|