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