Garbage collect delisted Pools from SMASH

X-JIRA-Ticket: ADP-478
Co-authored-by: Jonathan Knowles <[email protected]>
Co-authored-by: KtorZ <[email protected]>

lib/core/cardano-wallet-core.cabal

@@ -94,7 +94,7 @@ library
     , statistics
     , stm
     , streaming-commons
-    , string-qq
+    , string-interpolate
     , template-haskell
     , text
     , text-class

lib/core/src/Cardano/Pool/DB.hs

@@ -49,6 +49,8 @@ import Data.Map.Strict
     ( Map )
 import Data.Quantity
     ( Quantity (..) )
+import Data.Time.Clock.POSIX
+    ( POSIXTime )
 import Data.Word
     ( Word64 )
 import System.Random
@@ -211,6 +213,16 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -> stm ()
         -- ^ Remove all entries of slot ids newer than the argument
 
+    , putDelistedPools
+        :: [PoolId]
+        -> stm ()
+        -- ^ Overwrite the set of delisted pools with a completely new set.
+        -- Pools may be delisted for reasons such as non-compliance.
+
+    , readDelistedPools
+        :: stm [PoolId]
+        -- ^ Fetch the set of delisted pools.
+
     , removePools
         :: [PoolId]
         -> stm ()
@@ -249,6 +261,15 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -> stm ()
         -- ^ Modify the settings.
 
+    , readLastMetadataGC
+        :: stm (Maybe POSIXTime)
+        -- ^ Get the last metadata GC time.
+
+    , putLastMetadataGC
+        :: POSIXTime
+        -> stm ()
+        -- ^ Set the last metadata GC time.
+        --
     , cleanDB
         :: stm ()
         -- ^ Clean a database

lib/core/src/Cardano/Pool/DB/MVar.hs

@@ -30,15 +30,19 @@ import Cardano.Pool.DB.Model
     , mListPoolLifeCycleData
     , mListRegisteredPools
     , mListRetiredPools
+    , mPutDelistedPools
     , mPutFetchAttempt
     , mPutHeader
+    , mPutLastMetadataGC
     , mPutPoolMetadata
     , mPutPoolProduction
     , mPutPoolRegistration
     , mPutPoolRetirement
     , mPutSettings
     , mPutStakeDistribution
     , mReadCursor
+    , mReadDelistedPools
+    , mReadLastMetadataGC
     , mReadPoolLifeCycleStatus
     , mReadPoolMetadata
     , mReadPoolProduction
@@ -146,6 +150,12 @@ newDBLayer timeInterpreter = do
         rollbackTo =
             void . alterPoolDB (const Nothing) db . mRollbackTo timeInterpreter
 
+        putDelistedPools =
+            void . alterPoolDB (const Nothing) db . mPutDelistedPools
+
+        readDelistedPools =
+            readPoolDB db mReadDelistedPools
+
         removePools =
             void . alterPoolDB (const Nothing) db . mRemovePools
 
@@ -165,6 +175,11 @@ newDBLayer timeInterpreter = do
         putSettings =
             void . alterPoolDB (const Nothing) db . mPutSettings
 
+        readLastMetadataGC = readPoolDB db mReadLastMetadataGC
+
+        putLastMetadataGC =
+            void . alterPoolDB (const Nothing) db . mPutLastMetadataGC
+
         cleanDB =
             void $ alterPoolDB (const Nothing) db mCleanDatabase
 

lib/core/src/Cardano/Pool/DB/Model.hs

@@ -16,6 +16,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE UndecidableInstances #-}
 
+
 -- |
 -- Copyright: © 2018-2020 IOHK
 -- License: Apache-2.0
@@ -50,6 +51,7 @@ module Cardano.Pool.DB.Model
     , mPutPoolRetirement
     , mReadPoolRetirement
     , mUnfetchedPoolMetadataRefs
+    , mPutDelistedPools
     , mPutFetchAttempt
     , mPutPoolMetadata
     , mListPoolLifeCycleData
@@ -60,9 +62,12 @@ module Cardano.Pool.DB.Model
     , mRollbackTo
     , mReadCursor
     , mRemovePools
+    , mReadDelistedPools
     , mRemoveRetiredPools
     , mReadSettings
     , mPutSettings
+    , mPutLastMetadataGC
+    , mReadLastMetadataGC
     ) where
 
 import Prelude
@@ -75,16 +80,18 @@ import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
     , CertificatePublicationTime
     , EpochNo (..)
+    , InternalState (..)
     , PoolId
     , PoolLifeCycleStatus (..)
     , PoolOwner (..)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
     , Settings
     , SlotNo (..)
-    , StakePoolMetadata
+    , StakePoolMetadata (..)
     , StakePoolMetadataHash
     , StakePoolMetadataUrl
