git.iko.soy/stackage
on c496bbf help sign in
stackage/Stackage/LoadDatabase.hs
172 lines 8.6 kB history raw
1module Stackage.LoadDatabase where
3import qualified Codec.Archive.Tar as Tar
4import Control.Monad (guard)
5import qualified Data.ByteString.Lazy as L
6import qualified Data.ByteString.Lazy.Char8 as L8
7import Data.List (stripPrefix)
8import qualified Data.Map as Map
9import Data.Maybe (catMaybes, listToMaybe,
10 mapMaybe)
11import Data.Monoid (Monoid (..))
12import Data.Set (member)
13import qualified Data.Set as Set
14import Distribution.Compiler (CompilerFlavor (GHC))
15import Distribution.Package (Dependency (Dependency))
16import Distribution.PackageDescription (Condition (..),
17 ConfVar (..),
18 FlagName (FlagName),
19 RepoType (Git),
20 SourceRepo (..),
21 benchmarkBuildInfo,
22 buildInfo, buildTools,
23 condBenchmarks,
24 condExecutables,
25 condLibrary,
26 condTestSuites,
27 condTreeComponents,
28 condTreeConstraints,
29 condTreeData,
30 flagDefault, flagName,
31 genPackageFlags,
32 homepage, libBuildInfo,
33 packageDescription,
34 sourceRepos,
35 testBuildInfo)
36import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
37 parsePackageDescription)
38import Distribution.System (buildArch, buildOS)
39import Distribution.Version (unionVersionRanges,
40 withinRange)
41import Stackage.Config
42import Stackage.Types
43import Stackage.Util
45-- | Load the raw package database.
46--
47-- We want to put in some restrictions:
48--
49-- * Drop all core packages. We never want to install a new version of
50-- those, nor include them in the package list.
51--
52-- * For packages with a specific version bound, find the maximum matching
53-- version.
54--
55-- * For other packages, select the maximum version number.
56loadPackageDB :: SelectSettings
57 -> Map PackageName Version -- ^ core packages from HP file
58 -> Set PackageName -- ^ all core packages, including extras
59 -> Map PackageName (VersionRange, Maintainer) -- ^ additional deps
60 -> IO PackageDB
61loadPackageDB settings coreMap core deps = do
62 tarName <- getTarballName
63 lbs <- L.readFile tarName
64 addEntries mempty $ Tar.read lbs
65 where
66 addEntries _ (Tar.Fail e) = error $ show e
67 addEntries db Tar.Done = return db
68 addEntries db (Tar.Next e es) = addEntry db e >>= flip addEntries es
70 addEntry :: PackageDB -> Tar.Entry -> IO PackageDB
71 addEntry pdb e =
72 case getPackageVersion e of
73 Nothing -> return pdb
74 Just (p, v)
75 | p `member` core -> return pdb
76 | otherwise ->
77 case Map.lookup p deps of
78 Just (vrange, _maintainer)
79 | not $ withinRange v vrange -> return pdb
80 _ ->
81 case Tar.entryContent e of
82 Tar.NormalFile bs _ -> do
83 let (deps', hasTests, buildTools', mgpd, execs, mgithub) = parseDeps p bs
84 return $ mappend pdb $ PackageDB $ Map.singleton p PackageInfo
85 { piVersion = v
86 , piDeps = deps'
87 , piHasTests = hasTests
88 , piBuildTools = buildTools'
89 , piGPD = mgpd
90 , piExecs = execs
91 , piGithubUser = mgithub
92 }
93 _ -> return pdb
95 skipTests p = p `Set.member` skippedTests settings
97 parseDeps p lbs =
98 case parsePackageDescription $ L8.unpack lbs of
99 ParseOk _ gpd -> (mconcat
100 [ maybe mempty (go gpd) $ condLibrary gpd
101 , mconcat $ map (go gpd . snd) $ condExecutables gpd
102 , if skipTests p
103 then mempty
104 else mconcat $ map (go gpd . snd) $ condTestSuites gpd
105 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
106 ], not $ null $ condTestSuites gpd
107 , Set.fromList $ map depName $ allBuildInfo gpd
108 , Just gpd
109 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
110 , listToMaybe $ catMaybes
111 $ parseGithubUserHP (homepage $ packageDescription gpd)
112 : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
113 )
114 _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty, Nothing)
115 where
116 allBuildInfo gpd = concat
117 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
118 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
119 , if skipTests p
120 then []
121 else concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
122 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
123 ]
124 where
125 goBI f x = buildTools $ f $ condTreeData x
126 depName (Dependency (PackageName pn) _) = Executable pn
127 go gpd tree
128 = Map.unionsWith unionVersionRanges
129 $ Map.fromList (map (\(Dependency pn vr) -> (pn, vr)) $ condTreeConstraints tree)
130 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
132 checkCond gpd (cond, tree, melse)
133 | checkCond' cond = Just tree
134 | otherwise = melse
135 where
136 checkCond' (Var (OS os)) = os == buildOS
137 checkCond' (Var (Arch arch)) = arch == buildArch
139 -- Sigh... the small_base flag on mersenne-random-pure64 is backwards
140 checkCond' (Var (Flag (FlagName "small_base")))
141 | p == PackageName "mersenne-random-pure64" = False
143 checkCond' (Var (Flag flag@(FlagName flag'))) =
144 flag' `Set.notMember` disabledFlags settings &&
145 flag `elem` flags'
146 checkCond' (Var (Impl compiler range)) =
147 compiler == GHC && withinRange targetCompilerVersion range
148 checkCond' (Lit b) = b
149 checkCond' (CNot c) = not $ checkCond' c
150 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
151 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
153 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
154 (map FlagName $ Set.toList $ Stackage.Types.flags settings coreMap)
156-- | Attempt to grab the Github username from a homepage.
157parseGithubUserHP :: String -> Maybe String
158parseGithubUserHP url1 = do
159 url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
160 [ "http://github.com/"
161 , "https://github.com/"
162 ]
163 let x = takeWhile (/= '/') url2
164 guard $ not $ null x
165 Just x
167-- | Attempt to grab the Github username from a source repo.
168parseGithubUserSR :: SourceRepo -> Maybe String
169parseGithubUserSR sr =
170 case (repoType sr, repoLocation sr) of
171 (Just Git, Just s) -> parseGithubUserHP s
172 _ -> Nothing