git.iko.soy/stackage
on f90bccf help sign in
stackage/Stackage/LoadDatabase.hs
176 lines 8.8 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, Version (Version))
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 :: SelectSettings
57 -> Map PackageName Version -- ^ core packages from HP file
58 -> Set PackageName -- ^ all core packages, including extras
59 -> Map PackageName (VersionRange, Maintainer) -- ^ additional deps
60 -> IO PackageDB
61loadPackageDB settings coreMap core deps = do
62 tarName <- getTarballName
63 lbs <- L.readFile tarName
64 addEntries mempty $ Tar.read lbs
65 where
66 addEntries _ (Tar.Fail e) = error $ show e
67 addEntries db Tar.Done = return db
68 addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
70 ghcVersion' =
71 let GhcMajorVersion x y = selectGhcVersion settings
72 in Version [x, y, 2] []
74 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
75 addEntry pdb e =
76 case getPackageVersion e of
77 Nothing -> return pdb
78 Just (p, v)
79 | p `member` core -> return pdb
80 | otherwise ->
81 case Map.lookup p deps of
82 Just (vrange, _maintainer)
83 | not $ withinRange v vrange -> return pdb
84 _ ->
85 case Tar.entryContent e of
86 Tar.NormalFile bs _ -> do
87 let (deps', hasTests, buildTools', mgpd, execs, mgithub) = parseDeps p bs
88 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
89 { piVersion = v
90 , piDeps = deps'
91 , piHasTests = hasTests
92 , piBuildTools = buildTools'
93 , piGPD = mgpd
94 , piExecs = execs
95 , piGithubUser = mgithub
96 }
97 _ -> return pdb
99 skipTests p = p `Set.member` skippedTests settings
101 parseDeps p lbs =
102 case parsePackageDescription $ L8.unpack lbs of
103 ParseOk _ gpd -> (mconcat
104 [ maybe mempty (go gpd) $ condLibrary gpd
105 , mconcat $ map (go gpd . snd) $ condExecutables gpd
106 , if skipTests p
107 then mempty
108 else mconcat $ map (go gpd . snd) $ condTestSuites gpd
109 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
110 ], not $ null $ condTestSuites gpd
111 , Set.fromList $ map depName $ allBuildInfo gpd
112 , Just gpd
113 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
114 , listToMaybe $ catMaybes
115 $ parseGithubUserHP (homepage $ packageDescription gpd)
116 : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
117 )
118 _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty, Nothing)
119 where
120 allBuildInfo gpd = concat
121 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
122 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
123 , if skipTests p
124 then []
125 else concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
126 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
127 ]
128 where
129 goBI f x = buildTools $ f $ condTreeData x
130 depName (Dependency (PackageName pn) _) = Executable pn
131 go gpd tree
132 = Map.unionsWith unionVersionRanges
133 $ Map.fromList (map (\(Dependency pn vr) -> (pn, vr)) $ condTreeConstraints tree)
134 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
136 checkCond gpd (cond, tree, melse)
137 | checkCond' cond = Just tree
138 | otherwise = melse
139 where
140 checkCond' (Var (OS os)) = os == buildOS
141 checkCond' (Var (Arch arch)) = arch == buildArch
143 -- Sigh... the small_base flag on mersenne-random-pure64 is backwards
144 checkCond' (Var (Flag (FlagName "small_base")))
145 | p == PackageName "mersenne-random-pure64" = False
147 checkCond' (Var (Flag flag@(FlagName flag'))) =
148 flag' `Set.notMember` disabledFlags settings &&
149 flag `elem` flags'
150 checkCond' (Var (Impl compiler range)) =
151 compiler == GHC && withinRange ghcVersion' range
152 checkCond' (Lit b) = b
153 checkCond' (CNot c) = not $ checkCond' c
154 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
155 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
157 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
158 (map FlagName $ Set.toList $ Stackage.Types.flags settings coreMap)
160-- | Attempt to grab the Github username from a homepage.
161parseGithubUserHP :: String -> Maybe String
162parseGithubUserHP url1 = do
163 url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
164 [ "http://github.com/"
165 , "https://github.com/"
166 ]
167 let x = takeWhile (/= '/') url2
168 guard $ not $ null x
169 Just x
171-- | Attempt to grab the Github username from a source repo.
172parseGithubUserSR :: SourceRepo -> Maybe String
173parseGithubUserSR sr =
174 case (repoType sr, repoLocation sr) of
175 (Just Git, Just s) -> parseGithubUserHP s
176 _ -> Nothing