mirror of
https://github.com/commercialhaskell/stackage-server.git
synced 2026-01-11 19:58:28 +01:00
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:
parent
148cc8258c
commit
05307bded8
@ -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"
|
||||||
|
|||||||
@ -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"
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user