Merge #2249

2249: ADP-478: Garbage collect delisted stake pools from SMASH r=KtorZ a=hasufell This is the first step for garbage collecting stake pools based on SMASH delisting. X-JIRA-Ticket: ADP-478 ---- ## Questions / Considerations 1. After looking at the logic, I believe we don't have to adjust any other functions of the DBLayer such as `listRegisteredPools` or `readPoolProduction`. These can still consider all pools. Only the API layer will consider delisted pools and adjust `ApiStakePool` accordingly. 2. There's still the open question whether we want to *really* delete GCed pools via `removePools` at some point. ---- ## TODO ### Feature - [x] Add `delisted` column to metadata table and populate Pool DBLayer with functions - [x] Create new `internal_state` table and have GC thread store last sync time - [x] Add garbage collection thread querying the SMASH server for delisted pools and calling `delistPools` from DBLayer - [x] have GC thread store last sync time - [x] return last GC sync time - [x] Add `POST '{ "maintenance_action": "gc_stake_pools" }' /stake-pools` endpoint ### QA - [x] database tests - [x] check json roundtripping works - [ ] Add integration tests? We don't have SMASH server integration tests yet. Co-authored-by: Julian Ospald <[email protected]> Co-authored-by: Jonathan Knowles <[email protected]> Co-authored-by: IOHK <[email protected]> Co-authored-by: KtorZ <[email protected]>
cardano-foundation · Nov 10, 2020 · 6cdad95 · 6cdad95
2 parents 1ee823d + 6489807
commit 6cdad95
Show file tree

Hide file tree

Showing 37 changed files with 5,690 additions and 298 deletions.
diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs
@@ -142,7 +142,7 @@ spec :: forall n t.
     ) => SpecWith (Context t)
 spec = describe "SHELLEY_STAKE_POOLS" $ do
     let listPools ctx stake = request @[ApiStakePool] ctx
-            (Link.listStakePools stake) Default Empty
+                (Link.listStakePools stake) Default Empty
 
     it "STAKE_POOLS_JOIN_01 - Cannot join non-existent wallet" $ \ctx -> runResourceT $ do
         w <- emptyWallet ctx
