git.iko.soy/stackage
on 0bb3e90 help sign in
stackage/Stackage/InstallInfo.hs
213 lines 8.7 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 underlay <- getDBPackages (selectUnderlayPackageDirs settings) (selectGhcVersion settings)
48 let underlaySet = Set.map pkgName underlay
49 coreMap = Map.unions
50 $ map (\(PackageIdentifier k v) -> Map.singleton k v)
51 $ Set.toList core
52 allPackages' =
53 case mhp of
54 Just hp | requireHaskellPlatform settings ->
55 Map.union (stablePackages settings $ requireHaskellPlatform settings)
56 $ identsToRanges (hplibs hp)
57 _ -> stablePackages settings $ requireHaskellPlatform settings
58 allPackages = dropExcluded settings allPackages'
59 totalCore
60 | ignoreUpgradeableCore settings =
61 Map.fromList $ map (\n -> (PackageName n, Nothing)) $ words "base containers template-haskell"
62 | otherwise =
63 Map.fromList (map (\(PackageIdentifier p v) -> (p, Just v)) (Set.toList core))
64 `Map.union` Map.fromList (map (, Nothing) (Set.toList $ extraCore settings))
66 putStrLn "Loading package database"
67 pdb <- loadPackageDB settings coreMap (Map.keysSet totalCore) allPackages underlaySet
69 putStrLn "Narrowing package database"
70 (final, errs) <- narrowPackageDB settings (Map.keysSet totalCore) pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
72 putStrLn "Printing build plan to build-plan.log"
73 System.IO.UTF8.writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
74 System.IO.UTF8.writeFile "hackage-map.txt" $ unlines $ map showHackageMap $ Map.toList final
76 unless (Set.null errs) $ do
77 putStrLn "Build plan requires some disallowed packages"
78 mapM_ putStrLn $ Set.toList errs
79 exitFailure
81 putStrLn "Checking for bad versions"
82 case checkBadVersions settings coreMap pdb final of
83 badVersions
84 | Map.null badVersions -> return ()
85 | otherwise -> do
86 forM_ (Map.toList badVersions) $ \(user, badDeps) -> do
87 putStrLn $ user ++ " cannot use: "
88 forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do
89 putStrLn $ concat
90 [ "- "
91 , packageVersionString (name, version)
92 , " -- "
93 , Distribution.Text.display $ simplifyVersionRange range
94 ]
95 putStrLn ""
97 error "Conflicting build plan, exiting"
99 let ii = InstallInfo
100 { iiCore = totalCore
101 , iiPackages = Map.map biToSPI final
102 , iiOptionalCore = maybe
103 Map.empty
104 (Map.fromList . map (\(PackageIdentifier p v) -> (p, v)) . Set.toList . hplibs)
105 mhp
106 , iiPackageDB = pdb
107 }
109 forM_ [False, True] $ \isInc -> do
110 let incexc = if isInc then "inclusive" else "exclusive"
112 now <- getCurrentTime
113 let ghcVer =
114 let GhcMajorVersion x y = selectGhcVersion settings
115 in show x ++ "." ++ show y
116 date = formatTime defaultTimeLocale "%Y-%m-%d" now
118 createDirectoryIfMissing True incexc
120 putStrLn $ "Inclusive/exclusive: " ++ incexc
122 putStrLn "Creating hackage file (for publishing to Stackage server)"
123 IO.withBinaryFile (incexc </> "hackage") IO.WriteMode $ \hackageH ->
124 IO.withBinaryFile (incexc </> "create-snapshot.sh") IO.WriteMode
125 (createHackageFile isInc ii ghcVer date hackageH)
127 putStrLn "Creating desc file (for publishing to Stackage server)"
128 System.IO.UTF8.writeFile (incexc </> "desc") $ concat
129 [ "Stackage build for GHC "
130 , ghcVer
131 , ", "
132 , date
133 , ", "
134 , incexc
135 , "\nGenerated on "
136 , show now
137 ]
139 return ii
141biToSPI :: BuildInfo -> SelectedPackageInfo
142biToSPI BuildInfo {..} = SelectedPackageInfo
143 { spiVersion = biVersion
144 , spiMaintainer = biMaintainer
145 , spiGithubUser = biGithubUser
146 , spiHasTests = biHasTests
147 }
149showDep :: (PackageName, BuildInfo) -> String
150showDep (PackageName name, BuildInfo {..}) =
151 concat
152 [ name
153 , "-"
154 , showVersion biVersion
155 , " ("
156 , unMaintainer biMaintainer
157 , " " ++ githubMentions biGithubUser
158 , ")"
159 , ": "
160 , unwords $ map unP biUsers
161 ]
162 where
163 unP (PackageName p) = p
165-- | Convert to format used by Hackage for displaying distribution versions.
166-- For more info, see https://github.com/fpco/stackage/issues/38.
167showHackageMap :: (PackageName, BuildInfo) -> String
168showHackageMap (PackageName name, BuildInfo {..}) =
169 show (name, showVersion biVersion, Nothing :: Maybe String)
171bpPackageList :: BuildPlan -> [String]
172bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
174-- | Check for internal mismatches in required and actual package versions.
175checkBadVersions :: SelectSettings
176 -> Map PackageName Version -- ^ core
177 -> PackageDB
178 -> Map PackageName BuildInfo
179 -> Map String (Map PackageName (Version, VersionRange))
180checkBadVersions settings core (PackageDB pdb) buildPlan =
181 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
182 where
183 unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings
185 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
186 getBadVersions (name, bi)
187 | Map.null badVersions = Map.empty
188 | otherwise = Map.singleton display badVersions
189 where
190 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
191 display = concat
192 [ packageVersionString (name, biVersion bi)
193 , " ("
194 , unMaintainer $ biMaintainer bi
195 , case Map.lookup name pdb of
196 Just PackageInfo { piGithubUser = gus } -> " " ++ githubMentions gus
197 _ -> ""
198 , ")"
199 ]
201 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
202 checkPackage name vr =
203 case Map.lookup name buildPlan of
204 Nothing ->
205 case Map.lookup name core of
206 -- Might be part of extra-core
207 Nothing -> Map.empty
208 Just version
209 | version `withinRange` vr -> Map.empty
210 | otherwise -> Map.singleton name (version, vr)
211 Just bi
212 | biVersion bi `withinRange` vr -> Map.empty
213 | otherwise -> Map.singleton name (biVersion bi, vr)