Fix priority of core packages:

* `global-hints.yaml` is now used as a fallback for packages that
  are not included in the snapshot
* Fix ordering of dependencies on the package page
This commit is contained in:
Alexey Kuleshevich 2019-07-06 20:52:52 +03:00
parent 148cc8258c
commit 05307bded8
No known key found for this signature in database
GPG Key ID: E59B216127119E3E
3 changed files with 39 additions and 16 deletions

View File

@ -67,7 +67,7 @@ optsParser =
switch switch
(long "cache-cabal-files" <> (long "cache-cabal-files" <>
help help
("Improve performance by cached parsed cabal files" ++ ("Improve performance by caching parsed cabal files" ++
" at expense of higher memory consumption")) " at expense of higher memory consumption"))
where where
repoAccount = "commercialhaskell" repoAccount = "commercialhaskell"

View File

@ -376,7 +376,7 @@ checkForDocs snapshotId snapName = do
notFoundList <- lift $ pooledMapConcurrentlyN n (markModules sidsCacheRef) mods notFoundList <- lift $ pooledMapConcurrentlyN n (markModules sidsCacheRef) mods
forM_ (Set.fromList $ catMaybes notFoundList) $ \pid -> forM_ (Set.fromList $ catMaybes notFoundList) $ \pid ->
lift $ lift $
logError $ logWarn $
"Documentation available for package '" <> display pid <> "Documentation available for package '" <> display pid <>
"' but was not found in this snapshot: " <> "' but was not found in this snapshot: " <>
display snapName display snapName
@ -550,12 +550,6 @@ updateSnapshot ::
-> RIO StackageCron (ResourceT (RIO StackageCron) ()) -> RIO StackageCron (ResourceT (RIO StackageCron) ())
updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..} = do updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..} = do
insertSnapshotName snapshotId snapName insertSnapshotName snapshotId snapName
case Map.lookup sfCompiler corePackageGetters of
Nothing -> logError $ "Hints are not found for the compiler: " <> display sfCompiler
Just compilerCorePackages ->
forM_ compilerCorePackages $ \getCorePackageInfo -> do
(mTree, mhcid, pid, gpd) <- getCorePackageInfo
run $ addSnapshotPackage snapshotId sfCompiler Core mTree mhcid False mempty pid gpd
loadedPackageCountRef <- newIORef (0 :: Int) loadedPackageCountRef <- newIORef (0 :: Int)
let totalPackages = length sfPackages let totalPackages = length sfPackages
addPantryPackageWithReport pp = do addPantryPackageWithReport pp = do
@ -578,6 +572,7 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..
let timeTotal = round (diffUTCTime after before) let timeTotal = round (diffUTCTime after before)
(mins, secs) = timeTotal `quotRem` (60 :: Int) (mins, secs) = timeTotal `quotRem` (60 :: Int)
packagePerSecond = fromIntegral ((totalPackages * 100) `div` timeTotal) / 100 :: Float packagePerSecond = fromIntegral ((totalPackages * 100) `div` timeTotal) / 100 :: Float
allPantryUpdatesSucceeded = and pantryUpdatesSucceeded
logInfo $ logInfo $
mconcat mconcat
[ "Loading snapshot '" [ "Loading snapshot '"
@ -590,6 +585,21 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..
, displayShow packagePerSecond , displayShow packagePerSecond
, " packages/sec. There are still docs." , " packages/sec. There are still docs."
] ]
case Map.lookup sfCompiler corePackageGetters of
Nothing -> logError $ "Hints are not found for the compiler: " <> display sfCompiler
Just _
| not allPantryUpdatesSucceeded ->
logWarn $
mconcat
[ "There was an issue loading a snapshot '"
, display snapName
, "', deferring addition of packages "
, "from global-hints until next time."
]
Just compilerCorePackages ->
forM_ compilerCorePackages $ \getCorePackageInfo -> do
(mTree, mhcid, pid, gpd) <- getCorePackageInfo
run $ addSnapshotPackage snapshotId sfCompiler Core mTree mhcid False mempty pid gpd
return $ do return $ do
checkForDocsSucceeded <- checkForDocsSucceeded <-
tryAny (checkForDocs snapshotId snapName) >>= \case tryAny (checkForDocs snapshotId snapName) >>= \case
@ -597,7 +607,8 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..
logError $ "Received exception while getting the docs: " <> displayShow exc logError $ "Received exception while getting the docs: " <> displayShow exc
return False return False
Right () -> return True Right () -> return True
if and pantryUpdatesSucceeded && checkForDocsSucceeded if allPantryUpdatesSucceeded &&
checkForDocsSucceeded && Map.member sfCompiler corePackageGetters
then do then do
lift $ snapshotMarkUpdated snapshotId updatedOn lift $ snapshotMarkUpdated snapshotId updatedOn
logInfo $ "Created or updated snapshot '" <> display snapName <> "' successfully" logInfo $ "Created or updated snapshot '" <> display snapName <> "' successfully"