+    , defaultInternalState
     , defaultSettings
     )
 import Control.Monad.Trans.Class
@@ -109,6 +116,10 @@ import Data.Ord
     ( Down (..) )
 import Data.Quantity
     ( Quantity (..) )
+import Data.Set
+    ( Set )
+import Data.Time.Clock.POSIX
+    ( POSIXTime )
 import Data.Word
     ( Word64 )
 import GHC.Generics
@@ -143,6 +154,8 @@ data PoolDatabase = PoolDatabase
         !(Map (CertificatePublicationTime, PoolId) PoolRetirementCertificate)
     -- ^ On-chain retirements associated with pools
 
+    , delisted :: !(Set PoolId)
+
     , metadata :: !(Map StakePoolMetadataHash StakePoolMetadata)
     -- ^ Off-chain metadata cached in database
 
@@ -156,6 +169,10 @@ data PoolDatabase = PoolDatabase
     -- ^ Store headers during syncing
 
     , settings :: Settings
+
+    , internalState :: InternalState
+    -- ^ Various internal states that need to persist across
+    -- wallet restarts.
     } deriving (Generic, Show, Eq)
 
 data SystemSeed
@@ -171,9 +188,9 @@ instance Eq SystemSeed where
 
 -- | Produces an empty model pool production database.
 emptyPoolDatabase :: PoolDatabase
