Add delistPools to Pool DBLayer

This is the first step for garbage collecting stake pools based on SMASH delisting. X-JIRA-Ticket: ADP-478
cardano-foundation · Oct 19, 2020 · 9793e1e · 9793e1e
1 parent 66df475
commit 9793e1e
Show file tree

Hide file tree

Showing 12 changed files with 80 additions and 6 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
@@ -881,24 +881,28 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                             , name = "Genesis Pool A"
                             , description = Nothing
                             , homepage = "https://iohk.io"
+                            , delisted = False
                             }
                         , StakePoolMetadata
                             { ticker = (StakePoolTicker "GPB")
                             , name = "Genesis Pool B"
                             , description = Nothing
                             , homepage = "https://iohk.io"
+                            , delisted = False
                             }
                         , StakePoolMetadata
                             { ticker = (StakePoolTicker "GPC")
                             , name = "Genesis Pool C"
                             , description = Just "Lorem Ipsum Dolor Sit Amet."
                             , homepage = "https://iohk.io"
+                            , delisted = False
                             }
                         , StakePoolMetadata
                             { ticker = (StakePoolTicker "GPD")
                             , name = "Genesis Pool D"
                             , description = Just "Lorem Ipsum Dolor Sit Amet."
                             , homepage = "https://iohk.io"
+                            , delisted = False
                             }
                         ]
 

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

diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs
@@ -211,6 +211,11 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
         -> stm ()
         -- ^ Remove all entries of slot ids newer than the argument
 
+    , delistPools
+        :: [PoolId]
+        -> stm ()
+        -- ^ Mark pools as delisted
+        --
     , removePools
         :: [PoolId]
         -> stm ()

diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs
@@ -26,6 +26,7 @@ import Cardano.Pool.DB.Model
     , emptyPoolDatabase
     , mCleanDatabase
     , mCleanPoolMetadata
+    , mDelistPools
     , mListHeaders
     , mListPoolLifeCycleData
     , mListRegisteredPools
@@ -146,6 +147,9 @@ newDBLayer timeInterpreter = do
         rollbackTo =
             void . alterPoolDB (const Nothing) db . mRollbackTo timeInterpreter
 
+        delistPools =
+            void . alterPoolDB (const Nothing) db . mDelistPools
+
         removePools =
             void . alterPoolDB (const Nothing) db . mRemovePools
 

diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs
@@ -60,6 +60,7 @@ module Cardano.Pool.DB.Model
     , mRollbackTo
     , mReadCursor
     , mRemovePools
+    , mDelistPools
     , mRemoveRetiredPools
     , mReadSettings
     , mPutSettings
@@ -82,11 +83,13 @@ import Cardano.Wallet.Primitive.Types
     , PoolRetirementCertificate (..)
     , Settings
     , SlotNo (..)
-    , StakePoolMetadata
+    , StakePoolMetadata (..)
     , StakePoolMetadataHash
     , StakePoolMetadataUrl
     , defaultSettings
     )
+import Control.Monad
+    ( forM_ )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.State.Strict
@@ -414,6 +417,13 @@ mRollbackTo ti point = do
         | point' <= getPoint point = Just v
         | otherwise = Nothing
 
+mDelistPools :: [PoolId] -> ModelOp ()
+mDelistPools poolsToDelist =
+    forM_ poolsToDelist $ \pool -> do
+        mhash <- (>>= (fmap snd . poolMetadata . snd)) <$> mReadPoolRegistration pool
+        forM_ mhash $ \hash -> modify #metadata
+            $ Map.adjust (\m -> m { delisted = True }) hash
+
 mRemovePools :: [PoolId] -> ModelOp ()
 mRemovePools poolsToRemove = do
     modify #distributions

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs
@@ -60,7 +60,7 @@ import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
     , CertificatePublicationTime (..)
     , EpochNo (..)
-    , PoolId
+    , PoolId (..)
     , PoolLifeCycleStatus (..)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
@@ -89,13 +89,15 @@ import Data.Functor
 import Data.Generics.Internal.VL.Lens
     ( view )
 import Data.List
