Skip to content

Commit

Permalink
WIP: Add precedence fields to DB pool certificate tables.
Browse files Browse the repository at this point in the history
  • Loading branch information
@jonathanknowles
jonathanknowles committed Jul 3, 2020
1 parent d8cac3e commit 7c82265
Show file tree
Hide file tree
Showing 9 changed files with 122 additions and 69 deletions.
11 changes: 7 additions & 4 deletions lib/core/src/Cardano/Pool/DB.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@ import Cardano.Wallet.Primitive.Types
, PoolId
, PoolRegistrationCertificate
, PoolRetirementCertificate
, Precedence
, SlotId (..)
, StakePoolMetadata
, StakePoolMetadataHash
Expand Down Expand Up @@ -101,7 +102,7 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
-- This is useful for the @NetworkLayer@ to know how far we have synced.

, putPoolRegistration
:: SlotId
:: SlotPrecedence
-> PoolRegistrationCertificate
-> stm ()
-- ^ Add a mapping between stake pools and their corresponding
Expand All @@ -110,18 +111,18 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer

, readPoolRegistration
:: PoolId
-> stm (Maybe PoolRegistrationCertificate)
-> stm (Maybe (SlotPrecedence, PoolRegistrationCertificate))
-- ^ Find a registration certificate associated to a given pool

, putPoolRetirement
:: SlotId
:: SlotPrecedence
-> PoolRetirementCertificate
-> stm ()
-- ^ Add a retirement certificate for a particular pool.

, readPoolRetirement
:: PoolId
-> stm (Maybe PoolRetirementCertificate)
-> stm (Maybe (SlotPrecedence, PoolRetirementCertificate))
-- ^ Find a retirement certificate for a particular pool.

, unfetchedPoolMetadataRefs
Expand Down Expand Up @@ -178,6 +179,8 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
-- For a Sqlite DB, this would be "run a query inside a transaction".
}

type SlotPrecedence = (SlotId, Precedence)

-- | Forbidden operation was executed on an already existing slot
newtype ErrPointAlreadyExists
= ErrPointAlreadyExists BlockHeader -- Point already exists in db
Expand Down
58 changes: 40 additions & 18 deletions lib/core/src/Cardano/Pool/DB/Model.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,11 +60,14 @@ import Cardano.Wallet.Primitive.Types
, PoolOwner (..)
, PoolRegistrationCertificate (..)
, PoolRetirementCertificate (..)
, Precedence (..)
, SlotId (..)
, StakePoolMetadata
, StakePoolMetadataHash
, StakePoolMetadataUrl
)
import Data.Bifunctor
( first )
import Data.Foldable
( fold )
import Data.Map.Strict
Expand All @@ -88,6 +91,8 @@ import qualified Data.Set as Set
Model Database Types
-------------------------------------------------------------------------------}

type SlotPrecedence = (SlotId, Precedence)

data PoolDatabase = PoolDatabase
{ pools :: !(Map PoolId [BlockHeader])
-- ^ Information of what blocks were produced by which stake pools
Expand All @@ -98,10 +103,12 @@ data PoolDatabase = PoolDatabase
, owners :: !(Map PoolId [PoolOwner])
-- ^ Mapping between pool ids and owners

, registrations :: !(Map (SlotId, PoolId) PoolRegistrationCertificate)
, registrations
:: !(Map (SlotPrecedence, PoolId) PoolRegistrationCertificate)
-- ^ On-chain registrations associated with pools

, retirements :: !(Map (SlotId, PoolId) PoolRetirementCertificate)
, retirements
:: !(Map (SlotPrecedence, PoolId) PoolRetirementCertificate)
-- ^ On-chain retirements associated with pools

, metadata :: !(Map StakePoolMetadataHash StakePoolMetadata)
Expand Down Expand Up @@ -186,45 +193,58 @@ mReadStakeDistribution epoch db@PoolDatabase{distributions} =
, db
)

mPutPoolRegistration :: SlotId -> PoolRegistrationCertificate -> ModelPoolOp ()
mPutPoolRegistration sl registration db@PoolDatabase{owners,registrations} =
mPutPoolRegistration
:: SlotPrecedence
-> PoolRegistrationCertificate
-> ModelPoolOp ()
mPutPoolRegistration sp registration db =
( Right ()
, db { owners = Map.insert poolId poolOwners owners
, registrations = Map.insert (sl, poolId) registration registrations
, registrations = Map.insert (sp, poolId) registration registrations
}
)
where
PoolRegistrationCertificate { poolId , poolOwners } = registration
PoolDatabase {owners, registrations} = db
PoolRegistrationCertificate {poolId, poolOwners} = registration

