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