View File

@ -656,7 +656,7 @@ getForwardDeps spi mlimit =
where_ $ where_ $
(user ^. DepUser ==. val (spiSnapshotPackageId spi)) &&. (user ^. DepUser ==. val (spiSnapshotPackageId spi)) &&.
(uses ^. SnapshotPackageSnapshot ==. val (spiSnapshotId spi)) (uses ^. SnapshotPackageSnapshot ==. val (spiSnapshotId spi))
orderBy [desc (pn ^. PackageNameName)] orderBy [asc (pn ^. PackageNameName)]
maybe (pure ()) (limit . fromIntegral) mlimit maybe (pure ()) (limit . fromIntegral) mlimit
pure pure
( pn ^. PackageNameName ( pn ^. PackageNameName
@ -704,7 +704,7 @@ getReverseDeps spi mlimit =
where_ $ where_ $
(curPn ^. PackageNameName ==. val (spiPackageName spi)) &&. (curPn ^. PackageNameName ==. val (spiPackageName spi)) &&.
(sp ^. SnapshotPackageSnapshot ==. val (spiSnapshotId spi)) (sp ^. SnapshotPackageSnapshot ==. val (spiSnapshotId spi))
orderBy [desc (pn ^. PackageNameName)] orderBy [asc (pn ^. PackageNameName)]
maybe (pure ()) (limit . fromIntegral) mlimit maybe (pure ()) (limit . fromIntegral) mlimit
pure pure
( pn ^. PackageNameName ( pn ^. PackageNameName
@ -792,7 +792,6 @@ addSnapshotPackage ::
-> ReaderT SqlBackend (RIO env) () -> ReaderT SqlBackend (RIO env) ()
addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden flags pid gpd = do addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden flags pid gpd = do
let PackageIdentifierP pname pver = pid let PackageIdentifierP pname pver = pid
keyInsertBy = fmap (either entityKey id) . P.insertBy
mTreeId = entityKey <$> mTree mTreeId = entityKey <$> mTree
packageNameId <- packageNameId <-
maybe (getPackageNameId (unPackageNameP pname)) (pure . treeName . entityVal) mTree maybe (getPackageNameId (unPackageNameP pname)) (pure . treeName . entityVal) mTree
@ -816,10 +815,23 @@ addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden fla
, snapshotPackageIsHidden = isHidden , snapshotPackageIsHidden = isHidden
, snapshotPackageFlags = flags , snapshotPackageFlags = flags
} }
snapshotPackageId <- keyInsertBy snapshotPackage checkForDuplicate =
-- TODO: collect all missing dependencies and make a report \case
_ <- insertDeps pid snapshotPackageId (extractDependencies compiler flags gpd) Right key -> pure $ Just key
insertSnapshotPackageModules snapshotPackageId (extractModuleNames gpd) Left entity
-- Make sure this package still comes from the same place and update
-- all the fields to newest values. Necessary for making sure global
-- hints do not overwrite hackage packages, but still allows for
-- updating package info in case of a forceful update.
| snapshotPackageOrigin (entityVal entity) == origin -> do
P.replace (entityKey entity) snapshotPackage
pure $ Just (entityKey entity)
_ -> pure Nothing
msnapshotPackageId <- checkForDuplicate =<< P.insertBy snapshotPackage
forM_ msnapshotPackageId $ \snapshotPackageId -> do
_ <- insertDeps pid snapshotPackageId (extractDependencies compiler flags gpd)
-- TODO: collect all missing dependencies and make a report
insertSnapshotPackageModules snapshotPackageId (extractModuleNames gpd)
getContentTreeEntryId :: getContentTreeEntryId ::
TreeId TreeId