git.iko.soy/stackage
on 77fa7fa help sign in
stackage/Stackage/InstallInfo.hs
203 lines 8.2 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.LoadDatabase
18import Stackage.NarrowDatabase
19import Stackage.ServerFiles
20import Stackage.Types
21import Stackage.Util
22import System.Directory (createDirectoryIfMissing)
23import System.FilePath ((</>))
24import qualified System.IO as IO
25import qualified System.IO.UTF8
26import System.Locale (defaultTimeLocale)
27import System.Exit (exitFailure)
29dropExcluded :: SelectSettings
30 -> Map PackageName (VersionRange, Maintainer)
31 -> Map PackageName (VersionRange, Maintainer)
32dropExcluded bs m0 =
33 foldl' (flip Map.delete) m0 (Set.toList $ excludedPackages bs)
35getInstallInfo :: SelectSettings -> IO InstallInfo
36getInstallInfo settings = do
37 core <- do
38 putStrLn "Loading core packages from global database"
39 getGlobalPackages $ selectGhcVersion settings
40 underlay <- getDBPackages (selectUnderlayPackageDirs settings) (selectGhcVersion settings)
41 let underlaySet = Set.map pkgName underlay
42 coreMap = Map.unions
43 $ map (\(PackageIdentifier k v) -> Map.singleton k v)
44 $ Set.toList core
45 allPackages' =
46 stablePackages settings $ requireHaskellPlatform settings
47 allPackages = dropExcluded settings allPackages'
48 totalCore
49 | ignoreUpgradeableCore settings =
50 Map.fromList $ map (\n -> (PackageName n, Nothing)) $ words "base containers template-haskell"
51 | otherwise =
52 Map.fromList (map (\(PackageIdentifier p v) -> (p, Just v)) (Set.toList core))
53 `Map.union` Map.fromList (map (, Nothing) (Set.toList $ extraCore settings))
55 putStrLn "Loading package database"
56 pdb <- loadPackageDB settings coreMap (Map.keysSet totalCore) allPackages underlaySet
58 putStrLn "Narrowing package database"
59 (final, errs) <- narrowPackageDB settings (Map.keysSet totalCore) pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
61 putStrLn "Printing build plan to build-plan.log"
62 System.IO.UTF8.writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
63 System.IO.UTF8.writeFile "hackage-map.txt" $ unlines $ map showHackageMap $ Map.toList final
65 unless (Set.null errs) $ do
66 putStrLn "Build plan requires some disallowed packages"
67 mapM_ putStrLn $ Set.toList errs
68 exitFailure
70 putStrLn "Checking for bad versions"
71 case checkBadVersions settings coreMap pdb final of
72 badVersions
73 | Map.null badVersions -> return ()
74 | otherwise -> do
75 forM_ (Map.toList badVersions) $ \(user, badDeps) -> do
76 putStrLn $ user ++ " cannot use: "
77 forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do
78 putStrLn $ concat
79 [ "- "
80 , packageVersionString (name, version)
81 , " -- "
82 , Distribution.Text.display $ simplifyVersionRange range
83 ]
84 putStrLn ""
86 error "Conflicting build plan, exiting"
88 let ii = InstallInfo
89 { iiCore = totalCore
90 , iiPackages = Map.map biToSPI final
91 , iiOptionalCore = Map.empty
92 , iiPackageDB = pdb
93 }
95 forM_ [False, True] $ \isInc -> do
96 let incexc = if isInc then "inclusive" else "exclusive"
98 now <- getCurrentTime
99 let ghcVer =
100 let GhcMajorVersion x y = selectGhcVersion settings
101 in show x ++ "." ++ show y
102 date = formatTime defaultTimeLocale "%Y-%m-%d" now
104 createDirectoryIfMissing True incexc
106 putStrLn $ "Inclusive/exclusive: " ++ incexc
108 putStrLn "Creating hackage file (for publishing to Stackage server)"
109 let isHP = requireHaskellPlatform settings
110 IO.withBinaryFile (incexc </> "hackage") IO.WriteMode $ \hackageH ->
111 IO.withBinaryFile (incexc </> "create-snapshot.sh") IO.WriteMode
112 (createHackageFile isInc isHP ii ghcVer date hackageH)
114 putStrLn "Creating desc file (for publishing to Stackage server)"
115 System.IO.UTF8.writeFile (incexc </> "desc") $ concat
116 [ "Stackage build for GHC "
117 , ghcVer
118 , if requireHaskellPlatform settings
119 then " + Haskell Platform"
120 else ""
121 , ", "
122 , date
123 , ", "
124 , incexc
125 , "\nGenerated on "
126 , show now
127 ]
129 return ii
131biToSPI :: BuildInfo -> SelectedPackageInfo
132biToSPI BuildInfo {..} = SelectedPackageInfo
133 { spiVersion = biVersion
134 , spiMaintainer = biMaintainer
135 , spiGithubUser = biGithubUser
136 , spiHasTests = biHasTests
137 }
139showDep :: (PackageName, BuildInfo) -> String
140showDep (PackageName name, BuildInfo {..}) =
141 concat
142 [ name
143 , "-"
144 , showVersion biVersion
145 , " ("
146 , unMaintainer biMaintainer
147 , " " ++ githubMentions biGithubUser
148 , ")"
149 , ": "
150 , unwords $ map unP biUsers
151 ]
152 where
153 unP (PackageName p) = p
155-- | Convert to format used by Hackage for displaying distribution versions.
156-- For more info, see https://github.com/fpco/stackage/issues/38.
157showHackageMap :: (PackageName, BuildInfo) -> String
158showHackageMap (PackageName name, BuildInfo {..}) =
159 show (name, showVersion biVersion, Nothing :: Maybe String)
161bpPackageList :: BuildPlan -> [String]
162bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
164-- | Check for internal mismatches in required and actual package versions.
165checkBadVersions :: SelectSettings
166 -> Map PackageName Version -- ^ core
167 -> PackageDB
168 -> Map PackageName BuildInfo
169 -> Map String (Map PackageName (Version, VersionRange))
170checkBadVersions settings core (PackageDB pdb) buildPlan =
171 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
172 where
173 unexpectedFailure name _ = name `Set.notMember` expectedFailures settings
175 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
176 getBadVersions (name, bi)
177 | Map.null badVersions = Map.empty
178 | otherwise = Map.singleton display badVersions
179 where
180 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
181 display = concat
182 [ packageVersionString (name, biVersion bi)
183 , " ("
184 , unMaintainer $ biMaintainer bi
185 , case Map.lookup name pdb of
186 Just PackageInfo { piGithubUser = gus } -> " " ++ githubMentions gus
187 _ -> ""
188 , ")"
189 ]
191 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
192 checkPackage name vr =
193 case Map.lookup name buildPlan of
194 Nothing ->
195 case Map.lookup name core of
196 -- Might be part of extra-core
197 Nothing -> Map.empty
198 Just version
199 | version `withinRange` vr -> Map.empty
200 | otherwise -> Map.singleton name (version, vr)
201 Just bi
202 | biVersion bi `withinRange` vr -> Map.empty
203 | otherwise -> Map.singleton name (biVersion bi, vr)