git.iko.soy/stackage
on c766873 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.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 -> IO PackageDB
68loadPackageDB settings coreMap core deps = do
69 tarName <- getTarballName
70 lbs <- L.readFile tarName
71 pdb <- addEntries mempty $ Tar.read lbs
72 contents <- handle (\(_ :: IOException) -> return [])
73 $ getDirectoryContents $ selectTarballDir settings
74 foldM addTarball pdb $ mapMaybe stripTarGz contents
75 where
76 addEntries _ (Tar.Fail e) = error $ show e
77 addEntries db Tar.Done = return db
78 addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
80 stripTarGz = fmap reverse . stripPrefix (reverse ".tar.gz") . reverse
82 ghcVersion' =
83 let GhcMajorVersion x y = selectGhcVersion settings
84 in Version [x, y, 2] []
86 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
87 addEntry pdb e =
88 case getPackageVersion e of
89 Nothing -> return pdb
90 Just (p, v)
91 | p `member` core -> return pdb
92 | otherwise ->
93 case Map.lookup p deps of
94 Just (vrange, _maintainer)
95 | not $ withinRange v vrange -> return pdb
96 _ -> do
97 let pkgname = packageVersionString (p, v)
98 tarball = selectTarballDir settings </> pkgname <.> "tar.gz"
99 exists <- doesFileExist tarball
100 if exists
101 then do
102 lbs <- L.readFile tarball
103 findCabalAndAddPackage tarball p v pdb $ Tar.read $ GZip.decompress lbs
104 else
105 case Tar.entryContent e of
106 Tar.NormalFile bs _ -> addPackage p v bs pdb
107 _ -> return pdb
109 addTarball :: PackageDB -> FilePath -> IO PackageDB
110 addTarball pdb tarball' = do
111 lbs <- L.readFile tarball
112 let (v', p') = break (== '-') $ reverse tarball'
113 p = PackageName $ reverse $ drop 1 p'
114 v <- maybe (error $ "Invalid tarball name: " ++ tarball) return
115 $ simpleParse $ reverse v'
116 findCabalAndAddPackage tarball p v pdb $ Tar.read $ GZip.decompress lbs
117 where
118 tarball = selectTarballDir settings </> tarball' <.> "tar.gz"
120 skipTests p = p `Set.member` skippedTests settings
122 -- Find the relevant cabal file in the given entries and add its contents
123 -- to the package database
124 findCabalAndAddPackage tarball p v pdb =
125 loop
126 where
127 fixPath '\\' = '/'
128 fixPath c = c
130 expectedPath = let PackageName p' = p in concat
131 [ packageVersionString (p, v)
132 , "/"
133 , p'
134 , ".cabal"
135 ]
136 loop Tar.Done = error $ concat
137 [ "Missing cabal file "
138 , show expectedPath
139 , " in tarball: "
140 , show tarball
141 ]
142 loop (Tar.Fail e) = error $ concat
143 [ "Unable to read tarball "
144 , show tarball
145 , ": "
146 , show e
147 ]
148 loop (Tar.Next entry rest)
149 | map fixPath (Tar.entryPath entry) == expectedPath =
150 case Tar.entryContent entry of
151 Tar.NormalFile bs _ -> addPackage p v bs pdb
152 _ -> error $ concat
153 [ "In tarball "
154 , show tarball
155 , " the cabal file "
156 , show expectedPath
157 , " was not a normal file"
158 ]
159 | otherwise = loop rest
161 addPackage p v lbs pdb = do
162 let (deps', hasTests, buildToolsExe', buildToolsOther', mgpd, execs, mgithub) = parseDeps p lbs
163 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
164 { piVersion = v
165 , piDeps = deps'
166 , piHasTests = hasTests
167 , piBuildToolsExe = buildToolsExe'
168 , piBuildToolsAll = buildToolsExe' `Set.union` buildToolsOther'
169 , piGPD = mgpd
170 , piExecs = execs
171 , piGithubUser = mgithub
172 }
174 parseDeps p lbs =
175 case parsePackageDescription $ L8.unpack lbs of
176 ParseOk _ gpd -> (mconcat
177 [ maybe mempty (go gpd) $ condLibrary gpd
178 , mconcat $ map (go gpd . snd) $ condExecutables gpd
179 , if skipTests p
180 then mempty
181 else mconcat $ map (go gpd . snd) $ condTestSuites gpd
182 -- FIXME , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
183 ], not $ null $ condTestSuites gpd
184 , Set.fromList $ map depName $ libExeBuildInfo gpd
185 , Set.fromList $ map depName $ testBenchBuildInfo gpd
186 , Just gpd
187 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
188 , fmap convertGithubUser $ listToMaybe $ catMaybes
189 $ parseGithubUserHP (homepage $ packageDescription gpd)
190 : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
191 )
192 _ -> (mempty, defaultHasTestSuites, Set.empty, Set.empty, Nothing, Set.empty, Nothing)
193 where
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