Skip to content

Commit e056db1

Browse files
snoybergsnoyberg
committed
Fix up BuildPlan for multiple indices
Added perks: * More code sharing with Stack.Package and Stack.Fetch * More efficient cabal file grabbing
1 parent aa09ce9 commit e056db1

5 files changed

Lines changed: 88 additions & 161 deletions

File tree

‎src/Stack/BuildPlan.hs‎

Lines changed: 39 additions & 70 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE DeriveDataTypeable #-}
22
{-# LANGUAGE DeriveGeneric #-}
33
{-# LANGUAGE EmptyDataDecls #-}
4+
{-# LANGUAGE FlexibleContexts #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE TemplateHaskell #-}
67
{-# LANGUAGE TupleSections #-}
@@ -25,10 +26,11 @@ module Stack.BuildPlan
2526
import Control.Applicative ((<$>), (<*>))
2627
import Control.Arrow ((&&&))
2728
import Control.Exception.Enclosed (tryIO, handleIO)
28-
import Control.Monad (liftM)
29+
import Control.Monad (liftM, forM)
2930
import Control.Monad.Catch
3031
import Control.Monad.IO.Class
3132
import Control.Monad.Logger
33+
import Control.Monad.Trans.Control (MonadBaseControl)
3234
import Control.Monad.Reader (asks)
3335
import Control.Monad.State.Strict (State, execState, get, modify,
3436
put)
@@ -37,9 +39,6 @@ import Data.Aeson (withObject, withText, (.:))
3739
import qualified Data.Binary as Binary
3840
import Data.ByteString (ByteString)
3941
import qualified Data.ByteString.Char8 as S8
40-
import Data.Conduit
41-
import qualified Data.Conduit.List as CL
42-
import Data.Either (partitionEithers)
4342
import qualified Data.Foldable as F
4443
import qualified Data.HashMap.Strict as HM
4544
import Data.IntMap (IntMap)
@@ -64,19 +63,18 @@ import Distribution.PackageDescription (GenericPackageDescription,
6463
import GHC.Generics (Generic)
6564
import Network.HTTP.Download
6665
import Path
66+
import Stack.Fetch
6767
import Stack.GhcPkg
6868
import Stack.Types
6969
import Stack.Constants
7070
import Stack.Package
71-
import Stack.PackageIndex
7271
import System.Directory (createDirectoryIfMissing, getDirectoryContents)
7372
import System.FilePath (takeDirectory)
7473

7574
data BuildPlanException
7675
= UnknownPackages
7776
(Map PackageName (Set PackageName)) -- truly unknown
7877
(Map PackageName (Set PackageIdentifier)) -- shadowed
79-
| Couldn'tFindInIndex (Set PackageIdentifier)
8078
deriving (Typeable)
8179
instance Exception BuildPlanException
8280
instance Show BuildPlanException where
@@ -126,10 +124,6 @@ instance Show BuildPlanException where
126124
$ Set.unions
127125
$ Map.elems shadowed
128126

129-
show (Couldn'tFindInIndex idents) =
130-
"Couldn't find the following packages in the index: " ++
131-
intercalate ", " (map packageIdentifierString $ Set.toList idents)
132-
133127
-- | Determine the necessary packages to install to have the given set of
134128
-- packages available.
135129
--
@@ -181,7 +175,7 @@ data MiniBuildPlan = MiniBuildPlan
181175
deriving (Generic, Show)
182176
instance Binary.Binary MiniBuildPlan
183177

184-
toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env)
178+
toMiniBuildPlan :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m)
185179
=> BuildPlan -> m MiniBuildPlan
186180
toMiniBuildPlan bp = do
187181
extras <- addDeps ghcVersion $ fmap goPP $ bpPackages bp
@@ -205,73 +199,48 @@ toMiniBuildPlan bp = do
205199
)
206200

207201
-- | Add in the resolved dependencies from the package index
208-
addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env)
202+
addDeps :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, MonadThrow m, HasConfig env, MonadBaseControl IO m)
209203
=> Version -- ^ GHC version
210204
-> Map PackageName (Version, Map FlagName Bool)
211205
-> m (Map PackageName MiniPackageInfo)
212206
addDeps ghcVersion toCalc = do
213207
menv <- getMinimalEnvOverride
214-
eres <- tryAddDeps menv
215-
case eres of
216-
Left _ -> do
217-
$logInfo "Missing packages in index, updating and trying again"
218-
updateAllIndices menv
219-
tryAddDeps menv >>= either throwM return
220-
Right res -> return res
208+
platform <- asks $ configPlatform . getConfig
209+
resolvedMap <- resolvePackages menv (Map.keysSet idents0) Set.empty
210+
let byIndex = Map.fromListWith (++) $ flip map (Map.toList resolvedMap)
211+
$ \(ident, rp) ->
212+
(indexName $ rpIndex rp,
213+
[( ident
214+
, rpCache rp
215+
, maybe Map.empty snd $ Map.lookup (packageIdentifierName ident) toCalc
216+
)])
217+
res <- forM (Map.toList byIndex) $ \(indexName', pkgs) -> withCabalFiles indexName' pkgs
218+
$ \ident flags cabalBS -> do
219+
gpd <- readPackageUnresolvedBS Nothing cabalBS
220+
let packageConfig = PackageConfig
221+
{ packageConfigEnableTests = False
222+
, packageConfigEnableBenchmarks = False
223+
, packageConfigFlags = flags
224+
, packageConfigGhcVersion = ghcVersion
225+
, packageConfigPlatform = platform
226+
}
227+
name = packageIdentifierName ident
228+
pd = resolvePackageDescription packageConfig gpd
229+
exes = Set.fromList $ map (ExeName . S8.pack . exeName) $ executables pd
230+
notMe = Set.filter (/= name) . Map.keysSet
231+
return (name, MiniPackageInfo
232+
{ mpiVersion = packageIdentifierVersion ident
233+
, mpiFlags = flags
234+
, mpiPackageDeps = notMe $ packageDependencies pd
235+
, mpiToolDeps = Map.keysSet $ packageToolDependencies pd
236+
, mpiExes = exes
237+
})
238+
return $ Map.fromList $ concat res
221239
where
222-
tryAddDeps menv = do
223-
platform <- asks (configPlatform . getConfig)
224-
index:_ <- asks (configPackageIndices . getConfig) -- FIXME
225-
idents <- sourcePackageIndex menv index $$ CL.foldM (go platform) idents0 -- FIXME use the more efficient cabal file lookup code like Stack.Fetch
226-
return $ case partitionEithers $ map hoistEither $ Map.toList idents of
227-
([], pairs) -> Right $ Map.fromList pairs
228-
(missing, _) -> Left $ Couldn'tFindInIndex $ Set.fromList missing
229-
230240
idents0 = Map.fromList
231241
$ map (\(n, (v, f)) -> (PackageIdentifier n v, Left f))
232242
$ Map.toList toCalc
233243

234-
hoistEither (ident, Left _) = Left ident
235-
hoistEither (PackageIdentifier name version, Right (flags, pdeps, tdeps, exes)) =
236-
Right (name, MiniPackageInfo
237-
{ mpiVersion = version
238-
, mpiFlags = flags
239-
, mpiPackageDeps = pdeps
240-
, mpiToolDeps = tdeps
241-
, mpiExes = exes
242-
})
243-
244-
go platform m (Left ucf) =
245-
case Map.lookup ident m of
246-
Just (Left flags) -> do
247-
gpd <- ucfParse ucf
248-
let packageConfig = PackageConfig
249-
{ packageConfigEnableTests = False
250-
, packageConfigEnableBenchmarks = False
251-
, packageConfigFlags = flags
252-
, packageConfigGhcVersion = ghcVersion
253-
, packageConfigPlatform = platform
254-
}
255-
pd = resolvePackageDescription packageConfig gpd
256-
pdeps = Map.filterWithKey
257-
(const . (/= ucfName ucf))
258-
(packageDependencies pd)
259-
tdeps = Map.keysSet (packageToolDependencies pd)
260-
exes = Set.fromList $ map (ExeName . S8.pack . exeName) $ executables pd
261-
return $ Map.insert
262-
ident
263-
(Right
264-
( flags
265-
, Map.keysSet pdeps
266-
, tdeps
267-
, exes
268-
))
269-
m
270-
_ -> return m
271-
where
272-
ident = PackageIdentifier (ucfName ucf) (ucfVersion ucf)
273-
go _ m (Right _) = return m
274-
275244
-- | Resolve all packages necessary to install for
276245
getDeps :: MiniBuildPlan
277246
-> (PackageName -> Bool) -- ^ is it shadowed by a local package?
@@ -390,7 +359,7 @@ instance FromJSON Snapshots where
390359

391360
-- | Load up a 'MiniBuildPlan', preferably from cache
392361
loadMiniBuildPlan
393-
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env)
362+
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)
394363
=> SnapName
395364
-> Map PackageName Version -- ^ packages in global database
396365
-> m MiniBuildPlan
@@ -546,7 +515,7 @@ checkDeps flags deps packages = do
546515

