Skip to content

Commit

Permalink
store block production in the pool monitoring worker
Browse files Browse the repository at this point in the history
  • Loading branch information
KtorZ committed Jun 16, 2020
1 parent 345de18 commit 5c84984
Show file tree
Hide file tree
Showing 2 changed files with 35 additions and 13 deletions.
29 changes: 18 additions & 11 deletions lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
Original file line number Diff line number Diff line change
Expand Up @@ -60,6 +60,7 @@ module Cardano.Wallet.Shelley.Compatibility
, fromPoolDistr
, fromNonMyopicMemberRewards
, optimumNumberOfPools
, getProducer

, fromBlockNo
, fromShelleyBlock
Expand Down Expand Up @@ -328,6 +329,13 @@ toBlockHeader genesisHash epLength blk =
SL.bheaderPrev header
}

getProducer :: ShelleyBlock -> W.PoolId
getProducer blk =
let
O.ShelleyBlock (SL.Block (SL.BHeader header _) _) _ = blk
in
fromPoolKeyHash $ SL.hashKey (SL.bheaderVk header)

fromShelleyBlock
:: W.Hash "Genesis"
-> W.EpochLength
Expand Down Expand Up @@ -656,16 +664,15 @@ fromShelleyRegistrationCert
:: SL.DCert TPraosStandardCrypto
-> Maybe (W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef)
fromShelleyRegistrationCert = \case
SL.DCertPool (SL.RegPool pp) ->
Just $
( W.PoolRegistrationCertificate
{ W.poolId = fromPoolKeyHash $ SL._poolPubKey pp
, W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp)
, W.poolMargin = fromUnitInterval (SL._poolMargin pp)
, W.poolCost = Quantity $ fromIntegral (SL._poolCost pp)
}
, fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp)
)
SL.DCertPool (SL.RegPool pp) -> Just
( W.PoolRegistrationCertificate
{ W.poolId = fromPoolKeyHash $ SL._poolPubKey pp
, W.poolOwners = fromOwnerKeyHash <$> Set.toList (SL._poolOwners pp)
, W.poolMargin = fromUnitInterval (SL._poolMargin pp)
, W.poolCost = Quantity $ fromIntegral (SL._poolCost pp)
}
, fromPoolMetaData <$> strictMaybeToMaybe (SL._poolMD pp)
)

SL.DCertPool (SL.RetirePool{}) ->
Nothing -- FIXME We need to acknowledge pool retirement
Expand All @@ -691,7 +698,7 @@ fromStakeCredential = \case
SL.KeyHashObj (SL.KeyHash h) ->
W.ChimericAccount (getHash h)

fromPoolKeyHash :: SL.KeyHash 'SL.StakePool TPraosStandardCrypto -> W.PoolId
fromPoolKeyHash :: SL.KeyHash rol TPraosStandardCrypto -> W.PoolId
fromPoolKeyHash (SL.KeyHash h) =
W.PoolId (getHash h)

Expand Down
19 changes: 17 additions & 2 deletions lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,7 @@ import Cardano.BM.Data.Severity
import Cardano.BM.Data.Tracer
( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.Pool.DB
( DBLayer (..) )
( DBLayer (..), ErrPointAlreadyExists (..) )
import Cardano.Wallet.Api.Types
( ApiT (..) )
import Cardano.Wallet.Network
Expand All @@ -44,7 +44,13 @@ import Cardano.Wallet.Primitive.Types
, SlotId
)
import Cardano.Wallet.Shelley.Compatibility
( Shelley, ShelleyBlock, fromShelleyBlock', toBlockHeader, toPoint )
( Shelley
, ShelleyBlock
, fromShelleyBlock'
, getProducer
, toBlockHeader
, toPoint
)
import Cardano.Wallet.Shelley.Network
( NodePoolLsqData (..) )
import Cardano.Wallet.Unsafe
Expand Down Expand Up @@ -220,6 +226,9 @@ monitorStakePools tr gp nl db@DBLayer{..} = do
forward blocks (_nodeTip, _pparams) = do
atomically $ forM_ blocks $ \blk -> do
let (slot, registrations) = fromShelleyBlock' getEpochLength blk
runExceptT (putPoolProduction (getHeader blk) (getProducer blk)) >>= \case
Left e -> liftIO $ traceWith tr $ MsgErrProduction e
Right () -> pure ()
forM_ registrations $ \(pool, metadata) -> do
liftIO $ traceWith tr $ MsgStakePoolRegistration pool
putPoolRegistration slot pool
Expand All @@ -233,6 +242,7 @@ data StakePoolLog
| MsgCrashMonitoring
| MsgRollingBackTo SlotId
| MsgStakePoolRegistration PoolRegistrationCertificate
| MsgErrProduction ErrPointAlreadyExists
deriving (Show, Eq)

instance HasPrivacyAnnotation StakePoolLog
Expand All @@ -244,6 +254,7 @@ instance HasSeverityAnnotation StakePoolLog where
MsgCrashMonitoring{} -> Error
MsgRollingBackTo{} -> Info
MsgStakePoolRegistration{} -> Info
MsgErrProduction{} -> Error

instance ToText StakePoolLog where
toText = \case
Expand All @@ -263,3 +274,7 @@ instance ToText StakePoolLog where
"Rolling back to " <> pretty point
MsgStakePoolRegistration pool ->
"Discovered stake pool registration: " <> pretty pool
MsgErrProduction (ErrPointAlreadyExists blk) -> mconcat
[ "Couldn't store production for given block before it conflicts "
, "with another block. Conflicting block header is: ", pretty blk
]

0 comments on commit 5c84984

Please sign in to comment.