git.iko.soy/stackage
on 9eb4e32 help sign in
stackage/Stackage/LoadDatabase.hs
175 lines 8.7 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.Types
42import Stackage.Util
44-- | Load the raw package database.
45--
46-- We want to put in some restrictions:
47--
48-- * Drop all core packages. We never want to install a new version of
49-- those, nor include them in the package list.
50--
51-- * For packages with a specific version bound, find the maximum matching
52-- version.
53--
54-- * For other packages, select the maximum version number.
55loadPackageDB :: SelectSettings
56 -> Map PackageName Version -- ^ core packages from HP file
57 -> Set PackageName -- ^ all core packages, including extras
58 -> Map PackageName (VersionRange, Maintainer) -- ^ additional deps
59 -> IO PackageDB
60loadPackageDB settings coreMap 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 ghcVersion' =
70 let GhcMajorVersion x y = selectGhcVersion settings
71 in Version [x, y, 2] []
73 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
74 addEntry pdb e =
75 case getPackageVersion e of
76 Nothing -> return pdb
77 Just (p, v)
78 | p `member` core -> return pdb
79 | otherwise ->
80 case Map.lookup p deps of
81 Just (vrange, _maintainer)
82 | not $ withinRange v vrange -> return pdb
83 _ ->
84 case Tar.entryContent e of
85 Tar.NormalFile bs _ -> do
86 let (deps', hasTests, buildTools', mgpd, execs, mgithub) = parseDeps p bs
87 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
88 { piVersion = v
89 , piDeps = deps'
90 , piHasTests = hasTests
91 , piBuildTools = buildTools'
92 , piGPD = mgpd
93 , piExecs = execs
94 , piGithubUser = mgithub
95 }
96 _ -> return pdb
98 skipTests p = p `Set.member` skippedTests settings
100 parseDeps p lbs =
101 case parsePackageDescription $ L8.unpack lbs of
102 ParseOk _ gpd -> (mconcat
103 [ maybe mempty (go gpd) $ condLibrary gpd
104 , mconcat $ map (go gpd . snd) $ condExecutables gpd
105 , if skipTests p
106 then mempty
107 else mconcat $ map (go gpd . snd) $ condTestSuites gpd
108 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
109 ], not $ null $ condTestSuites gpd
110 , Set.fromList $ map depName $ allBuildInfo gpd
111 , Just gpd
112 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
113 , listToMaybe $ catMaybes
114 $ parseGithubUserHP (homepage $ packageDescription gpd)
115 : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
116 )
117 _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty, Nothing)
118 where
119 allBuildInfo gpd = concat
120 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
121 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
122 , if skipTests p
123 then []
124 else concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
125 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
126 ]
127 where
128 goBI f x = buildTools $ f $ condTreeData x
129 depName (Dependency (PackageName pn) _) = Executable pn
130 go gpd tree
131 = Map.unionsWith unionVersionRanges
132 $ Map.fromList (map (\(Dependency pn vr) -> (pn, vr)) $ condTreeConstraints tree)
133 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
135 checkCond gpd (cond, tree, melse)
136 | checkCond' cond = Just tree
137 | otherwise = melse
138 where
139 checkCond' (Var (OS os)) = os == buildOS
140 checkCond' (Var (Arch arch)) = arch == buildArch
142 -- Sigh... the small_base flag on mersenne-random-pure64 is backwards
143 checkCond' (Var (Flag (FlagName "small_base")))
144 | p == PackageName "mersenne-random-pure64" = False
146 checkCond' (Var (Flag flag@(FlagName flag'))) =
147 flag' `Set.notMember` disabledFlags settings &&
148 flag `elem` flags'
149 checkCond' (Var (Impl compiler range)) =
150 compiler == GHC && withinRange ghcVersion' range
151 checkCond' (Lit b) = b
152 checkCond' (CNot c) = not $ checkCond' c
153 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
154 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
156 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
157 (map FlagName $ Set.toList $ Stackage.Types.flags settings coreMap)
159-- | Attempt to grab the Github username from a homepage.
160parseGithubUserHP :: String -> Maybe String
161parseGithubUserHP url1 = do
162 url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
163 [ "http://github.com/"
164 , "https://github.com/"
165 ]
166 let x = takeWhile (/= '/') url2
167 guard $ not $ null x
168 Just x
170-- | Attempt to grab the Github username from a source repo.
171parseGithubUserSR :: SourceRepo -> Maybe String
172parseGithubUserSR sr =
173 case (repoType sr, repoLocation sr) of
174 (Just Git, Just s) -> parseGithubUserHP s
175 _ -> Nothing