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