git.iko.soy/stackage
on e4cfbdf help sign in
stackage/Stackage/LoadDatabase.hs
161 lines 8.2 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 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 parseDeps lbs =
96 case parsePackageDescription $ L8.unpack lbs of
97 ParseOk _ gpd -> (mconcat
98 [ maybe mempty (go gpd) $ condLibrary gpd
99 , mconcat $ map (go gpd . snd) $ condExecutables gpd
100 , mconcat $ map (go gpd . snd) $ condTestSuites gpd
101 , mconcat $ map (go gpd . snd) $ condBenchmarks gpd
102 ], not $ null $ condTestSuites gpd
103 , Set.fromList $ map depName $ allBuildInfo gpd
104 , Just gpd
105 , Set.fromList $ map (Executable . fst) $ condExecutables gpd
106 , listToMaybe $ catMaybes
107 $ parseGithubUserHP (homepage $ packageDescription gpd)
108 : map parseGithubUserSR (sourceRepos $ packageDescription gpd)
109 )
110 _ -> (mempty, defaultHasTestSuites, Set.empty, Nothing, Set.empty, Nothing)
111 where
112 allBuildInfo gpd = concat
113 [ maybe mempty (goBI libBuildInfo) $ condLibrary gpd
114 , concat $ map (goBI buildInfo . snd) $ condExecutables gpd
115 , concat $ map (goBI testBuildInfo . snd) $ condTestSuites gpd
116 , concat $ map (goBI benchmarkBuildInfo . snd) $ condBenchmarks gpd
117 ]
118 where
119 goBI f x = buildTools $ f $ condTreeData x
120 depName (Dependency (PackageName p) _) = Executable p
121 go gpd tree
122 = Map.unionsWith unionVersionRanges
123 $ Map.fromList (map (\(Dependency p vr) -> (p, vr)) $ condTreeConstraints tree)
124 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
126 checkCond gpd (cond, tree, melse)
127 | checkCond' cond = Just tree
128 | otherwise = melse
129 where
130 checkCond' (Var (OS os)) = os == buildOS
131 checkCond' (Var (Arch arch)) = arch == buildArch
132 checkCond' (Var (Flag flag@(FlagName flag'))) =
133 flag' `Set.notMember` disabledFlags settings &&
134 flag `elem` flags'
135 checkCond' (Var (Impl compiler range)) =
136 compiler == GHC && withinRange targetCompilerVersion range
137 checkCond' (Lit b) = b
138 checkCond' (CNot c) = not $ checkCond' c
139 checkCond' (COr c1 c2) = checkCond' c1 || checkCond' c2
140 checkCond' (CAnd c1 c2) = checkCond' c1 && checkCond' c2
142 flags' = map flagName (filter flagDefault $ genPackageFlags gpd) ++
143 (map FlagName $ Set.toList $ Stackage.Types.flags settings coreMap)
145-- | Attempt to grab the Github username from a homepage.
146parseGithubUserHP :: String -> Maybe String
147parseGithubUserHP url1 = do
148 url2 <- listToMaybe $ mapMaybe (flip stripPrefix url1)
149 [ "http://github.com/"
150 , "https://github.com/"
151 ]
152 let x = takeWhile (/= '/') url2
153 guard $ not $ null x
154 Just x
156-- | Attempt to grab the Github username from a source repo.
157parseGithubUserSR :: SourceRepo -> Maybe String
158parseGithubUserSR sr =
159 case (repoType sr, repoLocation sr) of
160 (Just Git, Just s) -> parseGithubUserHP s
161 _ -> Nothing