-    ( foldl' )
+    ( foldl', intercalate )
 import Data.Map.Strict
     ( Map )
 import Data.Quantity
     ( Percentage (..), Quantity (..) )
 import Data.Ratio
     ( denominator, numerator, (%) )
+import Data.String.Interpolate
+    ( i )
 import Data.String.QQ
     ( s )
 import Data.Text
@@ -115,6 +117,7 @@ import Database.Persist.Sql
     , fromPersistValue
     , insertMany_
     , insert_
+    , rawExecute
     , rawSql
     , repsert
     , selectFirst
@@ -139,6 +142,7 @@ import Cardano.Pool.DB.Sqlite.TH hiding
 
 import qualified Cardano.Pool.DB.Sqlite.TH as TH
 import qualified Cardano.Wallet.Primitive.Types as W
+import qualified Data.ByteString.Char8 as B8
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import qualified Database.Sqlite as Sqlite
@@ -393,10 +397,10 @@ 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,delisted} = metadata
             repsert
                 (PoolMetadataKey hash)
-                (PoolMetadata hash name ticker description homepage)
+                (PoolMetadata hash name ticker description homepage delisted)
             deleteWhere [ PoolFetchAttemptsMetadataHash ==. hash ]
 
         removePoolMetadata =
@@ -488,6 +492,43 @@ newDBLayer trace fp timeInterpreter = do
             deleteWhere [ BlockSlot >. point ]
             -- TODO: remove dangling metadata no longer attached to a pool
 
+        delistPools pools =
+            -- sqlite has a max of 2k variables or so, so we don't want
+            -- 'IN #{poolList my_pools}' to blow up.
+            forM_ (listOfK 1000 pools)
+                $ \kPools -> do
+                    rawExecute
+                        (deleteQueryString kPools)
+                        []
+
+          where
+            deleteQueryString my_pools = [i|
+                UPDATE pool_metadata
+                    SET delisted = 1
+                    WHERE metadata_hash
+                    IN (
+                        SELECT metadata_hash
+                        FROM active_pool_registrations
+                        WHERE pool_id
+                        IN #{poolList my_pools}
+                       );
+            |]
+
+            poolList :: [PoolId] -> String
+            poolList pids =
+                let inner = intercalate ", "
+                        -- pool IDs are strictly ascii, Char8 is safe
+                        . fmap (\x -> "\"" ++ B8.unpack (getPoolId x) ++ "\"")
+                        $ pids
+                in "( " ++ inner ++ " )"
+
+            listOfK :: Int -> [a] -> [[a]]
+            listOfK k = go
+              where
+                go [] = []
+                go xs = let (l, r) = splitAt k xs
+                        in l : go r
+
         removePools = mapM_ $ \pool -> do
             liftIO $ traceWith trace $ MsgRemovingPool pool
             deleteWhere [ PoolProductionPoolId ==. pool ]
@@ -960,6 +1001,7 @@ fromPoolMeta meta = (poolMetadataHash meta,) $
         , name = poolMetadataName meta
         , description = poolMetadataDescription meta
         , homepage = poolMetadataHomepage meta
+        , delisted = poolMetadataDelisted meta
         }
 
 fromSettings

diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs
@@ -134,6 +134,7 @@ PoolMetadata sql=pool_metadata
     poolMetadataTicker                 W.StakePoolTicker       sql=ticker
     poolMetadataDescription            Text Maybe              sql=description
     poolMetadataHomepage               Text                    sql=homepage
+    poolMetadataDelisted               Bool                    sql=delisted
 
     Primary poolMetadataHash
     deriving Show Generic

diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
@@ -640,6 +640,9 @@ data StakePoolMetadata = StakePoolMetadata
     -- ^ Short description of the stake pool.
     , homepage :: Text
     -- ^ Absolute URL for the stake pool's homepage link.
+    , delisted :: Bool
+    -- ^ The pool has been delisted from the current SMASH server
+    -- (e.g. due to non-compliance). This isn't part of the JSON.
     } deriving (Eq, Ord, Show, Generic)
 
 instance FromJSON StakePoolMetadata where
@@ -655,7 +658,7 @@ instance FromJSON StakePoolMetadata where
         homepage <- obj .: "homepage"
         guard (T.length homepage <= 100)
 
-        pure $ StakePoolMetadata{ticker,name,description,homepage}
+        pure $ StakePoolMetadata{ticker,name,description,homepage,delisted=False}
 
 -- | Very short name for a stake pool.
 newtype StakePoolTicker = StakePoolTicker { unStakePoolTicker :: Text }

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
@@ -324,6 +324,7 @@ genStakePoolMetadata (StakePoolMetadataUrl url) = StakePoolMetadata
     <*> genPrintableText
     <*> oneof [ pure Nothing, Just <$> genPrintableText ]
     <*> pure url
+    <*> pure False
 
 genStakePoolTicker :: Gen StakePoolTicker
 genStakePoolTicker = (StakePoolTicker . T.pack) <$>

diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs
@@ -964,6 +964,7 @@ prop_removePools
         , name = "MOCK"
         , description = Nothing
         , homepage = "http://mock.pool/"
+        , delisted = False
         }
 
 prop_listRegisteredPools

diff --git a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs
@@ -1171,6 +1171,7 @@ instance Arbitrary StakePoolMetadata where
         <*> arbitraryText 50
         <*> arbitraryMaybeText 255
         <*> arbitraryText 100
+        <*> pure False
       where
         arbitraryText maxLen = do
             len <- choose (1, maxLen)

diff --git a/nix/.stack.nix/cardano-wallet-core.nix b/nix/.stack.nix/cardano-wallet-core.nix