git.iko.soy/stackage
on fccd62f help sign in
stackage/Stackage/InstallInfo.hs
211 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.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 System.IO.UTF8.writeFile (incexc </> "slug") $ concat
130 [ date
131 , "-ghc"
132 , ghcVer
133 , if requireHaskellPlatform settings then "hp" else ""
134 , if isInc then "-inc" else "-exc"
135 ]
137 return ii
139biToSPI :: BuildInfo -> SelectedPackageInfo
140biToSPI BuildInfo {..} = SelectedPackageInfo
141 { spiVersion = biVersion
142 , spiMaintainer = biMaintainer
143 , spiGithubUser = biGithubUser
144 , spiHasTests = biHasTests
145 }
147showDep :: (PackageName, BuildInfo) -> String
148showDep (PackageName name, BuildInfo {..}) =
149 concat
150 [ name
151 , "-"
152 , showVersion biVersion
153 , " ("
154 , unMaintainer biMaintainer
155 , " " ++ githubMentions biGithubUser
156 , ")"
157 , ": "
158 , unwords $ map unP biUsers
159 ]
160 where
161 unP (PackageName p) = p
163-- | Convert to format used by Hackage for displaying distribution versions.
164-- For more info, see https://github.com/fpco/stackage/issues/38.
165showHackageMap :: (PackageName, BuildInfo) -> String
166showHackageMap (PackageName name, BuildInfo {..}) =
167 show (name, showVersion biVersion, Nothing :: Maybe String)
169bpPackageList :: BuildPlan -> [String]
170bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
172-- | Check for internal mismatches in required and actual package versions.
173checkBadVersions :: SelectSettings
174 -> Map PackageName Version -- ^ core
175 -> PackageDB
176 -> Map PackageName BuildInfo
177 -> Map String (Map PackageName (Version, VersionRange))
178checkBadVersions settings core (PackageDB pdb) buildPlan =
179 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
180 where
181 unexpectedFailure name _ = name `Set.notMember` expectedFailures settings
183 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
184 getBadVersions (name, bi)
185 | Map.null badVersions = Map.empty
186 | otherwise = Map.singleton display badVersions
187 where
188 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
189 display = concat
190 [ packageVersionString (name, biVersion bi)
191 , " ("
192 , unMaintainer $ biMaintainer bi
193 , case Map.lookup name pdb of
194 Just PackageInfo { piGithubUser = gus } -> " " ++ githubMentions gus
195 _ -> ""
196 , ")"
197 ]
199 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
200 checkPackage name vr =
201 case Map.lookup name buildPlan of
202 Nothing ->
203 case Map.lookup name core of
204 -- Might be part of extra-core
205 Nothing -> Map.empty
206 Just version
207 | version `withinRange` vr -> Map.empty
208 | otherwise -> Map.singleton name (version, vr)
209 Just bi
210 | biVersion bi `withinRange` vr -> Map.empty
211 | otherwise -> Map.singleton name (biVersion bi, vr)