From 05307bded80cd4204c1eaa2d740621af96e6afd0 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Sat, 6 Jul 2019 20:52:52 +0300 Subject: [PATCH] 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 --- app/stackage-server-cron.hs | 2 +- src/Stackage/Database/Cron.hs | 27 +++++++++++++++++++-------- src/Stackage/Database/Query.hs | 26 +++++++++++++++++++------- 3 files changed, 39 insertions(+), 16 deletions(-) diff --git a/app/stackage-server-cron.hs b/app/stackage-server-cron.hs index 1722ca7..aa4052f 100644 --- a/app/stackage-server-cron.hs +++ b/app/stackage-server-cron.hs @@ -67,7 +67,7 @@ optsParser = switch (long "cache-cabal-files" <> help - ("Improve performance by cached parsed cabal files" ++ + ("Improve performance by caching parsed cabal files" ++ " at expense of higher memory consumption")) where repoAccount = "commercialhaskell" diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs index ebb3aec..b819390 100644 --- a/src/Stackage/Database/Cron.hs +++ b/src/Stackage/Database/Cron.hs @@ -376,7 +376,7 @@ checkForDocs snapshotId snapName = do notFoundList <- lift $ pooledMapConcurrentlyN n (markModules sidsCacheRef) mods forM_ (Set.fromList $ catMaybes notFoundList) $ \pid -> lift $ - logError $ + logWarn $ "Documentation available for package '" <> display pid <> "' but was not found in this snapshot: " <> display snapName @@ -550,12 +550,6 @@ updateSnapshot :: -> RIO StackageCron (ResourceT (RIO StackageCron) ()) updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {..} = do 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) let totalPackages = length sfPackages addPantryPackageWithReport pp = do @@ -578,6 +572,7 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {.. let timeTotal = round (diffUTCTime after before) (mins, secs) = timeTotal `quotRem` (60 :: Int) packagePerSecond = fromIntegral ((totalPackages * 100) `div` timeTotal) / 100 :: Float + allPantryUpdatesSucceeded = and pantryUpdatesSucceeded logInfo $ mconcat [ "Loading snapshot '" @@ -590,6 +585,21 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {.. , displayShow packagePerSecond , " 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 checkForDocsSucceeded <- tryAny (checkForDocs snapshotId snapName) >>= \case @@ -597,7 +607,8 @@ updateSnapshot corePackageGetters snapshotId snapName updatedOn SnapshotFile {.. logError $ "Received exception while getting the docs: " <> displayShow exc return False Right () -> return True - if and pantryUpdatesSucceeded && checkForDocsSucceeded + if allPantryUpdatesSucceeded && + checkForDocsSucceeded && Map.member sfCompiler corePackageGetters then do lift $ snapshotMarkUpdated snapshotId updatedOn logInfo $ "Created or updated snapshot '" <> display snapName <> "' successfully" diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs index 364655b..8a86609 100644 --- a/src/Stackage/Database/Query.hs +++ b/src/Stackage/Database/Query.hs @@ -656,7 +656,7 @@ getForwardDeps spi mlimit = where_ $ (user ^. DepUser ==. val (spiSnapshotPackageId spi)) &&. (uses ^. SnapshotPackageSnapshot ==. val (spiSnapshotId spi)) - orderBy [desc (pn ^. PackageNameName)] + orderBy [asc (pn ^. PackageNameName)] maybe (pure ()) (limit . fromIntegral) mlimit pure ( pn ^. PackageNameName @@ -704,7 +704,7 @@ getReverseDeps spi mlimit = where_ $ (curPn ^. PackageNameName ==. val (spiPackageName spi)) &&. (sp ^. SnapshotPackageSnapshot ==. val (spiSnapshotId spi)) - orderBy [desc (pn ^. PackageNameName)] + orderBy [asc (pn ^. PackageNameName)] maybe (pure ()) (limit . fromIntegral) mlimit pure ( pn ^. PackageNameName @@ -792,7 +792,6 @@ addSnapshotPackage :: -> ReaderT SqlBackend (RIO env) () addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden flags pid gpd = do let PackageIdentifierP pname pver = pid - keyInsertBy = fmap (either entityKey id) . P.insertBy mTreeId = entityKey <$> mTree packageNameId <- maybe (getPackageNameId (unPackageNameP pname)) (pure . treeName . entityVal) mTree @@ -816,10 +815,23 @@ addSnapshotPackage snapshotId compiler origin mTree mHackageCabalId isHidden fla , snapshotPackageIsHidden = isHidden , snapshotPackageFlags = flags } - snapshotPackageId <- keyInsertBy snapshotPackage - -- TODO: collect all missing dependencies and make a report - _ <- insertDeps pid snapshotPackageId (extractDependencies compiler flags gpd) - insertSnapshotPackageModules snapshotPackageId (extractModuleNames gpd) + checkForDuplicate = + \case + Right key -> pure $ Just key + 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 :: TreeId