547516
-- | Find a snapshot and set of flags that is compatible with the given
548517
-- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found.
549-
findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env)
518+
findBuildPlan :: (MonadIO m, MonadCatch m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m)
550519
=> Path Abs File
551520
-> GenericPackageDescription
552521
-> m (Maybe (SnapName, Map FlagName Bool))

‎src/Stack/Config.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Control.Monad.Catch
3131
import Control.Monad.IO.Class
3232
import Control.Monad.Logger hiding (Loc)
3333
import Control.Monad.Reader (MonadReader, ask, runReaderT)
34+
import Control.Monad.Trans.Control (MonadBaseControl)
3435
import Data.Aeson
3536
import Data.Either (partitionEithers)
3637
import Data.Map (Map)
@@ -74,7 +75,7 @@ data ConfigMonoid =
7475
deriving Show
7576

7677
-- | Get the default resolver value
77-
getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m)
78+
getDefaultResolver :: (MonadIO m, MonadCatch m, MonadReader env m, HasConfig env, HasHttpManager env, MonadLogger m, MonadBaseControl IO m)
7879
=> Path Abs Dir
7980
-> m (Resolver, Map PackageName (Map FlagName Bool), Bool)
8081
getDefaultResolver dir = do
@@ -278,7 +279,7 @@ instance HasPlatform MiniConfig
278279

