git.iko.soy/stackage
on 62064dc help sign in
stackage/Stackage/InstallInfo.hs
212 lines 8.5 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE TupleSections #-}
3module Stackage.InstallInfo
4 ( getInstallInfo
5 , bpPackageList
6 ) where
8import Control.Monad (forM_, unless)
9import Data.List (foldl')
10import qualified Data.Map as Map
11import qualified Data.Set as Set
12import Data.Time (getCurrentTime, formatTime)
13import Data.Version (showVersion)
14import qualified Distribution.Text
15import Distribution.Version (simplifyVersionRange, withinRange)
16import Stackage.GhcPkg
17import Stackage.HaskellPlatform
18import Stackage.LoadDatabase
19import Stackage.NarrowDatabase
20import Stackage.ServerFiles
21import Stackage.Types
22import Stackage.Util
23import System.Directory (createDirectoryIfMissing)
24import System.FilePath ((</>))
25import qualified System.IO as IO
26import qualified System.IO.UTF8
27import System.Locale (defaultTimeLocale)
28import System.Exit (exitFailure)
30dropExcluded :: SelectSettings
31 -> Map PackageName (VersionRange, Maintainer)
32 -> Map PackageName (VersionRange, Maintainer)
33dropExcluded bs m0 =
34 foldl' (flip Map.delete) m0 (Set.toList $ excludedPackages bs)
36getInstallInfo :: SelectSettings -> IO InstallInfo
37getInstallInfo settings = do
38 putStrLn "Loading Haskell Platform"
39 mhp <- loadHaskellPlatform settings
41 core <-
42 case mhp of
43 Just hp | not (useGlobalDatabase settings) -> return $ hpcore hp
44 _ -> do
45 putStrLn "Loading core packages from global database"
46 getGlobalPackages $ selectGhcVersion settings
47 let coreMap = Map.unions
48 $ map (\(PackageIdentifier k v) -> Map.singleton k v)
49 $ Set.toList core
51 let allPackages' =
52 case mhp of
53 Just hp | requireHaskellPlatform settings ->
54 Map.union (stablePackages settings $ requireHaskellPlatform settings)
55 $ identsToRanges (hplibs hp)
56 _ -> stablePackages settings $ requireHaskellPlatform settings
57 allPackages = dropExcluded settings allPackages'
58 let totalCore
59 | ignoreUpgradeableCore settings =
60 Map.fromList $ map (\n -> (PackageName n, Nothing)) $ words "base containers template-haskell"
61 | otherwise =
62 Map.fromList (map (\(PackageIdentifier p v) -> (p, Just v)) (Set.toList core))
63 `Map.union` Map.fromList (map (, Nothing) (Set.toList $ extraCore settings))
65 putStrLn "Loading package database"
66 pdb <- loadPackageDB settings coreMap (Map.keysSet totalCore) allPackages
68 putStrLn "Narrowing package database"
69 (final, errs) <- narrowPackageDB settings (Map.keysSet totalCore) pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
71 putStrLn "Printing build plan to build-plan.log"
72 System.IO.UTF8.writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
73 System.IO.UTF8.writeFile "hackage-map.txt" $ unlines $ map showHackageMap $ Map.toList final
75 unless (Set.null errs) $ do
76 putStrLn "Build plan requires some disallowed packages"
77 mapM_ putStrLn $ Set.toList errs
78 exitFailure
80 putStrLn "Checking for bad versions"
81 case checkBadVersions settings coreMap pdb final of
82 badVersions
83 | Map.null badVersions -> return ()
84 | otherwise -> do
85 forM_ (Map.toList badVersions) $ \(user, badDeps) -> do
86 putStrLn $ user ++ " cannot use: "
87 forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do
88 putStrLn $ concat
89 [ "- "
90 , packageVersionString (name, version)
91 , " -- "
92 , Distribution.Text.display $ simplifyVersionRange range
93 ]
94 putStrLn ""
96 error "Conflicting build plan, exiting"
98 let ii = InstallInfo
99 { iiCore = totalCore
100 , iiPackages = Map.map biToSPI final
101 , iiOptionalCore = maybe
102 Map.empty
103 (Map.fromList . map (\(PackageIdentifier p v) -> (p, v)) . Set.toList . hplibs)
104 mhp
105 , iiPackageDB = pdb
106 }
108 forM_ [False, True] $ \isInc -> do
109 let incexc = if isInc then "inclusive" else "exclusive"
111 now <- getCurrentTime
112 let ghcVer =
113 let GhcMajorVersion x y = selectGhcVersion settings
114 in show x ++ "." ++ show y
115 date = formatTime defaultTimeLocale "%Y-%m-%d" now
117 createDirectoryIfMissing True incexc
119 putStrLn $ "Inclusive/exclusive: " ++ incexc
121 putStrLn "Creating hackage file (for publishing to Stackage server)"
122 IO.withBinaryFile (incexc </> "hackage") IO.WriteMode $ \hackageH ->
123 IO.withBinaryFile (incexc </> "create-snapshot.sh") IO.WriteMode
124 (createHackageFile isInc ii ghcVer date hackageH)
126 putStrLn "Creating desc file (for publishing to Stackage server)"
127 System.IO.UTF8.writeFile (incexc </> "desc") $ concat
128 [ "Stackage build for GHC "
129 , ghcVer
130 , ", "
131 , date
132 , ", "
133 , incexc
134 , "\nGenerated on "
135 , show now
136 ]
138 return ii
140biToSPI :: BuildInfo -> SelectedPackageInfo
141biToSPI BuildInfo {..} = SelectedPackageInfo
142 { spiVersion = biVersion
143 , spiMaintainer = biMaintainer
144 , spiGithubUser = biGithubUser
145 , spiHasTests = biHasTests
146 }
148showDep :: (PackageName, BuildInfo) -> String
149showDep (PackageName name, BuildInfo {..}) =
150 concat
151 [ name
152 , "-"
153 , showVersion biVersion
154 , " ("
155 , unMaintainer biMaintainer
156 , " " ++ githubMentions biGithubUser
157 , ")"
158 , ": "
159 , unwords $ map unP biUsers
160 ]
161 where
162 unP (PackageName p) = p
164-- | Convert to format used by Hackage for displaying distribution versions.
165-- For more info, see https://github.com/fpco/stackage/issues/38.
166showHackageMap :: (PackageName, BuildInfo) -> String
167showHackageMap (PackageName name, BuildInfo {..}) =
168 show (name, showVersion biVersion, Nothing :: Maybe String)
170bpPackageList :: BuildPlan -> [String]
171bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
173-- | Check for internal mismatches in required and actual package versions.
174checkBadVersions :: SelectSettings
175 -> Map PackageName Version -- ^ core
176 -> PackageDB
177 -> Map PackageName BuildInfo
178 -> Map String (Map PackageName (Version, VersionRange))
179checkBadVersions settings core (PackageDB pdb) buildPlan =
180 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
181 where
182 unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings
184 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
185 getBadVersions (name, bi)
186 | Map.null badVersions = Map.empty
187 | otherwise = Map.singleton display badVersions
188 where
189 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
190 display = concat
191 [ packageVersionString (name, biVersion bi)
192 , " ("
193 , unMaintainer $ biMaintainer bi
194 , case Map.lookup name pdb of
195 Just PackageInfo { piGithubUser = gus } -> " " ++ githubMentions gus
196 _ -> ""
197 , ")"
198 ]
200 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
201 checkPackage name vr =
202 case Map.lookup name buildPlan of
203 Nothing ->
204 case Map.lookup name core of
205 -- Might be part of extra-core
206 Nothing -> Map.empty
207 Just version
208 | version `withinRange` vr -> Map.empty
209 | otherwise -> Map.singleton name (version, vr)
210 Just bi
211 | biVersion bi `withinRange` vr -> Map.empty
212 | otherwise -> Map.singleton name (biVersion bi, vr)