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