git.iko.soy/stackage
on aaca23e help sign in
stackage/Stackage/LoadDatabase.hs
225 lines 11 kB history raw
1module Stackage.LoadDatabase where
3import qualified Codec.Archive.Tar as Tar
4import qualified Codec.Compression.GZip as GZip
5import Control.Monad (guard)
6import qualified Data.ByteString.Lazy as L
7import qualified Data.ByteString.Lazy.Char8 as L8
8import Data.List (stripPrefix)
9import qualified Data.Map as Map
10import Data.Maybe (catMaybes, listToMaybe,
11 mapMaybe)
12import Data.Monoid (Monoid (..))
13import Data.Set (member)
14import qualified Data.Set as Set
15import Distribution.Compiler (CompilerFlavor (GHC))
16import Distribution.Package (Dependency (Dependency))
17import Distribution.PackageDescription (Condition (..),
18 ConfVar (..),
19 FlagName (FlagName),
20 RepoType (Git),
21 SourceRepo (..),
22 benchmarkBuildInfo,
23 buildInfo, buildTools,
24 condBenchmarks,
25 condExecutables,
26 condLibrary,
27 condTestSuites,
28 condTreeComponents,
29 condTreeConstraints,
30 condTreeData,
31 flagDefault, flagName,
32 genPackageFlags,
33 homepage, libBuildInfo,
34 packageDescription,
35 sourceRepos,
36 testBuildInfo)
37import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
38 parsePackageDescription)
39import Distribution.System (buildArch, buildOS)
40import Distribution.Version (Version (Version),
41 unionVersionRanges,
42 withinRange)
43import Stackage.Types
44import Stackage.Util
45import System.Directory (doesFileExist)
46import System.FilePath ((<.>), (</>))
48-- | Load the raw package database.
49--
50-- We want to put in some restrictions:
51--
52-- * Drop all core packages. We never want to install a new version of
53-- those, nor include them in the package list.
54--
55-- * For packages with a specific version bound, find the maximum matching
56-- version.
57--
58-- * For other packages, select the maximum version number.
59loadPackageDB :: SelectSettings
60 -> Map PackageName Version -- ^ core packages from HP file
61 -> Set PackageName -- ^ all core packages, including extras
62 -> Map PackageName (VersionRange, Maintainer) -- ^ additional deps
63 -> IO PackageDB
64loadPackageDB settings coreMap core deps = do
65 tarName <- getTarballName
66 lbs <- L.readFile tarName
67 addEntries mempty $ Tar.read lbs
68 where
69 addEntries _ (Tar.Fail e) = error $ show e
70 addEntries db Tar.Done = return db
71 addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
73 ghcVersion' =
74 let GhcMajorVersion x y = selectGhcVersion settings
75 in Version [x, y, 2] []
77 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
78 addEntry pdb e =
79 case getPackageVersion e of
80 Nothing -> return pdb
81 Just (p, v)
82 | p `member` core -> return pdb
83 | otherwise ->
84 case Map.lookup p deps of
85 Just (vrange, _maintainer)
86 | not $ withinRange v vrange -> return pdb
87 _ -> do
88 let pkgname = packageVersionString (p, v)
89 tarball = selectTarballDir settings </> pkgname <.> "tar.gz"
90 exists <- doesFileExist tarball
91 if exists
92 then do
93 lbs <- L.readFile tarball
94 findCabalAndAddPackage tarball p v pdb $ Tar.read $ GZip.decompress lbs
95 else
96 case Tar.entryContent e of
97 Tar.NormalFile bs _ -> addPackage p v bs pdb
98 _ -> return pdb
100 skipTests p = p `Set.member` skippedTests settings
102 -- Find the relevant cabal file in the given entries and add its contents
103 -- to the package database
104 findCabalAndAddPackage tarball p v pdb =
105 loop
106 where
107 expectedPath = let PackageName p' = p in concat
108 [ packageVersionString (p, v)
109 , "/"
110 , p'
111 , ".cabal"
112 ]
113 loop Tar.Done = error $ concat
114 [ "Missing cabal file "
115 , show expectedPath
116 , " in tarball: "
117 , show tarball
118 ]
119 loop (Tar.Fail e) = error $ concat
120 [ "Unable to read tarball "
121 , show tarball
122 , ": "
123 , show e
124 ]
125 loop (Tar.Next entry rest)
126 | Tar.entryPath entry == expectedPath =
127 case Tar.entryContent entry of
128 Tar.NormalFile bs _ -> addPackage p v bs pdb
129 _ -> error $ concat
130 [ "In tarball "
131 , show tarball
132 , " the cabal file "
133 , show expectedPath
134 , " was not a normal file"
135 ]
136 | otherwise = loop rest
138 addPackage p v lbs pdb = do
139 let (deps', hasTests, buildTools', mgpd, execs, mgithub) = parseDeps p lbs
140 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
141 { piVersion = v
142 , piDeps = deps'
143 , piHasTests = hasTests
144 , piBuildTools = buildTools'
145 , piGPD = mgpd
146 , piExecs = execs
147 , piGithubUser = mgithub
148 }
150 parseDeps p lbs =
151 case parsePackageDescription $ L8.unpack lbs of
152 ParseOk _ gpd -> (mconcat
153 [ maybe mempty (go gpd) $ condLibrary gpd
154 , mconcat $ map (go gpd . snd) $ condExecutables gpd
155 , if skipTests p
156 then mempty
157 else mconcat $ map (go gpd . snd) $ condTestSuites gpd
158 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
159 ], not $ null $ condTestSuites gpd
160 , Set.fromList $ map depName $ allBuildInfo gpd
161 , Just gpd
162 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
163 , listToMaybe $ catMaybes
164 $ parseGithubUserHP (homepage $ packageDescription gpd)
165 : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
166 )
167 _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty, Nothing)
168 where
169 allBuildInfo gpd = concat
170 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
171 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
172 , if skipTests p
173 then []
174 else concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
175 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
176 ]
177 where
178 goBI f x = buildTools $ f $ condTreeData x
179 depName (Dependency (PackageName pn) _) = Executable pn
180 go gpd tree
181 = Map.unionsWith unionVersionRanges
182 $ Map.fromList (map (\(Dependency pn vr) -> (pn, vr)) $ condTreeConstraints tree)
183 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
185 checkCond gpd (cond, tree, melse)
186 | checkCond' cond = Just tree
187 | otherwise = melse
188 where
189 checkCond' (Var (OS os)) = os == buildOS
190 checkCond' (Var (Arch arch)) = arch == buildArch
192 -- Sigh... the small_base flag on mersenne-random-pure64 is backwards
193 checkCond' (Var (Flag (FlagName "small_base")))
194 | p == PackageName "mersenne-random-pure64" = False
196 checkCond' (Var (Flag flag@(FlagName flag'))) =
197 flag' `Set.notMember` disabledFlags settings &&
198 flag `elem` flags'
199 checkCond' (Var (Impl compiler range)) =
200 compiler == GHC && withinRange ghcVersion' range
201 checkCond' (Lit b) = b
202 checkCond' (CNot c) = not $ checkCond' c
203 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
204 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
206 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
207 (map FlagName $ Set.toList $ Stackage.Types.flags settings coreMap)
209-- | Attempt to grab the Github username from a homepage.
210parseGithubUserHP :: String -> Maybe String
211parseGithubUserHP url1 = do
212 url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
213 [ "http://github.com/"
214 , "https://github.com/"
215 ]
216 let x = takeWhile (/= '/') url2
217 guard $ not $ null x
218 Just x
220-- | Attempt to grab the Github username from a source repo.
221parseGithubUserSR :: SourceRepo -> Maybe String
222parseGithubUserSR sr =
223 case (repoType sr, repoLocation sr) of
224 (Just Git, Just s) -> parseGithubUserHP s
225 _ -> Nothing