@@ -0,0 +1,92 @@
1+module Stackage.LoadDatabase where
2+
3+import qualified Codec.Archive.Tar as Tar
4+import qualified Codec.Archive.Tar.Entry as TarEntry
5+import Control.Exception (throwIO)
6+import Control.Monad (guard)
7+import qualified Data.ByteString.Lazy as L
8+import qualified Data.ByteString.Lazy.Char8 as L8
9+import Data.List (stripPrefix)
10+import qualified Data.Map as Map
11+import Data.Monoid (Monoid (..))
12+import Data.Set (member)
13+import qualified Data.Set as Set
14+import Distribution.Package (Dependency (Dependency))
15+import Distribution.PackageDescription (condBenchmarks,
16+ condExecutables,
17+ condLibrary,
18+ condTestSuites,
19+ condTreeConstraints)
20+import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
21+ parsePackageDescription)
22+import Distribution.Text (simpleParse)
23+import Distribution.Version (withinRange)
24+import Stackage.Types
25+import System.Directory (getAppUserDataDirectory)
26+import System.FilePath ((</>))
27+
28+-- | Load the raw package database.
29+--
30+-- We want to put in some restrictions:
31+--
32+-- * Drop all core packages. We never want to install a new version of
33+-- those, nor include them in the package list.
34+--
35+-- * For packages with a specific version bound, find the maximum matching
36+-- version.
37+--
38+-- * For other packages, select the maximum version number.
39+loadPackageDB :: Set PackageName -- ^ core packages
40+ -> Map PackageName VersionRange -- ^ additional deps
41+ -> IO PackageDB
42+loadPackageDB core deps = do
43+ c <- getAppUserDataDirectory "cabal"
44+ let tarName = c </> "packages" </> "hackage.haskell.org" </> "00-index.tar"
45+ lbs <- L.readFile tarName
46+ addEntries mempty $ Tar.read lbs
47+ where
48+ addEntries :: PackageDB -> Tar.Entries Tar.FormatError -> IO PackageDB
49+ addEntries _ (Tar.Fail e) = throwIO e
50+ addEntries db Tar.Done = return db
51+ addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
52+
53+ addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
54+ addEntry pdb e =
55+ case getPackageVersion $ TarEntry.fromTarPathToPosixPath (TarEntry.entryTarPath e) of
56+ Nothing -> return pdb
57+ Just (p, v)
58+ | p `member` core -> return pdb
59+ | otherwise ->
60+ case Map.lookup p deps of
61+ Just vrange
62+ | not $ withinRange v vrange -> return pdb
63+ _ ->
64+ case Tar.entryContent e of
65+ Tar.NormalFile bs _ -> return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
66+ { piVersion = v
67+ , piDeps = parseDeps bs
68+ }
69+ _ -> return pdb
70+
71+ parseDeps lbs =
72+ case parsePackageDescription $ L8.unpack lbs of
73+ ParseOk _ gpd -> mconcat
74+ [ maybe mempty go $ condLibrary gpd
75+ , mconcat $ map (go . snd) $ condExecutables gpd
76+ , mconcat $ map (go . snd) $ condTestSuites gpd
77+ , mconcat $ map (go . snd) $ condBenchmarks gpd
78+ ]
79+ _ -> mempty
80+ where
81+ go = Set.fromList . map (\(Dependency p _) -> p) . condTreeConstraints
82+
83+ getPackageVersion :: FilePath -> Maybe (PackageName, Version)
84+ getPackageVersion fp = do
85+ let (package', s1) = break (== '/') fp
86+ package = PackageName package'
87+ s2 <- stripPrefix "/" s1
88+ let (version', s3) = break (== '/') s2
89+ version <- simpleParse version'
90+ s4 <- stripPrefix "/" s3
91+ guard $ s4 == package' ++ ".cabal"
92+ Just (package, version)