git.iko.soy/stackage
on 2fe8941 help sign in
stackage/Stackage/LoadDatabase.hs
261 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 fixPath '\\' = '/'
127 fixPath c = c
129 expectedPath = let PackageName p' = p in concat
130 [ packageVersionString (p, v)
131 , "/"
132 , p'
133 , ".cabal"
134 ]
135 loop Tar.Done = error $ concat
136 [ "Missing cabal file "
137 , show expectedPath
138 , " in tarball: "
139 , show tarball
140 ]
141 loop (Tar.Fail e) = error $ concat
142 [ "Unable to read tarball "
143 , show tarball
144 , ": "
145 , show e
146 ]
147 loop (Tar.Next entry rest)
148 | map fixPath (Tar.entryPath entry) == expectedPath =
149 case Tar.entryContent entry of
150 Tar.NormalFile bs _ -> addPackage p v bs pdb
151 _ -> error $ concat
152 [ "In tarball "
153 , show tarball
154 , " the cabal file "
155 , show expectedPath
156 , " was not a normal file"
157 ]
158 | otherwise = loop rest
160 addPackage p v lbs pdb = do
161 let (deps', hasTests, buildToolsExe', buildToolsOther', mgpd, execs, mgithub) = parseDeps p lbs
162 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
163 { piVersion = v
164 , piDeps = deps'
165 , piHasTests = hasTests
166 , piBuildToolsExe = buildToolsExe'
167 , piBuildToolsAll = buildToolsExe' `Set.union` buildToolsOther'
168 , piGPD = mgpd
169 , piExecs = execs
170 , piGithubUser = mgithub
171 }
173 parseDeps p lbs =
174 case parsePackageDescription $ L8.unpack lbs of
175 ParseOk _ gpd -> (mconcat
176 [ maybe mempty (go gpd) $ condLibrary gpd
177 , mconcat $ map (go gpd . snd) $ condExecutables gpd
178 , if skipTests p
179 then mempty
180 else mconcat $ map (go gpd . snd) $ condTestSuites gpd
181 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
182 ], not $ null $ condTestSuites gpd
183 , Set.fromList $ map depName $ libExeBuildInfo gpd
184 , Set.fromList $ map depName $ testBenchBuildInfo gpd
185 , Just gpd
186 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
187 , listToMaybe $ catMaybes
188 $ parseGithubUserHP (homepage $ packageDescription gpd)
189 : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
190 )
191 _ -> (mempty, defaultHasTestSuites, Set.empty, Set.empty, Nothing, Set.empty, Nothing)
192 where
193 allBuildInfo gpd = libExeBuildInfo gpd ++ testBenchBuildInfo gpd
194 libExeBuildInfo gpd = concat
195 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
196 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
197 ]
198 testBenchBuildInfo gpd = concat
199 [ if skipTests p
200 then []
201 else concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
202 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
203 ]
204 goBI f x = buildTools $ f $ condTreeData x
206 depName (Dependency (PackageName pn) _) = Executable pn
207 go gpd tree
208 = Map.filterWithKey (\k _ -> not $ ignoredDep k)
209 $ Map.unionsWith unionVersionRanges
210 $ Map.fromList (map (\(Dependency pn vr) -> (pn, vr)) $ condTreeConstraints tree)
211 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
213 -- Some specific overrides for cases where getting Stackage to be smart
214 -- enough to handle things would be too difficult.
215 ignoredDep :: PackageName -> Bool
216 ignoredDep dep
217 -- The flag logic used by text-stream-decode confuses Stackage.
218 | dep == PackageName "text" && p == PackageName "text-stream-decode" = True
219 | otherwise = False
221 checkCond gpd (cond, tree, melse)
222 | checkCond' cond = Just tree
223 | otherwise = melse
224 where
225 checkCond' (Var (OS os)) = os == buildOS
226 checkCond' (Var (Arch arch)) = arch == buildArch
228 -- Sigh... the small_base flag on mersenne-random-pure64 is backwards
229 checkCond' (Var (Flag (FlagName "small_base")))
230 | p == PackageName "mersenne-random-pure64" = False
232 checkCond' (Var (Flag flag@(FlagName flag'))) =
233 flag' `Set.notMember` disabledFlags settings &&
234 flag `elem` flags'
235 checkCond' (Var (Impl compiler range)) =
236 compiler == GHC && withinRange ghcVersion' range
237 checkCond' (Lit b) = b
238 checkCond' (CNot c) = not $ checkCond' c
239 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
240 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
242 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
243 (map FlagName $ Set.toList $ Stackage.Types.flags settings coreMap)
245-- | Attempt to grab the Github username from a homepage.
246parseGithubUserHP :: String -> Maybe String
247parseGithubUserHP url1 = do
248 url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
249 [ "http://github.com/"
250 , "https://github.com/"
251 ]
252 let x = takeWhile (/= '/') url2
253 guard $ not $ null x
254 Just x
256-- | Attempt to grab the Github username from a source repo.
257parseGithubUserSR :: SourceRepo -> Maybe String
258parseGithubUserSR sr =
259 case (repoType sr, repoLocation sr) of
260 (Just Git, Just s) -> parseGithubUserHP s
261 _ -> Nothing