Skip to content

Commit

Permalink
Add delistPools to Pool DBLayer
Browse files Browse the repository at this point in the history
This is the first step for garbage collecting
stake pools based on SMASH delisting.

X-JIRA-Ticket: ADP-478
  • Loading branch information
Julian Ospald committed Oct 15, 2020
1 parent 77e04fc commit 0ed2886
Show file tree
Hide file tree
Showing 12 changed files with 80 additions and 6 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -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
}
]

Expand Down
1 change: 1 addition & 0 deletions lib/core/cardano-wallet-core.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -90,6 +90,7 @@ library
, statistics
, stm
, streaming-commons
, string-interpolate
, string-qq
, template-haskell
, text
Expand Down
5 changes: 5 additions & 0 deletions lib/core/src/Cardano/Pool/DB.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()
Expand Down
4 changes: 4 additions & 0 deletions lib/core/src/Cardano/Pool/DB/MVar.hs
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@ import Cardano.Pool.DB.Model
, emptyPoolDatabase
, mCleanDatabase
, mCleanPoolMetadata
, mDelistPools
, mListHeaders
, mListPoolLifeCycleData
, mListRegisteredPools
Expand Down Expand Up @@ -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

Expand Down
12 changes: 11 additions & 1 deletion lib/core/src/Cardano/Pool/DB/Model.hs
Original file line number Diff line number Diff line change
Expand Up @@ -60,6 +60,7 @@ module Cardano.Pool.DB.Model
, mRollbackTo
, mReadCursor
, mRemovePools
, mDelistPools
, mRemoveRetiredPools
, mReadSettings
, mPutSettings
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down
50 changes: 46 additions & 4 deletions lib/core/src/Cardano/Pool/DB/Sqlite.hs
Original file line number Diff line number Diff line change
Expand Up @@ -61,7 +61,7 @@ import Cardano.Wallet.Primitive.Types
( BlockHeader (..)
, CertificatePublicationTime (..)
, EpochNo (..)
, PoolId
, PoolId (..)
, PoolLifeCycleStatus (..)
, PoolRegistrationCertificate (..)
, PoolRetirementCertificate (..)
Expand Down Expand Up @@ -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
Expand All @@ -116,6 +118,7 @@ import Database.Persist.Sql
, fromPersistValue
, insertMany_
, insert_
, rawExecute
, rawSql
, repsert
, selectFirst
Expand All @@ -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
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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 ]
Expand Down Expand Up @@ -961,6 +1002,7 @@ fromPoolMeta meta = (poolMetadataHash meta,) $
, name = poolMetadataName meta
, description = poolMetadataDescription meta
, homepage = poolMetadataHomepage meta
, delisted = poolMetadataDelisted meta
}

fromSettings
Expand Down
1 change: 1 addition & 0 deletions lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
5 changes: 4 additions & 1 deletion lib/core/src/Cardano/Wallet/Primitive/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 }
Expand Down
1 change: 1 addition & 0 deletions lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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) <$>
Expand Down
1 change: 1 addition & 0 deletions lib/core/test/unit/Cardano/Pool/DB/Properties.hs
Original file line number Diff line number Diff line change
Expand Up @@ -964,6 +964,7 @@ prop_removePools
, name = "MOCK"
, description = Nothing
, homepage = "http://mock.pool/"
, delisted = False
}

prop_listRegisteredPools
Expand Down
1 change: 1 addition & 0 deletions lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1140,6 +1140,7 @@ instance Arbitrary StakePoolMetadata where
<*> arbitraryText 50
<*> arbitraryMaybeText 255
<*> arbitraryText 100
<*> pure False
where
arbitraryText maxLen = do
len <- choose (1, maxLen)
Expand Down
1 change: 1 addition & 0 deletions nix/.stack.nix/cardano-wallet-core.nix

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit 0ed2886

Please sign in to comment.