279280
-- | Load the configuration, using current directory, environment variables,
280281
-- and defaults as necessary.
281-
loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env)
282+
loadConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env,MonadBaseControl IO m)
282283
=> m (LoadConfig m)
283284
loadConfig = do
284285
stackRoot <- determineStackRoot
@@ -296,7 +297,7 @@ loadConfig = do
296297

297298
-- | Load the build configuration, adds build-specific values to config loaded by @loadConfig@.
298299
-- values.
299-
loadBuildConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env)
300+
loadBuildConfig :: (MonadLogger m,MonadIO m,MonadCatch m,MonadReader env m,HasHttpManager env,MonadBaseControl IO m)
300301
=> Maybe (Project, Path Abs File, ConfigMonoid)
301302
-> Config
302303
-> m BuildConfig

‎src/Stack/Fetch.hs‎

Lines changed: 23 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,9 @@
1414
module Stack.Fetch
1515
( unpackPackages
1616
, unpackPackageIdents
17+
, resolvePackages
18+
, ResolvedPackage (..)
19+
, withCabalFiles
1720
) where
1821

1922
import qualified Codec.Archive.Tar as Tar
@@ -200,6 +203,23 @@ data ToFetchResult = ToFetchResult
200203
, tfrAlreadyUnpacked :: !(Map PackageIdentifier (Path Abs Dir))
201204
}
202205

