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