git.iko.soy/stackage
on e8ea642 help sign in
stackage/Stackage/LoadDatabase.hs
260 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 libExeBuildInfo gpd = concat
194 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
195 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
196 ]
197 testBenchBuildInfo gpd = concat
198 [ if skipTests p
199 then []
200 else concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
201 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
202 ]
203 goBI f x = buildTools $ f $ condTreeData x
205 depName (Dependency (PackageName pn) _) = Executable pn
206 go gpd tree
207 = Map.filterWithKey (\k _ -> not $ ignoredDep k)
208 $ Map.unionsWith unionVersionRanges
209 $ Map.fromList (map (\(Dependency pn vr) -> (pn, vr)) $ condTreeConstraints tree)
210 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
212 -- Some specific overrides for cases where getting Stackage to be smart
213 -- enough to handle things would be too difficult.
214 ignoredDep :: PackageName -> Bool
215 ignoredDep dep
216 -- The flag logic used by text-stream-decode confuses Stackage.
217 | dep == PackageName "text" && p == PackageName "text-stream-decode" = True
218 | otherwise = False
220 checkCond gpd (cond, tree, melse)
221 | checkCond' cond = Just tree
222 | otherwise = melse
223 where
224 checkCond' (Var (OS os)) = os == buildOS
225 checkCond' (Var (Arch arch)) = arch == buildArch
227 -- Sigh... the small_base flag on mersenne-random-pure64 is backwards
228 checkCond' (Var (Flag (FlagName "small_base")))
229 | p == PackageName "mersenne-random-pure64" = False
231 checkCond' (Var (Flag flag@(FlagName flag'))) =
232 flag' `Set.notMember` disabledFlags settings &&
233 flag `elem` flags'
234 checkCond' (Var (Impl compiler range)) =
235 compiler == GHC && withinRange ghcVersion' range
236 checkCond' (Lit b) = b
237 checkCond' (CNot c) = not $ checkCond' c
238 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
239 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
241 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
242 (map FlagName $ Set.toList $ Stackage.Types.flags settings coreMap)
244-- | Attempt to grab the Github username from a homepage.
245parseGithubUserHP :: String -> Maybe String
246parseGithubUserHP url1 = do
247 url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
248 [ "http://github.com/"
249 , "https://github.com/"
250 ]
251 let x = takeWhile (/= '/') url2
252 guard $ not $ null x
253 Just x
255-- | Attempt to grab the Github username from a source repo.
256parseGithubUserSR :: SourceRepo -> Maybe String
257parseGithubUserSR sr =
258 case (repoType sr, repoLocation sr) of
259 (Just Git, Just s) -> parseGithubUserHP s
260 _ -> Nothing