-emptyPoolDatabase =
-    PoolDatabase mempty mempty mempty mempty mempty mempty mempty NotSeededYet
-        mempty defaultSettings
+emptyPoolDatabase = PoolDatabase
+    mempty mempty mempty mempty mempty mempty mempty mempty NotSeededYet
+    mempty defaultSettings defaultInternalState
 
 {-------------------------------------------------------------------------------
                                   Model Operation Types
@@ -414,6 +431,12 @@ mRollbackTo ti point = do
         | point' <= getPoint point = Just v
         | otherwise = Nothing
 
+mPutDelistedPools :: [PoolId] -> ModelOp ()
+mPutDelistedPools = modify #delisted . const . Set.fromList
+
+mReadDelistedPools :: ModelOp [PoolId]
+mReadDelistedPools = Set.toList <$> get #delisted
+
 mRemovePools :: [PoolId] -> ModelOp ()
 mRemovePools poolsToRemove = do
     modify #distributions
@@ -453,6 +476,15 @@ mPutSettings
     -> ModelOp ()
 mPutSettings s = modify #settings (\_ -> s)
 
+mReadLastMetadataGC
+    :: ModelOp (Maybe POSIXTime)
+mReadLastMetadataGC = get (#internalState . #lastMetadataGC)
+
+mPutLastMetadataGC
+    :: POSIXTime
+    -> ModelOp ()
+mPutLastMetadataGC t = modify (#internalState . #lastMetadataGC) (\_ -> Just t)
+
 --------------------------------------------------------------------------------
 -- Utilities
 --------------------------------------------------------------------------------

lib/core/src/Cardano/Pool/DB/Sqlite.hs

@@ -50,6 +50,8 @@ import Cardano.Pool.DB
     ( DBLayer (..), ErrPointAlreadyExists (..), determinePoolLifeCycleStatus )
 import Cardano.Pool.DB.Log
     ( ParseFailure (..), PoolDbLog (..) )
+import Cardano.Pool.DB.Sqlite.TH hiding
+    ( BlockHeader, blockHeight )
 import Cardano.Wallet.DB.Sqlite.Types
     ( BlockId (..) )
 import Cardano.Wallet.Logging
@@ -60,7 +62,7 @@ import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
     , CertificatePublicationTime (..)
     , EpochNo (..)
-    , PoolId
+    , PoolId (..)
     , PoolLifeCycleStatus (..)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
@@ -96,8 +98,8 @@ import Data.Quantity
     ( Percentage (..), Quantity (..) )
 import Data.Ratio
     ( denominator, numerator, (%) )
-import Data.String.QQ
-    ( s )
+import Data.String.Interpolate
+    ( i )
 import Data.Text
     ( Text )
 import Data.Time.Clock
@@ -120,7 +122,9 @@ import Database.Persist.Sql
     , selectFirst
     , selectList
     , toPersistValue
+    , update
     , (<.)
+    , (=.)
     , (==.)
     , (>.)
     , (>=.)
@@ -134,9 +138,6 @@ import System.FilePath
 import System.Random
     ( newStdGen )
 
-import Cardano.Pool.DB.Sqlite.TH hiding
-    ( BlockHeader, blockHeight )
-
 import qualified Cardano.Pool.DB.Sqlite.TH as TH
 import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Data.Map.Strict as Map
@@ -393,7 +394,8 @@ newDBLayer trace fp timeInterpreter = do
                         (PoolMetadataFetchAttempts hash url retryAfter $ retryCount + 1)
 
         putPoolMetadata hash metadata = do
-            let StakePoolMetadata{ticker,name,description,homepage} = metadata
+            let StakePoolMetadata
+                    {ticker, name, description, homepage} = metadata
             repsert
                 (PoolMetadataKey hash)
                 (PoolMetadata hash name ticker description homepage)
@@ -489,6 +491,13 @@ newDBLayer trace fp timeInterpreter = do
             deleteWhere [ BlockSlot >. point ]
             -- TODO: remove dangling metadata no longer attached to a pool
 
+        putDelistedPools pools = do
+            deleteWhere ([] :: [Filter PoolDelistment])
+            insertMany_ $ fmap PoolDelistment pools
+
+        readDelistedPools =
+            fmap (delistedPoolId . entityVal) <$> selectList [] []
+
         removePools = mapM_ $ \pool -> do
             liftIO $ traceWith trace $ MsgRemovingPool pool
             deleteWhere [ PoolProductionPoolId ==. pool ]
@@ -541,16 +550,33 @@ newDBLayer trace fp timeInterpreter = do
                 (SettingsKey 1)
             . toSettings
 
+        readLastMetadataGC = do
+            -- only ever read the first row
+            result <- selectFirst
+                []
+                [Asc InternalStateId, LimitTo 1]
+            pure $ (W.lastMetadataGC . fromInternalState . entityVal) =<< result
+
+        putLastMetadataGC utc = do
+            result <- selectFirst
+                [ InternalStateId ==. (InternalStateKey 1) ]
+                [ ]
+            case result of
+                Just _ -> update (InternalStateKey 1) [ LastGCMetadata =. Just utc ]
+                Nothing -> insert_ (InternalState $ Just utc)
+
         cleanDB = do
             deleteWhere ([] :: [Filter PoolProduction])
             deleteWhere ([] :: [Filter PoolOwner])
             deleteWhere ([] :: [Filter PoolRegistration])
             deleteWhere ([] :: [Filter PoolRetirement])
+            deleteWhere ([] :: [Filter PoolDelistment])
             deleteWhere ([] :: [Filter StakeDistribution])
             deleteWhere ([] :: [Filter PoolMetadata])
             deleteWhere ([] :: [Filter PoolMetadataFetchAttempts])
             deleteWhere ([] :: [Filter TH.BlockHeader])
             deleteWhere ([] :: [Filter Settings])
+            deleteWhere ([] :: [Filter InternalState])
 
         atomically :: forall a. (SqlPersistT IO a -> IO a)
         atomically = runQuery
@@ -706,7 +732,7 @@ createView conn (DatabaseView name definition) = do
 -- This view does NOT exclude pools that have retired.
 --
 activePoolLifeCycleData :: DatabaseView
-activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [s|
+activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [i|
     SELECT
         active_pool_registrations.pool_id as pool_id,
         active_pool_retirements.retirement_epoch as retirement_epoch,
@@ -735,7 +761,7 @@ activePoolLifeCycleData = DatabaseView "active_pool_lifecycle_data" [s|
 -- This view does NOT exclude pools that have retired.
 --
 activePoolOwners :: DatabaseView
-activePoolOwners = DatabaseView "active_pool_owners" [s|
+activePoolOwners = DatabaseView "active_pool_owners" [i|
     SELECT pool_id, pool_owners FROM (
         SELECT row_number() OVER w AS r, *
         FROM (
@@ -763,7 +789,7 @@ activePoolOwners = DatabaseView "active_pool_owners" [s|
 -- This view does NOT exclude pools that have retired.
 --
 activePoolRegistrations :: DatabaseView
-activePoolRegistrations = DatabaseView "active_pool_registrations" [s|
+activePoolRegistrations = DatabaseView "active_pool_registrations" [i|
     SELECT
         pool_id,
         cost,
@@ -793,7 +819,7 @@ activePoolRegistrations = DatabaseView "active_pool_registrations" [s|
 --      certificates revoked by subsequent re-registration certificates.
 --
 activePoolRetirements :: DatabaseView
-activePoolRetirements = DatabaseView "active_pool_retirements" [s|
+activePoolRetirements = DatabaseView "active_pool_retirements" [i|
     SELECT * FROM (
         SELECT
             pool_id,
@@ -973,3 +999,7 @@ toSettings
     -> Settings
 toSettings (W.Settings pms) = Settings pms
 
+fromInternalState
+    :: InternalState
+    -> W.InternalState
+fromInternalState (InternalState utc) = W.InternalState utc