@@ -165,7 +165,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         \Cannot join existent stakepool with wrong password" $ \ctx -> runResourceT $ do
         w <- fixtureWallet ctx
         pool:_ <- map (view #id) . snd <$> unsafeRequest
-            @[ApiStakePool] ctx (Link.listStakePools arbitraryStake) Empty
+            @[ApiStakePool]
+            ctx (Link.listStakePools arbitraryStake) Empty
         joinStakePool @n ctx pool (w, "Wrong Passphrase") >>= flip verify
             [ expectResponseCode HTTP.status403
             , expectErrorMessage errMsg403WrongPass
@@ -178,7 +179,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         dest <- emptyWallet ctx
 
         -- Join Pool
-        pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool] ctx
+        pool:_ <- map (view #id) . snd <$>
+            unsafeRequest @[ApiStakePool] ctx
             (Link.listStakePools arbitraryStake) Empty
         joinStakePool @n ctx pool (src, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
@@ -355,8 +357,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
     it "STAKE_POOLS_JOIN_02 - \
         \Cannot join already joined stake pool" $ \ctx -> runResourceT $ do
         w <- fixtureWallet ctx
-        pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
-            ctx (Link.listStakePools arbitraryStake) Empty
+        pool:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool]
+                ctx (Link.listStakePools arbitraryStake) Empty
         joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
             , expectField (#status . #getApiT) (`shouldBe` Pending)
@@ -404,8 +407,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
 
     it "STAKE_POOLS_QUIT_02 - Passphrase must be correct to quit" $ \ctx -> runResourceT $ do
         w <- fixtureWallet ctx
-        pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
-            ctx (Link.listStakePools arbitraryStake) Empty
+        pool:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool]
+                ctx (Link.listStakePools arbitraryStake) Empty
         joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
             , expectField (#status . #getApiT) (`shouldBe` Pending)
@@ -444,8 +448,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         waitForNextEpoch ctx
 
         pool1:pool2:_ <- map (view #id) . snd
-            <$> unsafeRequest @[ApiStakePool] ctx
-                (Link.listStakePools arbitraryStake) Empty
+            <$> unsafeRequest @[ApiStakePool]
+                ctx (Link.listStakePools arbitraryStake) Empty
 
         joinStakePool @n ctx pool1 (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
@@ -509,8 +513,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
 
     it "STAKE_POOLS_JOIN_04 - Rewards accumulate" $ \ctx -> runResourceT $ do
         w <- fixtureWallet ctx
-        pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
-            ctx (Link.listStakePools arbitraryStake) Empty
+        pool:_ <- map (view #id) . snd
+            <$> unsafeRequest @[ApiStakePool]
+                ctx (Link.listStakePools arbitraryStake) Empty
         -- Join a pool
         joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
             [ expectResponseCode HTTP.status202
@@ -557,8 +562,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                 } |]
 
         w <- unsafeResponse <$> postWallet ctx payload
-        pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
-            ctx (Link.listStakePools arbitraryStake) Empty
+        pool:_ <- map (view #id) . snd <$>
+            unsafeRequest @[ApiStakePool]
+                ctx (Link.listStakePools arbitraryStake) Empty
 
         eventually "wallet join a pool" $ do
             joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
@@ -685,8 +691,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         $ it "Join/quit when already joined a pool" $ \ctx -> runResourceT $ do
             w <- fixtureWallet ctx
 
-            pool1:pool2:_ <-
-                map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
+            pool1:pool2:_ <- map (view #id) . snd <$>
+                unsafeRequest @[ApiStakePool]
                     ctx (Link.listStakePools arbitraryStake) Empty
 
             liftIO $ joinStakePool @n ctx pool1 (w, fixturePassphrase) >>= flip verify
@@ -755,8 +761,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         it "STAKE_POOLS_JOIN_01x - \
             \I can join if I have just the right amount" $ \ctx -> runResourceT $ do
             w <- fixtureWalletWith @n ctx [costOfJoining ctx + depositAmt ctx]
-            pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
-                ctx (Link.listStakePools arbitraryStake) Empty
+            pool:_ <- map (view #id) . snd <$>
+                unsafeRequest @[ApiStakePool]
+                    ctx (Link.listStakePools arbitraryStake) Empty
             joinStakePool @n ctx pool (w, fixturePassphrase)>>= flip verify
                 [ expectResponseCode HTTP.status202
                 , expectField (#status . #getApiT) (`shouldBe` Pending)
@@ -766,8 +773,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         it "STAKE_POOLS_JOIN_01x - \
            \I cannot join if I have not enough fee to cover" $ \ctx -> runResourceT $ do
             w <- fixtureWalletWith @n ctx [costOfJoining ctx + depositAmt ctx - 1]
-            pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
-                ctx (Link.listStakePools arbitraryStake) Empty
+            pool:_ <- map (view #id) . snd <$>
+                unsafeRequest @[ApiStakePool]
+                    ctx (Link.listStakePools arbitraryStake) Empty
             joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
                 [ expectResponseCode HTTP.status403
                 , expectErrorMessage (errMsg403DelegationFee 1)
@@ -788,8 +796,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                     ]
             w <- fixtureWalletWith @n ctx initBalance
 
-            pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
-                ctx (Link.listStakePools arbitraryStake) Empty
+            pool:_ <- map (view #id) . snd
+                <$> unsafeRequest @[ApiStakePool]
+                    ctx (Link.listStakePools arbitraryStake) Empty
 
             joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
                 [ expectResponseCode HTTP.status202
@@ -824,8 +833,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
             let initBalance = [ costOfJoining ctx + depositAmt ctx ]
             w <- fixtureWalletWith @n ctx initBalance
 
-            pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
-                ctx (Link.listStakePools arbitraryStake) Empty
+            pool:_ <- map (view #id) . snd
+                <$> unsafeRequest @[ApiStakePool]
+                    ctx (Link.listStakePools arbitraryStake) Empty
 
             joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
                 [ expectResponseCode HTTP.status202
@@ -898,18 +908,18 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                 r <- listPools ctx arbitraryStake
                 expectResponseCode HTTP.status200 r
                 let oneMillionAda = 1_000_000_000_000
-                let pools = either (error . show) Prelude.id $ snd r
+                let pools' = either (error . show) Prelude.id $ snd r
 
                 -- To ignore the ordering of the pools, we use Set.
-                setOf pools (view #cost)
+                setOf pools' (view #cost)
                     `shouldBe` Set.singleton (Quantity 0)
 
-                setOf pools (view #margin)
+                setOf pools' (view #margin)
                     `shouldBe`
                     Set.singleton
                         (Quantity $ unsafeMkPercentage 0.1)
 
-                setOf pools (view #pledge)
+                setOf pools' (view #pledge)
                     `shouldBe`
                     Set.fromList
                         [ Quantity oneMillionAda
@@ -960,9 +970,9 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
 
                 verify r
                     [ expectListSize 3
-                    , expectField Prelude.id $ \pools -> do
+                    , expectField Prelude.id $ \pools' -> do
                         let metadataActual = Set.fromList $
-                                mapMaybe (fmap getApiT . view #metadata) pools
+                                mapMaybe (fmap getApiT . view #metadata) pools'
                         metadataActual
                             `shouldSatisfy` (`Set.isSubsetOf` metadataPossible)
                         metadataActual
@@ -971,11 +981,12 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
 
         it "contains and is sorted by non-myopic-rewards" $ \ctx -> runResourceT $ do
             eventually "eventually shows non-zero rewards" $ do
-                Right pools@[pool1,_pool2,pool3] <-
+                Right pools'@[pool1,_pool2,pool3] <-
                     snd <$> listPools ctx arbitraryStake
                 let rewards = view (#metrics . #nonMyopicMemberRewards)
-                (rewards <$> pools) `shouldBe`
-                    (rewards <$> sortOn (Down . rewards) pools)
+
+                (rewards <$> pools') `shouldBe`
+                    (rewards <$> sortOn (Down . rewards) pools')
                 -- Make sure the rewards are not all equal:
                 rewards pool1 .> rewards pool3
 
@@ -1001,7 +1012,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
         \NonMyopicMemberRewards are 0 when stake is 0" $ \ctx -> runResourceT $ do
         liftIO $ pendingWith "This assumption seems false, for some reasons..."
         let stake = Just $ Coin 0
-        r <- request @[ApiStakePool] ctx (Link.listStakePools stake)
+        r <- request @[ApiStakePool]
+            ctx (Link.listStakePools stake)
             Default Empty
         expectResponseCode HTTP.status200 r
         verify r

diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal
@@ -94,7 +94,7 @@ library
     , statistics
     , stm
     , streaming-commons
-    , string-qq
+    , string-interpolate
     , template-haskell
     , text
     , text-class

diff --git a/lib/core/src/Cardano/Pool/DB.hs b/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

diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/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