206+
-- | Add the cabal files to a list of idents with their caches.
207+
withCabalFiles
208+
:: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)
209+
=> IndexName
210+
-> [(PackageIdentifier, PackageCache, a)]
211+
-> (PackageIdentifier -> a -> ByteString -> IO b)
212+
-> m [b]
213+
withCabalFiles name pkgs f = do
214+
indexPath <- configPackageIndex name
215+
liftIO $ withBinaryFile (toFilePath indexPath) ReadMode $ \h ->
216+
mapM (goPkg h) pkgs
217+
where
218+
goPkg h (ident, pc, tf) = do
219+
hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc
220+
cabalBS <- S.hGet h $ fromIntegral $ pcSize pc
221+
f ident tf cabalBS
222+
203223
-- | Figure out where to fetch from.
204224
getToFetch :: (MonadThrow m, MonadIO m, MonadReader env m, HasConfig env)
205225
=> Path Abs Dir -- ^ directory to unpack into
@@ -235,14 +255,9 @@ getToFetch dest resolvedAll = do
235255
, tfCabal = S.empty -- filled in by goIndex
236256
})])
237257

238-
goIndex (name, pkgs) = do
239-
indexPath <- configPackageIndex name
240-
liftIO $ withBinaryFile (toFilePath indexPath) ReadMode $ \h ->
241-
liftM Map.fromList $ mapM (goPkg h) pkgs
242-
243-
goPkg h (ident, pc, tf) = do
244-
hSeek h AbsoluteSeek $ fromIntegral $ pcOffset pc
245-
cabalBS <- S.hGet h $ fromIntegral $ pcSize pc
258+
goIndex (name, pkgs) =
259+
liftM Map.fromList $
260+
withCabalFiles name pkgs $ \ident tf cabalBS ->
246261
return (ident, tf { tfCabal = cabalBS })
247262

248263
-- | Download the given name,version pairs into the directory expected by cabal.

‎src/Stack/Package.hs‎

Lines changed: 20 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@
1111
module Stack.Package
1212
(readPackage
1313
,readPackageUnresolved
14+
,readPackageUnresolvedBS
1415
,resolvePackage
1516
,getCabalFileName
1617
,Package(..)
@@ -72,7 +73,7 @@ data PackageException
7273
= PackageConfigError ParseException
7374
| PackageNoConfigFile
7475
| PackageNoCabalFile (Path Abs Dir)
75-
| PackageInvalidCabalFile (Path Abs File) PError
76+
| PackageInvalidCabalFile (Maybe (Path Abs File)) PError
7677
| PackageDepCycle PackageName
7778
| PackageMissingDep Package PackageName VersionRange
7879
| PackageDependencyIssues [PackageException]
@@ -131,16 +132,28 @@ instance Eq Package where
131132
(==) = on (==) packageName
132133

133134
-- | Read the raw, unresolved package information.
134-
readPackageUnresolved :: (MonadLogger m, MonadIO m, MonadThrow m)
135+
readPackageUnresolved :: (MonadIO m, MonadThrow m)
135136
=> Path Abs File
136137
-> m GenericPackageDescription
137-
readPackageUnresolved cabalfp = do
138-
do bs <- liftIO (S.readFile (FL.toFilePath cabalfp))
139-
let chars = T.unpack (decodeUtf8With lenientDecode bs)
140-
case parsePackageDescription chars of
138+
readPackageUnresolved cabalfp =
139+
liftIO (S.readFile (FL.toFilePath cabalfp))
140+
>>= readPackageUnresolvedBS (Just cabalfp)
141+
142+
-- | Read the raw, unresolved package information from a ByteString.
143+
readPackageUnresolvedBS :: (MonadThrow m)
144+
=> Maybe (Path Abs File)
145+
-> S.ByteString
146+
-> m GenericPackageDescription
147+
readPackageUnresolvedBS mcabalfp bs =
148+
case parsePackageDescription chars of
141149
ParseFailed per ->
142-
throwM (PackageInvalidCabalFile cabalfp per)
150+
throwM (PackageInvalidCabalFile mcabalfp per)
143151
ParseOk _ gpkg -> return gpkg
152+
where
153+
chars = T.unpack (dropBOM (decodeUtf8With lenientDecode bs))
154+
155+
-- https://github.com/haskell/hackage-server/issues/351
156+
dropBOM t = fromMaybe t $ T.stripPrefix "\xFEFF" t
144157

145158
-- | Reads and exposes the package information
146159
readPackage :: (MonadLogger m, MonadIO m, MonadThrow m)

0 commit comments

Comments
 (0)