From cbfb68bdc82a96d87f9ffaff2ceb9fd3925cbdee Mon Sep 17 00:00:00 2001
From: Alexey Kuleshevich <alexey@kuleshevi.ch>
Date: Mon, 29 Jul 2019 19:36:57 +0300
Subject: [PATCH] Implemented automatic undeprecation of previously deprecated
 packages, also:

* Made sure update of deprecated is done each run, independently of Hackage update
---
 src/Stackage/Database/Cron.hs  |  6 +++---
 src/Stackage/Database/Query.hs | 11 ++++++++++-
 2 files changed, 13 insertions(+), 4 deletions(-)

diff --git a/src/Stackage/Database/Cron.hs b/src/Stackage/Database/Cron.hs
index b819390..7ea30ab 100644
--- a/src/Stackage/Database/Cron.hs
+++ b/src/Stackage/Database/Cron.hs
@@ -218,10 +218,10 @@ runStackageUpdate doNotUpload = do
     runStackageMigrations
     didUpdate <- forceUpdateHackageIndex (Just "stackage-server cron job")
     case didUpdate of
-        UpdateOccurred -> do
-            logInfo "Updated hackage index. Getting deprecated info now"
-            getHackageDeprecations >>= run . mapM_ addDeprecated
+        UpdateOccurred -> logInfo "Updated hackage index"
         NoUpdateOccurred -> logInfo "No new packages in hackage index"
+    logInfo "Getting deprecated info now"
+    getHackageDeprecations >>= setDeprecations
     corePackageGetters <- makeCorePackageGetters
     runResourceT $
         join $
diff --git a/src/Stackage/Database/Query.hs b/src/Stackage/Database/Query.hs
index 3baf17b..0b10d24 100644
--- a/src/Stackage/Database/Query.hs
+++ b/src/Stackage/Database/Query.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 module Stackage.Database.Query
     (
@@ -44,6 +45,7 @@ module Stackage.Database.Query
     -- ** Deprecations
 
     , getDeprecated
+    , setDeprecations
 
     -- * Needed for Cron Job
     -- ** Re-exports from Pantry
@@ -56,7 +58,6 @@ module Stackage.Database.Query
     , getHackageCabalByKey
     , snapshotMarkUpdated
     , insertSnapshotName
-    , addDeprecated
     , markModuleHasDocs
     , insertSnapshotPackageModules
     , insertDeps
@@ -874,6 +875,8 @@ lookupPackageNameId pname = fmap entityKey <$> getBy (UniquePackageName pname)
 lookupPackageNameById :: PackageNameId -> ReaderT SqlBackend (RIO env) (Maybe PackageNameP)
 lookupPackageNameById pnid = fmap PackageNameP <$> getPackageNameById pnid
 
+-- | Add or updates package deprecation and its "in favor" list. Returns the Id if package
+-- was found in pantry.
 addDeprecated :: HasLogFunc env => Deprecation -> ReaderT SqlBackend (RIO env) ()
 addDeprecated (Deprecation pname inFavourOfNameSet) = do
     mPackageNameId <- lookupPackageNameId pname
@@ -903,6 +906,12 @@ addDeprecated (Deprecation pname inFavourOfNameSet) = do
             logError $
             "Package name: " <> display pname <> " from deprecation list was not found in Pantry."
 
+-- | In a single transaction clear out all deprecatons and add the new ones.
+setDeprecations :: GetStackageDatabase env m => [Deprecation] -> m ()
+setDeprecations deprecations = run $ do
+  delete $ from $ \(_deprecation :: SqlExpr (Entity Deprecated)) -> pure ()
+  mapM_ addDeprecated deprecations
+
 
 getHackageCabalByRev0 ::
        PackageIdentifierP