From 0ed2886bdada7de8632f8ea67cbef3ad65e65a6f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 15 Oct 2020 17:41:58 +0200 Subject: [PATCH] Add `delistPools` to Pool DBLayer This is the first step for garbage collecting stake pools based on SMASH delisting. X-JIRA-Ticket: ADP-478 --- .../Scenario/API/Shelley/StakePools.hs | 4 ++ lib/core/cardano-wallet-core.cabal | 1 + lib/core/src/Cardano/Pool/DB.hs | 5 ++ lib/core/src/Cardano/Pool/DB/MVar.hs | 4 ++ lib/core/src/Cardano/Pool/DB/Model.hs | 12 ++++- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 50 +++++++++++++++++-- lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs | 1 + .../src/Cardano/Wallet/Primitive/Types.hs | 5 +- .../test/unit/Cardano/Pool/DB/Arbitrary.hs | 1 + .../test/unit/Cardano/Pool/DB/Properties.hs | 1 + .../test/unit/Cardano/Wallet/Api/TypesSpec.hs | 1 + nix/.stack.nix/cardano-wallet-core.nix | 1 + 12 files changed, 80 insertions(+), 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 index e2690ea71fd..9ca1bca31fd 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs @@ -743,24 +743,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 index 704a35fd6bc..11f642c47dc 100644 --- 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 index d6c965aa6bf..5d9d3d300f6 100644 --- 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 index a5784911a56..f40e7267bce 100644 --- 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 index 5837716455c..6d98e4746b4 100644 --- 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 index 83fb60632cf..337c64a392d 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -61,7 +61,7 @@ import Cardano.Wallet.Primitive.Types ( BlockHeader (..) , CertificatePublicationTime (..) , EpochNo (..) - , PoolId + , PoolId (..) , PoolLifeCycleStatus (..) , PoolRegistrationCertificate (..) , PoolRetirementCertificate (..) @@ -90,13 +90,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 @@ -116,6 +118,7 @@ import Database.Persist.Sql , fromPersistValue , insertMany_ , insert_ + , rawExecute , rawSql , repsert , selectFirst @@ -140,6 +143,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 @@ -394,10 +398,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 = @@ -489,6 +493,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 ] @@ -961,6 +1002,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 index a1e4a97a9b9..3f00c457629 100644 --- 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 index 1325ff90518..9c4b12d8ceb 100644 --- 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 index 0fc2a75e8d3..c501053d12e 100644 --- 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 index a7a3cfa0da1..afb1312f380 100644 --- 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 index aeaa469f6cf..617446c3ed9 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs @@ -1140,6 +1140,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 index 73a7a4a37e4..8775f982a5d 100644 --- a/nix/.stack.nix/cardano-wallet-core.nix +++ b/nix/.stack.nix/cardano-wallet-core.nix @@ -86,6 +86,7 @@ (hsPkgs."statistics" or (errorHandler.buildDepError "statistics")) (hsPkgs."stm" or (errorHandler.buildDepError "stm")) (hsPkgs."streaming-commons" or (errorHandler.buildDepError "streaming-commons")) + (hsPkgs."string-interpolate" or (errorHandler.buildDepError "string-interpolate")) (hsPkgs."string-qq" or (errorHandler.buildDepError "string-qq")) (hsPkgs."template-haskell" or (errorHandler.buildDepError "template-haskell")) (hsPkgs."text" or (errorHandler.buildDepError "text"))