git.iko.soy/stackage
on fb2385d help sign in
stackage/Stackage/LoadDatabase.hs
158 lines 8.0 kB history raw
1module Stackage.LoadDatabase where
3import qualified Codec.Archive.Tar as Tar
4import Control.Monad (guard)
5import qualified Data.ByteString.Lazy as L
6import qualified Data.ByteString.Lazy.Char8 as L8
7import Data.List (stripPrefix)
8import qualified Data.Map as Map
9import Data.Maybe (catMaybes, listToMaybe,
10 mapMaybe)
11import Data.Monoid (Monoid (..))
12import Data.Set (member)
13import qualified Data.Set as Set
14import Distribution.Compiler (CompilerFlavor (GHC))
15import Distribution.Package (Dependency (Dependency))
16import Distribution.PackageDescription (Condition (..),
17 ConfVar (..),
18 FlagName (FlagName),
19 RepoType (Git),
20 SourceRepo (..),
21 benchmarkBuildInfo,
22 buildInfo, buildTools,
23 condBenchmarks,
24 condExecutables,
25 condLibrary,
26 condTestSuites,
27 condTreeComponents,
28 condTreeConstraints,
29 condTreeData,
30 flagDefault, flagName,
31 genPackageFlags,
32 homepage, libBuildInfo,
33 packageDescription,
34 sourceRepos,
35 testBuildInfo)
36import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
37 parsePackageDescription)
38import Distribution.System (buildArch, buildOS)
39import Distribution.Version (unionVersionRanges,
40 withinRange)
41import Stackage.Config
42import Stackage.Types
43import Stackage.Util
45-- | Load the raw package database.
46--
47-- We want to put in some restrictions:
48--
49-- * Drop all core packages. We never want to install a new version of
50-- those, nor include them in the package list.
51--
52-- * For packages with a specific version bound, find the maximum matching
53-- version.
54--
55-- * For other packages, select the maximum version number.
56loadPackageDB :: BuildSettings
57 -> Set PackageName -- ^ core packages
58 -> Map PackageName (VersionRange, Maintainer) -- ^ additional deps
59 -> IO PackageDB
60loadPackageDB settings core deps = do
61 tarName <- getTarballName
62 lbs <- L.readFile tarName
63 addEntries mempty $ Tar.read lbs
64 where
65 addEntries _ (Tar.Fail e) = error $ show e
66 addEntries db Tar.Done = return db
67 addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
69 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
70 addEntry pdb e =
71 case getPackageVersion e of
72 Nothing -> return pdb
73 Just (p, v)
74 | p `member` core -> return pdb
75 | otherwise ->
76 case Map.lookup p deps of
77 Just (vrange, _maintainer)
78 | not $ withinRange v vrange -> return pdb
79 _ ->
80 case Tar.entryContent e of
81 Tar.NormalFile bs _ -> do
82 let (deps', hasTests, buildTools', mgpd, execs, mgithub) = parseDeps bs
83 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
84 { piVersion = v
85 , piDeps = deps'
86 , piHasTests = hasTests
87 , piBuildTools = buildTools'
88 , piGPD = mgpd
89 , piExecs = execs
90 , piGithubUser = mgithub
91 }
92 _ -> return pdb
94 parseDeps lbs =
95 case parsePackageDescription $ L8.unpack lbs of
96 ParseOk _ gpd -> (mconcat
97 [ maybe mempty (go gpd) $ condLibrary gpd
98 , mconcat $ map (go gpd . snd) $ condExecutables gpd
99 , mconcat $ map (go gpd . snd) $ condTestSuites gpd
100 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
101 ], not $ null $ condTestSuites gpd
102 , Set.fromList $ map depName $ allBuildInfo gpd
103 , Just gpd
104 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
105 , listToMaybe $ catMaybes
106 $ parseGithubUserHP (homepage $ packageDescription gpd)
107 : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
108 )
109 _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty, Nothing)
110 where
111 allBuildInfo gpd = concat
112 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
113 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
114 , concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
115 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
116 ]
117 where
118 goBI f x = buildTools $ f $ condTreeData x
119 depName (Dependency (PackageName p) _) = Executable p
120 go gpd tree
121 = Map.unionsWith unionVersionRanges
122 $ Map.fromList (map (\(Dependency p vr) -> (p, vr)) $ condTreeConstraints tree)
123 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
125 checkCond gpd (cond, tree, melse)
126 | checkCond' cond = Just tree
127 | otherwise = melse
128 where
129 checkCond' (Var (OS os)) = os == buildOS
130 checkCond' (Var (Arch arch)) = arch == buildArch
131 checkCond' (Var (Flag flag)) = flag `elem` flags'
132 checkCond' (Var (Impl compiler range)) =
133 compiler == GHC && withinRange targetCompilerVersion range
134 checkCond' (Lit b) = b
135 checkCond' (CNot c) = not $ checkCond' c
136 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
137 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
139 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
140 (map FlagName $ Set.toList $ Stackage.Types.flags settings)
142-- | Attempt to grab the Github username from a homepage.
143parseGithubUserHP :: String -> Maybe String
144parseGithubUserHP url1 = do
145 url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
146 [ "http://github.com/"
147 , "https://github.com/"
148 ]
149 let x = takeWhile (/= '/') url2
150 guard $ not $ null x
151 Just x
153-- | Attempt to grab the Github username from a source repo.
154parseGithubUserSR :: SourceRepo -> Maybe String
155parseGithubUserSR sr =
156 case (repoType sr, repoLocation sr) of
157 (Just Git, Just s) -> parseGithubUserHP s
158 _ -> Nothing