mReadPoolRegistration
:: PoolId -> ModelPoolOp (Maybe PoolRegistrationCertificate)
mReadPoolRegistration poolId db@PoolDatabase{registrations} =
:: PoolId
-> ModelPoolOp (Maybe (SlotPrecedence, PoolRegistrationCertificate))
mReadPoolRegistration poolId db =
( Right
$ fmap snd
$ fmap (first fst)
$ Map.lookupMax
$ Map.filterWithKey (only poolId) registrations
, db
)
where
PoolDatabase {registrations} = db
only k (_, k') _ = k == k'

mPutPoolRetirement :: SlotId -> PoolRetirementCertificate -> ModelPoolOp ()
mPutPoolRetirement sl retirement db@PoolDatabase {retirements} =
mPutPoolRetirement
:: SlotPrecedence
-> PoolRetirementCertificate
-> ModelPoolOp ()
mPutPoolRetirement sp retirement db =
( Right ()
, db { retirements = Map.insert (sl, poolId) retirement retirements }
, db { retirements = Map.insert (sp, poolId) retirement retirements }
)
where
PoolDatabase {retirements} = db
PoolRetirementCertificate poolId _retiredIn = retirement

mReadPoolRetirement :: PoolId -> ModelPoolOp (Maybe PoolRetirementCertificate)
mReadPoolRetirement poolId db@PoolDatabase {retirements} =
mReadPoolRetirement
:: PoolId
-> ModelPoolOp (Maybe (SlotPrecedence, PoolRetirementCertificate))
mReadPoolRetirement poolId db =
( Right
$ fmap snd
$ fmap (first fst)
$ Map.lookupMax
$ Map.filterWithKey (only poolId) retirements
, db
)
where
PoolDatabase {retirements} = db
only k (_, k') _ = k == k'

mListRegisteredPools :: PoolDatabase -> ([PoolId], PoolDatabase)
Expand All @@ -239,7 +259,7 @@ mUnfetchedPoolMetadataRefs n db@PoolDatabase{registrations,metadata} =
, db
)
where
unfetched :: Map (SlotId, PoolId) PoolRegistrationCertificate
unfetched :: Map (SlotPrecedence, PoolId) PoolRegistrationCertificate
unfetched = flip Map.filter registrations $ \r ->
case poolMetadata r of
Nothing -> False
Expand Down Expand Up @@ -305,8 +325,10 @@ mRollbackTo point PoolDatabase { pools
, fetchAttempts
} =
let
registrations' = Map.mapMaybeWithKey (discardBy id . fst) registrations
retirements' = Map.mapMaybeWithKey (discardBy id . fst) retirements
registrations' =
Map.mapMaybeWithKey (discardBy id . fst . fst) registrations
retirements' =
Map.mapMaybeWithKey (discardBy id . fst . fst) retirements
owners' = Map.restrictKeys owners
$ Set.fromList
$ snd <$> Map.keys registrations'
Expand Down
66 changes: 41 additions & 25 deletions lib/core/src/Cardano/Pool/DB/Sqlite.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -200,11 +200,15 @@ newDBLayer trace fp = do
[ StakeDistributionEpoch ==. fromIntegral epoch ]
[]

, putPoolRegistration = \slotId cert -> do
, putPoolRegistration = \(slotId, precedence) cert -> do
let poolId = view #poolId cert
deleteWhere [PoolOwnerPoolId ==. poolId, PoolOwnerSlot ==. slotId]
let poolRegistrationKey = PoolRegistrationKey poolId slotId
let poolRegistrationRow = PoolRegistration poolId slotId
let poolRegistrationKey = PoolRegistrationKey
poolId slotId precedence
let poolRegistrationRow = PoolRegistration
(poolId)
(slotId)
(precedence)
(fromIntegral $ numerator
$ getPercentage $ poolMargin cert)
(fromIntegral $ denominator
Expand All @@ -219,13 +223,17 @@ newDBLayer trace fp = do

, readPoolRegistration = \poolId -> do
let filterBy = [ PoolRegistrationPoolId ==. poolId ]
let orderBy = [ Desc PoolRegistrationSlot ]
let orderBy =
[ Desc PoolRegistrationSlot
, Desc PoolRegistrationPrecedence
]
selectFirst filterBy orderBy >>= \case
Nothing -> pure Nothing
Just meta -> do
let PoolRegistration
_poolId
_point
slotId
precedence
marginNum
marginDen
poolCost_
Expand All @@ -242,40 +250,48 @@ newDBLayer trace fp = do
selectList
[ PoolOwnerPoolId ==. poolId ]
[ Desc PoolOwnerSlot, Asc PoolOwnerIndex ]
pure $ Just $ PoolRegistrationCertificate
{ poolId
, poolOwners
, poolMargin
, poolCost
, poolPledge
, poolMetadata
}

, putPoolRetirement = \slotId PoolRetirementCertificate
let cert = PoolRegistrationCertificate
{ poolId
, poolOwners
, poolMargin
, poolCost
, poolPledge
, poolMetadata
}
pure $ Just ((slotId, precedence), cert)

, putPoolRetirement = \(slotId, precedence) PoolRetirementCertificate
{ poolId
, retiredIn
} -> do
let EpochNo retirementEpoch = retiredIn
repsert (PoolRetirementKey poolId slotId) $ PoolRetirement
poolId
slotId
(fromIntegral retirementEpoch)
repsert (PoolRetirementKey poolId slotId precedence) $
PoolRetirement
poolId
slotId
precedence
(fromIntegral retirementEpoch)

, readPoolRetirement = \poolId -> do
let filterBy = [ PoolRetirementPoolId ==. poolId ]
let orderBy = [ Desc PoolRetirementSlot ]
let orderBy =
[ Desc PoolRetirementSlot
, Desc PoolRetirementPrecedence
]
selectFirst filterBy orderBy >>= \case
Nothing -> pure Nothing
Just meta -> do
let PoolRetirement
_poolId
_slotId
slotId
precedence
retirementEpoch = entityVal meta
let retiredIn = EpochNo (fromIntegral retirementEpoch)
pure $ Just $ PoolRetirementCertificate
{ poolId
, retiredIn
}
let cert = PoolRetirementCertificate
{ poolId
, retiredIn
}
pure $ Just ((slotId, precedence), cert)

, unfetchedPoolMetadataRefs = \limit -> do
let nLimit = T.pack (show limit)
Expand Down
14 changes: 7 additions & 7 deletions lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -81,31 +81,31 @@ PoolOwner sql=pool_owner
poolOwnerIndex Word8 sql=pool_owner_index

Primary poolOwnerPoolId poolOwnerSlot poolOwnerOwner poolOwnerIndex
Foreign PoolRegistration fk_registration_pool_id poolOwnerPoolId poolOwnerSlot ! ON DELETE CASCADE
Foreign PoolRetirement fk_retirement_pool_id poolOwnerPoolId poolOwnerSlot ! ON DELETE CASCADE
deriving Show Generic

-- Mapping of registration certificate to pool
PoolRegistration sql=pool_registration
poolRegistrationPoolId W.PoolId sql=pool_id
poolRegistrationSlot W.SlotId sql=slot
poolRegistrationPrecedence W.Precedence sql=precedence
poolRegistrationMarginNumerator Word64 sql=margin_numerator
poolRegistrationMarginDenominator Word64 sql=margin_denominator
poolRegistrationCost Word64 sql=cost
poolRegistrationPledge Word64 sql=pledge
poolRegistrationMetadataUrl W.StakePoolMetadataUrl Maybe sql=metadata_url
poolRegistrationMetadataHash W.StakePoolMetadataHash Maybe sql=metadata_hash

Primary poolRegistrationPoolId poolRegistrationSlot
Primary poolRegistrationPoolId poolRegistrationSlot poolRegistrationPrecedence
deriving Show Generic

-- Mapping of retirement certificates to pools
PoolRetirement sql=pool_retirement
poolRetirementPoolId W.PoolId sql=pool_id
poolRetirementSlot W.SlotId sql=slot
poolRetirementEpoch Word64 sql=epoch
poolRetirementPoolId W.PoolId sql=pool_id
poolRetirementSlot W.SlotId sql=slot
poolRetirementPrecedence W.Precedence sql=precedence
poolRetirementEpoch Word64 sql=epoch

Primary poolRetirementPoolId poolRetirementSlot
Primary poolRetirementPoolId poolRetirementSlot poolRetirementPrecedence
deriving Show Generic

-- Cached metadata after they've been fetched from a remote server.
Expand Down
5 changes: 5 additions & 0 deletions lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,6 +24,7 @@ import Cardano.Wallet.Primitive.Types
, PoolId (..)
, PoolOwner (..)
, PoolRegistrationCertificate (..)
, Precedence (..)
, SlotId (..)
, SlotNo (..)
, SlotParameters (..)
Expand Down Expand Up @@ -102,6 +103,10 @@ instance Arbitrary EpochNo where
shrink (EpochNo x) = EpochNo <$> shrink x
arbitrary = unsafeEpochNo <$> choose (0, arbitraryEpochLength)

instance Arbitrary Precedence where
arbitrary = Precedence <$> arbitrary
shrink = fmap Precedence . shrink . unPrecedence

instance Arbitrary Word31 where
arbitrary = arbitrarySizedBoundedIntegral
shrink = shrinkIntegral
Expand Down
Loading

0 comments on commit 7c82265

Please sign in to comment.