From 3b8e3adcf1ab4ed0a7c6622fb795788c809a0c53 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 15 Jun 2020 15:36:59 +0200 Subject: [PATCH 01/10] extend pool database with two new tables to store metadata one of them will be used to persist a queue of metadata to fetch, while the other is a less volatile storage where metadata gets dumped once fetched. There's in principle no need for caching or timestamps here since metadata can't be updated (hash is stored on-chain as part of the registration) which simplifies a bit the problem. --- lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs | 26 +++++++++++++++++++ .../src/Cardano/Wallet/DB/Sqlite/Types.hs | 11 ++++++++ 2 files changed, 37 insertions(+) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs index 4e6286986e5..5e616507c0b 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs @@ -22,6 +22,10 @@ import Prelude import Cardano.Wallet.DB.Sqlite.Types ( sqlSettings' ) +import Data.ByteString + ( ByteString ) +import Data.Text + ( Text ) import Data.Word ( Word32, Word64, Word8 ) import Database.Persist.Class @@ -89,4 +93,26 @@ PoolRegistration sql=pool_registration Primary poolRegistrationPoolId deriving Show Generic + +-- Temporary queue where metadata to fetch are stored. +PoolMetadataQueue sql=pool_metadata_queue + poolMetadataQueuePoolId W.PoolId sql=pool_id + poolMetadataQueueUrl Text sql=metadata_url + poolMetadataQueueHash ByteString sql=metadata_hash + + Primary poolMetadataQueuePoolId + deriving Show Generic + +-- Cached metadata after they've been fetched from a remote server. +PoolMetadata sql=pool_metadata + poolMetadataPoolId W.PoolId sql=pool_id + poolMetadataName Text sql=name + poolMetadataTicker W.StakePoolTicker sql=ticker + poolMetadataDescription Text Maybe sql=description + poolMetadataHomepage Text sql=homepage + poolMetadataPledge Word64 sql=pledge + poolMetadataOwner ByteString sql=owner + + Primary poolMetadataPoolId + deriving Show Generic |] diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs index 454bde4b814..42a87c16eb5 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs @@ -36,6 +36,7 @@ import Cardano.Wallet.Primitive.Types , PoolOwner (..) , SlotId (..) , SlotNo (..) + , StakePoolTicker , TxStatus (..) , WalletId (..) , flatSlot @@ -454,3 +455,13 @@ instance PersistField PassphraseScheme where instance PersistFieldSql PassphraseScheme where sqlType _ = sqlType (Proxy @String) + +---------------------------------------------------------------------------- +-- StakePoolTicker + +instance PersistField StakePoolTicker where + toPersistValue = toPersistValue . toText + fromPersistValue = fromPersistValueFromText + +instance PersistFieldSql StakePoolTicker where + sqlType _ = sqlType (Proxy @Text) From 815461e1ff2e75090d7afcd144da8ccdc8502d62 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 15 Jun 2020 15:53:50 +0200 Subject: [PATCH 02/10] extract pool registration certificate from blocks --- .../Cardano/Wallet/Shelley/Compatibility.hs | 66 ++++++++++++++----- 1 file changed, 49 insertions(+), 17 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 437fffdd06d..43a560efb64 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -178,6 +178,7 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map +import qualified Data.Set as Set import qualified Data.Text.Encoding as T import qualified Ouroboros.Consensus.Shelley.Ledger as O import qualified Ouroboros.Network.Block as O @@ -324,7 +325,7 @@ fromShelleyBlock genesisHash epLength blk = let O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) headerHash = blk SL.TxSeq txs' = txSeq - (txs, certs) = unzip $ map fromShelleyTx $ toList txs' + (txs, certs, _) = unzip3 $ map fromShelleyTx $ toList txs' in W.Block { header = W.BlockHeader @@ -438,23 +439,14 @@ fromPParams pp = W.ProtocolParameters -- convert it into a percentage. -- decentralizationLevelFromPParams - :: HasCallStack - => SL.PParams + :: SL.PParams -> W.DecentralizationLevel decentralizationLevelFromPParams pp = - either reportInvalidValue W.DecentralizationLevel - $ mkPercentage - $ toRational - $ SL.intervalValue + W.DecentralizationLevel $ fromUnitInterval -- We must invert the value provided: (see function comment) $ invertUnitInterval d where d = SL._d pp - reportInvalidValue = error $ mconcat - [ "decentralizationLevelFromPParams: " - , "encountered invalid decentralization parameter value: " - , show d - ] txParametersFromPParams :: SL.PParams @@ -611,19 +603,24 @@ toShelleyCoin (W.Coin c) = SL.Coin $ safeCast c safeCast = fromIntegral -- NOTE: For resolved inputs we have to pass in a dummy value of 0. -fromShelleyTx :: SL.Tx TPraosStandardCrypto -> (W.Tx, [W.DelegationCertificate]) +fromShelleyTx + :: SL.Tx TPraosStandardCrypto + -> (W.Tx, [W.DelegationCertificate], [W.PoolRegistrationCertificate]) fromShelleyTx (SL.Tx bod@(SL.TxBody ins outs certs _ _ _ _ _) _ _) = ( W.Tx (fromShelleyTxId $ SL.txid bod) (map ((,W.Coin 0) . fromShelleyTxIn) (toList ins)) (map fromShelleyTxOut (toList outs)) - , mapMaybe fromShelleyCert (toList certs) + , mapMaybe fromShelleyDelegationCert (toList certs) + , mapMaybe fromShelleyRegistrationCert (toList certs) ) -- Convert & filter Shelley certificate into delegation certificate. Returns -- 'Nothing' if certificates aren't delegation certificate. -fromShelleyCert :: SL.DCert TPraosStandardCrypto -> Maybe W.DelegationCertificate -fromShelleyCert = \case +fromShelleyDelegationCert + :: SL.DCert TPraosStandardCrypto + -> Maybe W.DelegationCertificate +fromShelleyDelegationCert = \case SL.DCertDeleg (SL.Delegate delegation) -> Just $ W.CertDelegateFull (fromStakeCredential (SL._delegator delegation)) @@ -637,6 +634,27 @@ fromShelleyCert = \case SL.DCertGenesis{} -> Nothing SL.DCertMir{} -> Nothing +-- Convert & filter Shelley certificate into delegation certificate. Returns +-- 'Nothing' if certificates aren't delegation certificate. +fromShelleyRegistrationCert + :: SL.DCert TPraosStandardCrypto + -> Maybe W.PoolRegistrationCertificate +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) + } + + SL.DCertPool (SL.RetirePool{}) -> + Nothing -- FIXME We need to acknowledge pool retirement + + SL.DCertDeleg{} -> Nothing + SL.DCertGenesis{} -> Nothing + SL.DCertMir{} -> Nothing + -- | Convert a stake credentials to a 'ChimericAccount' type. Unlike with -- Jörmungandr, the Chimeric payload doesn't represent a public key but a HASH -- of a public key. @@ -651,11 +669,25 @@ fromPoolKeyHash :: SL.KeyHash 'SL.StakePool TPraosStandardCrypto -> W.PoolId fromPoolKeyHash (SL.KeyHash h) = W.PoolId (getHash h) +fromOwnerKeyHash :: SL.KeyHash 'SL.Staking TPraosStandardCrypto -> W.PoolOwner +fromOwnerKeyHash (SL.KeyHash h) = + W.PoolOwner (getHash h) + +fromUnitInterval :: HasCallStack => SL.UnitInterval -> Percentage +fromUnitInterval x = + either bomb id . mkPercentage . toRational . SL.intervalValue $ x + where + bomb = error $ mconcat + [ "fromUnitInterval: " + , "encountered invalid parameter value: " + , show x + ] + -- NOTE: Arguably breaks naming conventions. Perhaps fromCardanoSignedTx instead toSealed :: SL.Tx TPraosStandardCrypto -> (W.Tx, W.SealedTx) toSealed tx = let - (wtx, _) = fromShelleyTx tx + (wtx, _, _) = fromShelleyTx tx sealed = W.SealedTx $ serialize' $ O.mkShelleyTx tx in (wtx, sealed) From d2708d03af6243ef6478730e566ea065354a64fb Mon Sep 17 00:00:00 2001 From: KtorZ Date: Mon, 15 Jun 2020 17:43:01 +0200 Subject: [PATCH 03/10] add logic for monitoring shelley stake pools registration certificates Still rudimentary, and doesn't keep track of metadata information _yet_ but it's coming. --- .../Cardano/Wallet/Shelley/Compatibility.hs | 55 +++++--- .../src/Cardano/Wallet/Shelley/Pools.hs | 122 +++++++++++++++++- 2 files changed, 158 insertions(+), 19 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 43a560efb64..71fc2523fa9 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -63,9 +63,10 @@ module Cardano.Wallet.Shelley.Compatibility , fromNonMyopicMemberRewards , optimumNumberOfPools - , fromBlockNo , fromShelleyBlock + , fromShelleyBlock' + , toBlockHeader , fromShelleyHash , fromPrevHash , fromChainHash @@ -316,6 +317,27 @@ toSlotNo :: W.EpochLength -> W.SlotId -> SlotNo toSlotNo epLength = SlotNo . W.flatSlot epLength +toBlockHeader + :: W.Hash "Genesis" + -> W.EpochLength + -> ShelleyBlock + -> W.BlockHeader +toBlockHeader genesisHash epLength blk = + let + O.ShelleyBlock (SL.Block (SL.BHeader header _) _) headerHash = blk + in + W.BlockHeader + { slotId = + fromSlotNo epLength $ SL.bheaderSlotNo header + , blockHeight = + fromBlockNo $ SL.bheaderBlockNo header + , headerHash = + fromShelleyHash headerHash + , parentHeaderHash = + fromPrevHash (coerce genesisHash) $ + SL.bheaderPrev header + } + fromShelleyBlock :: W.Hash "Genesis" -> W.EpochLength @@ -323,26 +345,28 @@ fromShelleyBlock -> W.Block fromShelleyBlock genesisHash epLength blk = let - O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) headerHash = blk + O.ShelleyBlock (SL.Block _ txSeq) _ = blk SL.TxSeq txs' = txSeq (txs, certs, _) = unzip3 $ map fromShelleyTx $ toList txs' in W.Block - { header = W.BlockHeader - { slotId = - fromSlotNo epLength $ SL.bheaderSlotNo header - , blockHeight = - fromBlockNo $ SL.bheaderBlockNo header - , headerHash = - fromShelleyHash headerHash - , parentHeaderHash = - fromPrevHash (coerce genesisHash) $ - SL.bheaderPrev header - } + { header = toBlockHeader genesisHash epLength blk , transactions = txs , delegations = mconcat certs } +fromShelleyBlock' + :: W.EpochLength + -> ShelleyBlock + -> (W.SlotId, [W.PoolRegistrationCertificate]) +fromShelleyBlock' epLength blk = + let + O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _ = blk + SL.TxSeq txs' = txSeq + (_, _, certs) = unzip3 $ map fromShelleyTx $ toList txs' + in + (fromSlotNo epLength $ SL.bheaderSlotNo header, mconcat certs) + fromShelleyHash :: ShelleyHash c -> W.Hash "BlockHeader" fromShelleyHash (ShelleyHash (SL.HashHeader h)) = W.Hash (getHash h) @@ -411,7 +435,7 @@ fromMaxTxSize :: Natural -> Quantity "byte" Word16 fromMaxTxSize = Quantity . fromIntegral -fromPParams :: HasCallStack => SL.PParams -> W.ProtocolParameters +fromPParams :: SL.PParams -> W.ProtocolParameters fromPParams pp = W.ProtocolParameters { decentralizationLevel = decentralizationLevelFromPParams pp @@ -464,8 +488,7 @@ txParametersFromPParams pp = W.TxParameters -- | Convert genesis data into blockchain params and an initial set of UTxO fromGenesisData - :: HasCallStack - => ShelleyGenesis TPraosStandardCrypto + :: ShelleyGenesis TPraosStandardCrypto -> (W.NetworkParameters, W.Block) fromGenesisData g = ( W.NetworkParameters diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 3482a6e8572..2df25bee4bc 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | @@ -16,22 +17,47 @@ module Cardano.Wallet.Shelley.Pools where import Prelude +import Cardano.BM.Data.Severity + ( Severity (..) ) +import Cardano.BM.Data.Tracer + ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) ) +import Cardano.Pool.DB + ( DBLayer (..) ) import Cardano.Wallet.Api.Types ( ApiT (..) ) import Cardano.Wallet.Network - ( ErrNetworkUnavailable, NetworkLayer (..) ) + ( ErrNetworkUnavailable + , FollowAction (..) + , FollowExit (..) + , FollowLog + , NetworkLayer (..) + , follow + ) import Cardano.Wallet.Primitive.Types - ( Coin (..), GenesisParameters (..), PoolId ) + ( BlockHeader + , Coin (..) + , GenesisParameters (..) + , PoolId + , PoolRegistrationCertificate + , ProtocolParameters + , SlotId + ) import Cardano.Wallet.Shelley.Compatibility - ( Shelley, toPoint ) + ( Shelley, ShelleyBlock, fromShelleyBlock', toBlockHeader, toPoint ) import Cardano.Wallet.Shelley.Network ( NodePoolLsqData (..) ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage, unsafeRunExceptT ) +import Control.Monad + ( forM_ ) import Control.Monad.IO.Class ( liftIO ) import Control.Monad.Trans.Except ( ExceptT (..), runExceptT ) +import Control.Tracer + ( Tracer, contramap, traceWith ) +import Data.List.NonEmpty + ( NonEmpty (..) ) import Data.Map ( Map ) import Data.Map.Merge.Strict @@ -42,8 +68,12 @@ import Data.Quantity ( Percentage (..), Quantity (..) ) import Data.Sort ( sortOn ) +import Data.Text.Class + ( ToText (..) ) import Data.Word ( Word64 ) +import Fmt + ( pretty ) import GHC.Generics ( Generic ) @@ -146,3 +176,89 @@ newStakePoolLayer gp nl = StakePoolLayer } mapQ f (Quantity x) = Quantity $ f x + + +-- +-- Monitoring stake pool +-- + +monitorStakePools + :: Tracer IO StakePoolLog + -> GenesisParameters + -> NetworkLayer IO t ShelleyBlock + -> DBLayer IO + -> IO () +monitorStakePools tr gp nl db@DBLayer{..} = do + cursor <- initCursor + traceWith tr $ MsgStartMonitoring cursor + follow nl (contramap MsgFollow tr) cursor forward getHeader >>= \case + FollowInterrupted -> traceWith tr MsgHaltMonitoring + FollowFailure -> traceWith tr MsgCrashMonitoring + FollowRollback point -> do + traceWith tr $ MsgRollingBackTo point + liftIO . atomically $ rollbackTo point + monitorStakePools tr gp nl db + where + GenesisParameters + { getGenesisBlockHash + , getEpochLength + , getEpochStability + } = gp + + initCursor :: IO [BlockHeader] + initCursor = atomically $ readPoolProductionCursor (max 100 k) + where k = fromIntegral $ getQuantity getEpochStability + + getHeader :: ShelleyBlock -> BlockHeader + getHeader = toBlockHeader getGenesisBlockHash getEpochLength + + forward + :: NonEmpty ShelleyBlock + -> (BlockHeader, ProtocolParameters) + -> IO (FollowAction ()) + forward blocks (_nodeTip, _pparams) = do + atomically $ forM_ blocks $ \blk -> do + -- FIXME: Also extract & store metadata information from the block + let (slot, registrations) = fromShelleyBlock' getEpochLength blk + forM_ registrations $ \pool -> do + liftIO $ traceWith tr $ MsgStakePoolRegistration pool + putPoolRegistration slot pool + pure Continue + +data StakePoolLog + = MsgFollow FollowLog + | MsgStartMonitoring [BlockHeader] + | MsgHaltMonitoring + | MsgCrashMonitoring + | MsgRollingBackTo SlotId + | MsgStakePoolRegistration PoolRegistrationCertificate + deriving (Show, Eq) + +instance HasPrivacyAnnotation StakePoolLog +instance HasSeverityAnnotation StakePoolLog where + getSeverityAnnotation = \case + MsgFollow e -> getSeverityAnnotation e + MsgStartMonitoring{} -> Info + MsgHaltMonitoring{} -> Info + MsgCrashMonitoring{} -> Error + MsgRollingBackTo{} -> Info + MsgStakePoolRegistration{} -> Info + +instance ToText StakePoolLog where + toText = \case + MsgFollow e -> + toText e + MsgStartMonitoring cursor -> mconcat + [ "Monitoring stake pools. Currently at " + , case cursor of + [] -> "genesis" + _ -> pretty (last cursor) + ] + MsgHaltMonitoring -> + "Stopping stake pool monitoring as requested." + MsgCrashMonitoring -> + "Chain follower exited with error. Worker will no longer monitor stake pools." + MsgRollingBackTo point -> + "Rolling back to " <> pretty point + MsgStakePoolRegistration pool -> + "Discovered stake pool registration: " <> pretty pool From c0efeb849620ec64fb4bf98ebadcb1f1824114d9 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 08:55:43 +0200 Subject: [PATCH 04/10] write stake pool monitoring in start-up code, with proper loggers --- lib/shelley/exe/cardano-wallet-shelley.hs | 2 + lib/shelley/src/Cardano/Wallet/Shelley.hs | 60 ++++++++++++++++++----- 2 files changed, 50 insertions(+), 12 deletions(-) diff --git a/lib/shelley/exe/cardano-wallet-shelley.hs b/lib/shelley/exe/cardano-wallet-shelley.hs index 2b8cf9eaec9..944f191b7ec 100644 --- a/lib/shelley/exe/cardano-wallet-shelley.hs +++ b/lib/shelley/exe/cardano-wallet-shelley.hs @@ -302,6 +302,8 @@ tracerSeveritiesOption = Tracers <*> traceOpt apiServerTracer (Just Info) <*> traceOpt walletEngineTracer (Just Info) <*> traceOpt walletDbTracer (Just Info) + <*> traceOpt poolsEngineTracer (Just Info) + <*> traceOpt poolsDbTracer (Just Info) <*> traceOpt ntpClientTracer (Just Info) <*> traceOpt networkTracer (Just Info) where diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index 0bd2eaeb7fb..e5b2926001b 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -100,7 +100,7 @@ import Cardano.Wallet.Primitive.Types , WalletId ) import Cardano.Wallet.Registry - ( WorkerLog (..) ) + ( WorkerLog (..), defaultWorkerAfter ) import Cardano.Wallet.Shelley.Api.Server ( server ) import Cardano.Wallet.Shelley.Compatibility @@ -108,15 +108,19 @@ import Cardano.Wallet.Shelley.Compatibility import Cardano.Wallet.Shelley.Network ( NetworkLayerLog, withNetworkLayer ) import Cardano.Wallet.Shelley.Pools - ( StakePoolLayer (..), newStakePoolLayer ) + ( StakePoolLayer (..), StakePoolLog, monitorStakePools, newStakePoolLayer ) import Cardano.Wallet.Shelley.Transaction ( newTransactionLayer ) import Cardano.Wallet.Transaction ( TransactionLayer ) import Control.Applicative ( Const (..) ) +import Control.Concurrent + ( forkFinally ) +import Control.Monad + ( void ) import Control.Tracer - ( Tracer (..), nullTracer, traceWith ) + ( Tracer (..), contramap, nullTracer, traceWith ) import Data.Function ( (&) ) import Data.Proxy @@ -144,6 +148,7 @@ import System.Exit import System.IOManager ( withIOManager ) +import qualified Cardano.Pool.DB.Sqlite as Pool import qualified Cardano.Wallet.Api.Server as Server import qualified Cardano.Wallet.DB.Sqlite as Sqlite import qualified Data.Text as T @@ -229,15 +234,16 @@ serveWallet icarusApi <- apiLayer (newTransactionLayer proxy pm el ) nl shelleyApi <- apiLayer (newTransactionLayer proxy pm el) nl let spl = newStakePoolLayer (genesisParameters np) nl - startServer - proxy - socket - randomApi - icarusApi - shelleyApi - spl - ntpClient - pure ExitSuccess + withPoolsMonitoring databaseDir (genesisParameters np) nl $ do + startServer + proxy + socket + randomApi + icarusApi + shelleyApi + spl + ntpClient + pure ExitSuccess networkDiscriminantValFromProxy :: forall n. (NetworkDiscriminantVal n) @@ -270,6 +276,20 @@ serveWallet server byron icarus shelley spl ntp Server.start settings apiServerTracer tlsConfig socket application + withPoolsMonitoring + :: Maybe FilePath + -> GenesisParameters + -> NetworkLayer IO t ShelleyBlock + -> IO a + -> IO a + withPoolsMonitoring dir gp nl action = + Pool.withDBLayer poolsDbTracer (Pool.defaultFilePath <$> dir) $ \db -> do + void $ forkFinally (monitorStakePools tr gp nl db) onExit + action + where + tr = contramap (MsgFromWorker mempty) poolsEngineTracer + onExit = defaultWorkerAfter poolsEngineTracer + apiLayer :: forall s k. ( IsOurs s Address @@ -364,6 +384,8 @@ data Tracers' f = Tracers , apiServerTracer :: f ApiLog , walletEngineTracer :: f (WorkerLog WalletId WalletLog) , walletDbTracer :: f DBLog + , poolsEngineTracer :: f (WorkerLog Text StakePoolLog) + , poolsDbTracer :: f DBLog , ntpClientTracer :: f NtpTrace , networkTracer :: f NetworkLayerLog } @@ -386,6 +408,8 @@ tracerSeverities sev = Tracers , apiServerTracer = Const sev , walletDbTracer = Const sev , walletEngineTracer = Const sev + , poolsEngineTracer = Const sev + , poolsDbTracer = Const sev , ntpClientTracer = Const sev , networkTracer = Const sev } @@ -400,6 +424,8 @@ setupTracers sev tr = Tracers , apiServerTracer = mkTrace apiServerTracer $ onoff apiServerTracer tr , walletEngineTracer = mkTrace walletEngineTracer $ onoff walletEngineTracer tr , walletDbTracer = mkTrace walletDbTracer $ onoff walletDbTracer tr + , poolsEngineTracer = mkTrace poolsEngineTracer $ onoff poolsEngineTracer tr + , poolsDbTracer = mkTrace poolsDbTracer $ onoff poolsDbTracer tr , ntpClientTracer = mkTrace ntpClientTracer $ onoff ntpClientTracer tr , networkTracer = mkTrace networkTracer $ onoff networkTracer tr } @@ -428,6 +454,8 @@ tracerLabels = Tracers , apiServerTracer = Const "api-server" , walletEngineTracer = Const "wallet-engine" , walletDbTracer = Const "wallet-db" + , poolsEngineTracer = Const "pools-engine" + , poolsDbTracer = Const "pools-db" , ntpClientTracer = Const "ntp-client" , networkTracer = Const "network" } @@ -447,6 +475,12 @@ tracerDescriptions = , ( lbl walletDbTracer , "About database operations of each wallet." ) + , ( lbl poolsEngineTracer + , "About the background worker monitoring stake pools and stake pools engine." + ) + , ( lbl poolsDbTracer + , "About database operations on stake pools." + ) , ( lbl ntpClientTracer , "About ntp-client." ) @@ -464,6 +498,8 @@ nullTracers = Tracers , apiServerTracer = nullTracer , walletEngineTracer = nullTracer , walletDbTracer = nullTracer + , poolsEngineTracer = nullTracer + , poolsDbTracer = nullTracer , ntpClientTracer = nullTracer , networkTracer = nullTracer } From 5b868b1f84fe7060f448df0ca336485ca695aded Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 10:03:39 +0200 Subject: [PATCH 05/10] destroy node's connection when they're no longer needed --- lib/byron/src/Cardano/Wallet/Byron/Network.hs | 28 ++++++++++++++----- lib/core/src/Cardano/Wallet/Network.hs | 22 +++++++++------ lib/core/test/unit/Cardano/WalletSpec.hs | 2 ++ .../src/Cardano/Wallet/Jormungandr/Network.hs | 3 ++ .../src/Cardano/Wallet/Shelley/Network.hs | 28 ++++++++++++++----- 5 files changed, 61 insertions(+), 22 deletions(-) diff --git a/lib/byron/src/Cardano/Wallet/Byron/Network.hs b/lib/byron/src/Cardano/Wallet/Byron/Network.hs index 4b30b239c55..e64f93aaaff 100644 --- a/lib/byron/src/Cardano/Wallet/Byron/Network.hs +++ b/lib/byron/src/Cardano/Wallet/Byron/Network.hs @@ -49,8 +49,10 @@ import Cardano.Wallet.Byron.Compatibility ) import Cardano.Wallet.Network ( Cursor, ErrPostTx (..), NetworkLayer (..), mapCursor ) +import Control.Concurrent + ( ThreadId ) import Control.Concurrent.Async - ( async, link ) + ( Async, async, asyncThreadId, cancel, link ) import Control.Exception ( IOException ) import Control.Monad @@ -192,6 +194,7 @@ import qualified Data.Text.Encoding as T -- | Network layer cursor for Byron. Mostly useless since the protocol itself is -- stateful and the node's keep track of the associated connection's cursor. data instance Cursor (m Byron) = Cursor + (Async ()) (Point ByronBlock) (TQueue m (ChainSyncCmd ByronBlock m)) @@ -232,6 +235,7 @@ withNetworkLayer tr np addrInfo versionData action = do { currentNodeTip = liftIO $ _currentNodeTip nodeTipVar , nextBlocks = _nextBlocks , initCursor = _initCursor + , destroyCursor = _destroyCursor , cursorSlotId = _cursorSlotId , getProtocolParameters = atomically $ readTVar protocolParamsVar , postTx = _postTx localTxSubmissionQ @@ -248,8 +252,8 @@ withNetworkLayer tr np addrInfo versionData action = do chainSyncQ <- atomically newTQueue client <- mkWalletClient gp chainSyncQ let handlers = failOnConnectionLost tr - link =<< async - (connectClient tr handlers client versionData addrInfo) + thread <- async (connectClient tr handlers client versionData addrInfo) + link thread let points = reverse $ genesisPoint : (toPoint getGenesisBlockHash getEpochLength <$> headers) let findIt = chainSyncQ `send` CmdFindIntersection points @@ -261,18 +265,22 @@ withNetworkLayer tr np addrInfo versionData action = do $ MsgIntersectionFound $ fromChainHash getGenesisBlockHash $ pointHash intersection - pure $ Cursor intersection chainSyncQ + pure $ Cursor thread intersection chainSyncQ _ -> fail $ unwords [ "initCursor: intersection not found? This can't happen" , "because we always give at least the genesis point." , "Here are the points we gave: " <> show headers ] - _nextBlocks (Cursor _ chainSyncQ) = do - let toCursor point = Cursor point chainSyncQ + _destroyCursor (Cursor thread _ _) = do + liftIO $ traceWith tr $ MsgDestroyCursor (asyncThreadId thread) + cancel thread + + _nextBlocks (Cursor thread _ chainSyncQ) = do + let toCursor point = Cursor thread point chainSyncQ liftIO $ mapCursor toCursor <$> chainSyncQ `send` CmdNextBlocks - _cursorSlotId (Cursor point _) = do + _cursorSlotId (Cursor _ point _) = do fromSlotNo getEpochLength $ fromWithOrigin (SlotNo 0) $ pointSlot point _getAccountBalance _ = @@ -572,6 +580,7 @@ data NetworkLayerLog | MsgNodeTip W.BlockHeader | MsgProtocolParameters W.ProtocolParameters | MsgLocalStateQueryError String + | MsgDestroyCursor ThreadId type HandshakeTrace = TraceSendRecv (Handshake NodeToClientVersion CBOR.Term) @@ -617,6 +626,10 @@ instance ToText NetworkLayerLog where [ "Error when querying local state parameters:" , T.pack e ] + MsgDestroyCursor threadId -> T.unwords + [ "Destroying cursor connection at" + , T.pack (show threadId) + ] instance HasPrivacyAnnotation NetworkLayerLog instance HasSeverityAnnotation NetworkLayerLog where @@ -635,3 +648,4 @@ instance HasSeverityAnnotation NetworkLayerLog where MsgNodeTip{} -> Debug MsgProtocolParameters{} -> Info MsgLocalStateQueryError{} -> Error + MsgDestroyCursor{} -> Notice diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index 666eaef7217..8e4441a4dc1 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -68,6 +68,8 @@ import Control.Retry ( RetryPolicyM, constantDelay, limitRetriesByCumulativeDelay, retrying ) import Control.Tracer ( Tracer, traceWith ) +import Data.Functor + ( ($>) ) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Quantity @@ -109,6 +111,10 @@ data NetworkLayer m target block = NetworkLayer -- ^ Creates a cursor from the given block header so that 'nextBlocks' -- can be used to fetch blocks. + , destroyCursor + :: Cursor target -> m () + -- ^ Cleanup network connection once we're done with them. + , cursorSlotId :: Cursor target -> SlotId -- ^ Get the slot corresponding to a cursor. @@ -340,18 +346,18 @@ follow nl tr cps yield header = step delay cursor where retry (e :: SomeException) = case asyncExceptionFromException e of - Just ThreadKilled -> - return FollowInterrupted - Just UserInterrupt -> - return FollowInterrupted + Just ThreadKilled -> do + destroyCursor nl cursor $> FollowInterrupted + Just UserInterrupt -> do + destroyCursor nl cursor $> FollowInterrupted Nothing | fromException e == Just AsyncCancelled -> do - return FollowInterrupted + destroyCursor nl cursor $> FollowInterrupted Just _ -> do traceWith tr $ MsgUnhandledException eT - return FollowFailure + destroyCursor nl cursor $> FollowFailure _ -> do traceWith tr $ MsgUnhandledException eT - return FollowFailure + destroyCursor nl cursor $> FollowFailure where eT = T.pack (show e) @@ -388,7 +394,7 @@ follow nl tr cps yield header = (sl, _:_) | sl == slotId (last cps) -> step delay0 cursor' (sl, _) -> - pure (FollowRollback sl) + destroyCursor nl cursor' $> FollowRollback sl where continueWith :: Cursor target -> FollowAction e -> IO FollowExit continueWith cursor' = \case diff --git a/lib/core/test/unit/Cardano/WalletSpec.hs b/lib/core/test/unit/Cardano/WalletSpec.hs index b2784d51ef6..e66cf27220e 100644 --- a/lib/core/test/unit/Cardano/WalletSpec.hs +++ b/lib/core/test/unit/Cardano/WalletSpec.hs @@ -652,6 +652,8 @@ dummyNetworkLayer = NetworkLayer error "dummyNetworkLayer: nextBlocks not implemented" , initCursor = error "dummyNetworkLayer: initCursor not implemented" + , destroyCursor = + error "dummyNetworkLayer: destroyCursor not implemented" , cursorSlotId = error "dummyNetworkLayer: cursorSlotId not implemented" , currentNodeTip = diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs index 9f1976f32cd..85d8e643f45 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs @@ -309,6 +309,9 @@ mkRawNetworkLayer np batchSize st j = NetworkLayer , initCursor = _initCursor + , destroyCursor = + const (pure ()) + , cursorSlotId = _cursorSlotId diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index 0dc08386835..7f931546738 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -67,8 +67,10 @@ import Cardano.Wallet.Shelley.Compatibility , toShelleyCoin , toStakeCredential ) +import Control.Concurrent + ( ThreadId ) import Control.Concurrent.Async - ( async, link ) + ( Async, async, asyncThreadId, cancel, link ) import Control.Exception ( IOException ) import Control.Monad @@ -214,6 +216,7 @@ import qualified Shelley.Spec.Ledger.PParams as SL -- | Network layer cursor for Shelley. Mostly useless since the protocol itself is -- stateful and the node's keep track of the associated connection's cursor. data instance Cursor (m Shelley) = Cursor + (Async ()) (Point ShelleyBlock) (TQueue m (ChainSyncCmd ShelleyBlock m)) @@ -248,6 +251,7 @@ withNetworkLayer tr np addrInfo versionData action = do { currentNodeTip = liftIO $ _currentNodeTip nodeTipVar , nextBlocks = _nextBlocks , initCursor = _initCursor + , destroyCursor = _destroyCursor , cursorSlotId = _cursorSlotId , getProtocolParameters = atomically $ readTVar protocolParamsVar , postTx = _postTx localTxSubmissionQ @@ -282,8 +286,8 @@ withNetworkLayer tr np addrInfo versionData action = do chainSyncQ <- atomically newTQueue client <- mkWalletClient gp chainSyncQ let handlers = failOnConnectionLost tr - link =<< async - (connectClient tr handlers client versionData addrInfo) + thread <- async (connectClient tr handlers client versionData addrInfo) + link thread let points = reverse $ genesisPoint : (toPoint getGenesisBlockHash getEpochLength <$> headers) let findIt = chainSyncQ `send` CmdFindIntersection points @@ -295,18 +299,22 @@ withNetworkLayer tr np addrInfo versionData action = do $ MsgIntersectionFound $ fromChainHash getGenesisBlockHash $ pointHash intersection - pure $ Cursor intersection chainSyncQ + pure $ Cursor thread intersection chainSyncQ _ -> fail $ unwords [ "initCursor: intersection not found? This can't happen" , "because we always give at least the genesis point." , "Here are the points we gave: " <> show headers ] - _nextBlocks (Cursor _ chainSyncQ) = do - let toCursor point = Cursor point chainSyncQ + _destroyCursor (Cursor thread _ _) = do + liftIO $ traceWith tr $ MsgDestroyCursor (asyncThreadId thread) + cancel thread + + _nextBlocks (Cursor thread _ chainSyncQ) = do + let toCursor point = Cursor thread point chainSyncQ liftIO $ mapCursor toCursor <$> chainSyncQ `send` CmdNextBlocks - _cursorSlotId (Cursor point _) = do + _cursorSlotId (Cursor _ point _) = do fromSlotNo getEpochLength $ fromWithOrigin (SlotNo 0) $ pointSlot point _getAccountBalance nodeTipVar queryRewardQ acct = do @@ -685,6 +693,7 @@ data NetworkLayerLog | MsgGetRewardAccountBalance W.BlockHeader W.ChimericAccount | MsgAccountDelegationAndRewards W.ChimericAccount Delegations RewardAccounts + | MsgDestroyCursor ThreadId type HandshakeTrace = TraceSendRecv (Handshake NodeToClientVersion CBOR.Term) @@ -741,6 +750,10 @@ instance ToText NetworkLayerLog where , " delegations = " <> T.pack (show delegations) , " rewards = " <> T.pack (show rewards) ] + MsgDestroyCursor threadId -> T.unwords + [ "Destroying cursor connection at" + , T.pack (show threadId) + ] instance HasPrivacyAnnotation NetworkLayerLog instance HasSeverityAnnotation NetworkLayerLog where @@ -761,3 +774,4 @@ instance HasSeverityAnnotation NetworkLayerLog where MsgLocalStateQueryError{} -> Error MsgGetRewardAccountBalance{} -> Info MsgAccountDelegationAndRewards{} -> Info + MsgDestroyCursor{} -> Notice From 65bba25a22be506e73270724c28834579ae6afd1 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 10:20:01 +0200 Subject: [PATCH 06/10] do not force rollback when the list of checkpoints is empty An empty list basically assumes that there's no checkpoint on the driver, so nothing to rollback. --- lib/core/src/Cardano/Wallet/Network.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index 8e4441a4dc1..fdd17cb2331 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -391,6 +391,8 @@ follow nl tr cps yield header = -- initiates the protocol by asking clients to rollback to the last -- known intersection. case (cursorSlotId nl cursor', cps) of + (sl, []) -> + step delay0 cursor' (sl, _:_) | sl == slotId (last cps) -> step delay0 cursor' (sl, _) -> From cb6282c046d41c5565a90ef32c58a10342b00a04 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 12:04:19 +0200 Subject: [PATCH 07/10] extract and store pool metadata references from the chain --- lib/core/src/Cardano/Pool/DB.hs | 18 ++++++++++ lib/core/src/Cardano/Pool/DB/MVar.hs | 12 +++++++ lib/core/src/Cardano/Pool/DB/Model.hs | 28 ++++++++++++++-- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 18 ++++++++++ .../src/Cardano/Wallet/Primitive/Types.hs | 9 +++++ .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 2 +- .../src/Cardano/Pool/Jormungandr/Metrics.hs | 2 +- .../Cardano/Pool/Jormungandr/MetricsSpec.hs | 2 ++ .../Cardano/Wallet/Shelley/Compatibility.hs | 33 ++++++++++++++----- .../src/Cardano/Wallet/Shelley/Network.hs | 1 + .../src/Cardano/Wallet/Shelley/Pools.hs | 7 ++-- 11 files changed, 116 insertions(+), 16 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index 74905ca7c33..db4c8123dc6 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -25,6 +25,7 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate , SlotId (..) + , StakePoolMetadataRef ) import Control.Monad.Fail ( MonadFail ) @@ -116,6 +117,23 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -- map we would get from 'readPoolProduction' because not all registered -- pools have necessarily produced any block yet! + , putPoolMetadataRef + :: PoolId + -> StakePoolMetadataRef + -> stm () + -- ^ Store references to a stake pool metadata found on chain. + + , deletePoolMetadataRef + :: PoolId + -> stm () + -- ^ Remove pool metadata references from the database. + + , peekPoolMetadataRef + :: Int + -> stm [(PoolId, StakePoolMetadataRef)] + -- ^ Peek at some pool metadata ref. Returns at most 'n' elements, where + -- 'n' is the first parameter. + , readSystemSeed :: stm StdGen -- ^ Read the seed assigned to this particular database. The seed is diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index 69923c1ff17..af34266e63d 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -24,7 +24,10 @@ import Cardano.Pool.DB.Model , PoolErr (..) , emptyPoolDatabase , mCleanPoolProduction + , mDeletePoolMetadataRef , mListRegisteredPools + , mPeekPoolMetadataRef + , mPutPoolMetadataRef , mPutPoolProduction , mPutPoolRegistration , mPutStakeDistribution @@ -84,6 +87,15 @@ newDBLayer = do , listRegisteredPools = modifyMVar db (pure . swap . mListRegisteredPools) + , putPoolMetadataRef = \a0 a1 -> + void $ alterPoolDB (const Nothing) db (mPutPoolMetadataRef a0 a1) + + , deletePoolMetadataRef = + void . alterPoolDB (const Nothing) db . mDeletePoolMetadataRef + + , peekPoolMetadataRef = \a0 -> + modifyMVar db (pure . swap . mPeekPoolMetadataRef a0) + , readSystemSeed = modifyMVar db (fmap swap . mReadSystemSeed) diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index 74d457b3cec..10034995a4d 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -41,6 +41,9 @@ module Cardano.Pool.DB.Model , mPutPoolRegistration , mReadPoolRegistration , mListRegisteredPools + , mPutPoolMetadataRef + , mDeletePoolMetadataRef + , mPeekPoolMetadataRef , mReadSystemSeed , mRollbackTo , mReadCursor @@ -55,6 +58,7 @@ import Cardano.Wallet.Primitive.Types , PoolOwner (..) , PoolRegistrationCertificate (..) , SlotId (..) + , StakePoolMetadataRef ) import Data.Foldable ( fold ) @@ -94,6 +98,9 @@ data PoolDatabase = PoolDatabase , metadata :: !(Map (SlotId, PoolId) (Percentage, Quantity "lovelace" Word64)) -- ^ On-chain metadata associated with pools + , metadataRef :: [(PoolId, StakePoolMetadataRef)] + -- ^ On-chain metadata references needed to fetch metadata + , seed :: !SystemSeed -- ^ Store an arbitrary random generator seed } deriving (Generic, Show, Eq) @@ -111,7 +118,7 @@ instance Eq SystemSeed where -- | Produces an empty model pool production database. emptyPoolDatabase :: PoolDatabase -emptyPoolDatabase = PoolDatabase mempty mempty mempty mempty NotSeededYet +emptyPoolDatabase = PoolDatabase mempty mempty mempty mempty mempty NotSeededYet {------------------------------------------------------------------------------- Model Operation Types @@ -206,6 +213,22 @@ mListRegisteredPools :: PoolDatabase -> ([PoolId], PoolDatabase) mListRegisteredPools db@PoolDatabase{metadata} = ( snd <$> Map.keys metadata, db ) +mPutPoolMetadataRef :: PoolId -> StakePoolMetadataRef -> ModelPoolOp () +mPutPoolMetadataRef pid ref db@PoolDatabase{metadataRef} = + ( Right () + , db { metadataRef = (pid, ref):metadataRef } + ) + +mDeletePoolMetadataRef :: PoolId -> ModelPoolOp () +mDeletePoolMetadataRef pid db@PoolDatabase{metadataRef} = + ( Right () + , db { metadataRef = filter ((/= pid) . fst) metadataRef } + ) + +mPeekPoolMetadataRef :: Int -> PoolDatabase -> ([(PoolId, StakePoolMetadataRef)], PoolDatabase) +mPeekPoolMetadataRef n db@PoolDatabase{metadataRef} = + ( take n metadataRef, db ) + mReadSystemSeed :: PoolDatabase -> IO (StdGen, PoolDatabase) @@ -225,7 +248,7 @@ mReadCursor k db@PoolDatabase{pools} = in (Right $ reverse $ limit $ sortDesc allHeaders, db) mRollbackTo :: SlotId -> ModelPoolOp () -mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, seed} = +mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, metadataRef, seed} = let metadata' = Map.mapMaybeWithKey (discardBy id . fst) metadata owners' = Map.restrictKeys owners @@ -238,6 +261,7 @@ mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, seed} = , distributions = Map.mapMaybeWithKey (discardBy epochNumber) distributions , owners = owners' , metadata = metadata' + , metadataRef , seed } ) diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index 4152fbfe538..f8b861ec95c 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -46,6 +46,7 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate (..) , SlotId (..) + , StakePoolMetadataRef (..) ) import Cardano.Wallet.Unsafe ( unsafeMkPercentage ) @@ -74,6 +75,7 @@ import Database.Persist.Sql , deleteWhere , insertMany_ , insert_ + , putMany , selectFirst , selectList , (<.) @@ -214,6 +216,15 @@ newDBLayer trace fp = do fmap (poolRegistrationPoolId . entityVal) <$> selectList [ ] [ Desc PoolRegistrationSlot ] + , putPoolMetadataRef = \poolId ref -> do + putMany [PoolMetadataQueue poolId (metadataURL ref) (metadataHash ref)] + + , deletePoolMetadataRef = \poolId -> do + deleteWhere [PoolMetadataQueuePoolId ==. poolId] + + , peekPoolMetadataRef = \n -> do + fmap (fromPoolMetadataQueue . entityVal) <$> selectList [] [ LimitTo n ] + , rollbackTo = \point -> do let (EpochNo epoch) = epochNumber point deleteWhere [ PoolProductionSlot >. point ] @@ -326,3 +337,10 @@ fromStakeDistribution distribution = ( stakeDistributionPoolId distribution , Quantity (stakeDistributionStake distribution) ) + + +fromPoolMetadataQueue + :: PoolMetadataQueue + -> (PoolId, StakePoolMetadataRef) +fromPoolMetadataQueue (PoolMetadataQueue poolId url hash) = + (poolId, StakePoolMetadataRef url hash) diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index e05b6477a77..38623564073 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -143,6 +143,7 @@ module Cardano.Wallet.Primitive.Types , StakeDistribution (..) , poolIdBytesLength , StakePoolMetadata (..) + , StakePoolMetadataRef (..) , StakePoolOffChainMetadata (..) , StakePoolTicker (..) , sameStakePoolMetadata @@ -583,6 +584,14 @@ data StakePool = StakePool , saturation :: Double } deriving (Show, Generic) +-- | Metadata references, in order to fetch them from a remote. +data StakePoolMetadataRef = StakePoolMetadataRef + { metadataURL :: Text + -- ^ A URL location where to find pools metadata + , metadataHash :: ByteString + -- ^ A blake2b_256 hash of the pools' metadata. For verification. + } deriving (Eq, Show, Generic) + -- | Information about a stake pool, published by a stake pool owner in the -- stake pool registry. -- diff --git a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs index a2b20792a3f..a1de8471dfb 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs @@ -33,7 +33,7 @@ import Test.Utils.Trace ( captureLogging ) spec :: Spec -spec = do +spec = describe "PATATE" $ do withDB newMemoryDBLayer $ do describe "Sqlite" properties diff --git a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs index 7e79696e683..b111728353f 100644 --- a/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs +++ b/lib/jormungandr/src/Cardano/Pool/Jormungandr/Metrics.hs @@ -169,7 +169,7 @@ data StakePoolLayer e m = StakePoolLayer -- The pool productions and stake distrubtions in the db can /never/ be from -- different forks such that it's safe for readers to access it. monitorStakePools - :: GetStakeDistribution t IO ~ GetStakeDistribution Jormungandr IO + :: (GetStakeDistribution t IO ~ GetStakeDistribution Jormungandr IO) => Tracer IO StakePoolLog -> (Block, Quantity "block" Word32) -- ^ Genesis block and 'k' diff --git a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs index 672696eaafa..41b0887f148 100644 --- a/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs +++ b/lib/jormungandr/test/unit/Cardano/Pool/Jormungandr/MetricsSpec.hs @@ -265,6 +265,8 @@ prop_trackRegistrations test = monadicIO $ do $ ErrNetworkInvalid "The test case has finished") , initCursor = pure . const (Cursor header0) + , destroyCursor = + const (pure ()) , stakeDistribution = \_ -> pure mempty , currentNodeTip = diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 71fc2523fa9..3772a1ea1a4 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -167,6 +167,8 @@ import Ouroboros.Network.NodeToClient ) import Ouroboros.Network.Point ( WithOrigin (..) ) +import Shelley.Spec.Ledger.BaseTypes + ( strictMaybeToMaybe, urlToText ) import qualified Cardano.Api as Cardano import qualified Cardano.Byron.Codec.Cbor as CBOR @@ -358,7 +360,7 @@ fromShelleyBlock genesisHash epLength blk = fromShelleyBlock' :: W.EpochLength -> ShelleyBlock - -> (W.SlotId, [W.PoolRegistrationCertificate]) + -> (W.SlotId, [(W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef)]) fromShelleyBlock' epLength blk = let O.ShelleyBlock (SL.Block (SL.BHeader header _) txSeq) _ = blk @@ -628,7 +630,10 @@ toShelleyCoin (W.Coin c) = SL.Coin $ safeCast c -- NOTE: For resolved inputs we have to pass in a dummy value of 0. fromShelleyTx :: SL.Tx TPraosStandardCrypto - -> (W.Tx, [W.DelegationCertificate], [W.PoolRegistrationCertificate]) + -> ( W.Tx + , [W.DelegationCertificate] + , [(W.PoolRegistrationCertificate, Maybe W.StakePoolMetadataRef)] + ) fromShelleyTx (SL.Tx bod@(SL.TxBody ins outs certs _ _ _ _ _) _ _) = ( W.Tx (fromShelleyTxId $ SL.txid bod) @@ -661,15 +666,18 @@ fromShelleyDelegationCert = \case -- 'Nothing' if certificates aren't delegation certificate. fromShelleyRegistrationCert :: SL.DCert TPraosStandardCrypto - -> Maybe W.PoolRegistrationCertificate + -> 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) - } + 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 @@ -678,6 +686,13 @@ fromShelleyRegistrationCert = \case SL.DCertGenesis{} -> Nothing SL.DCertMir{} -> Nothing +fromPoolMetaData :: SL.PoolMetaData -> W.StakePoolMetadataRef +fromPoolMetaData meta = + W.StakePoolMetadataRef + { W.metadataURL = urlToText (SL._poolMDUrl meta) + , W.metadataHash = SL._poolMDHash meta + } + -- | Convert a stake credentials to a 'ChimericAccount' type. Unlike with -- Jörmungandr, the Chimeric payload doesn't represent a public key but a HASH -- of a public key. diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index 7f931546738..9d3e83b5e43 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -351,6 +351,7 @@ withNetworkLayer tr np addrInfo versionData action = do handleQueryFailure = withExceptT (\e -> ErrNetworkUnreachable $ T.pack $ "Unexpected" ++ show e) . ExceptT + _stakeDistribution queue pt coin = do stakeMap <- fromPoolDistr <$> handleQueryFailure (queue `send` CmdQueryLocalState pt OC.GetStakeDistribution) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 2df25bee4bc..1e86ec231e7 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} @@ -38,7 +39,7 @@ import Cardano.Wallet.Primitive.Types , Coin (..) , GenesisParameters (..) , PoolId - , PoolRegistrationCertificate + , PoolRegistrationCertificate (..) , ProtocolParameters , SlotId ) @@ -218,11 +219,11 @@ monitorStakePools tr gp nl db@DBLayer{..} = do -> IO (FollowAction ()) forward blocks (_nodeTip, _pparams) = do atomically $ forM_ blocks $ \blk -> do - -- FIXME: Also extract & store metadata information from the block let (slot, registrations) = fromShelleyBlock' getEpochLength blk - forM_ registrations $ \pool -> do + forM_ registrations $ \(pool, metadata) -> do liftIO $ traceWith tr $ MsgStakePoolRegistration pool putPoolRegistration slot pool + maybe (pure ()) (putPoolMetadataRef (poolId pool)) metadata pure Continue data StakePoolLog From 565343b0bbf4b72f04c59223c84a6aba46b91c23 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 14:55:14 +0200 Subject: [PATCH 08/10] add basic property tests for checking new pool db functions. --- lib/core/src/Cardano/Pool/DB.hs | 2 +- lib/core/src/Cardano/Pool/DB/MVar.hs | 6 +-- lib/core/src/Cardano/Pool/DB/Model.hs | 6 +-- lib/core/src/Cardano/Pool/DB/Sqlite.hs | 4 +- .../src/Cardano/Wallet/Primitive/Types.hs | 2 +- .../test/unit/Cardano/Pool/DB/Arbitrary.hs | 13 +++++ .../test/unit/Cardano/Pool/DB/Properties.hs | 52 ++++++++++++++++++- .../test/unit/Cardano/Pool/DB/SqliteSpec.hs | 2 +- .../Wallet/Primitive/AddressDerivationSpec.hs | 2 +- 9 files changed, 77 insertions(+), 12 deletions(-) diff --git a/lib/core/src/Cardano/Pool/DB.hs b/lib/core/src/Cardano/Pool/DB.hs index db4c8123dc6..19351685410 100644 --- a/lib/core/src/Cardano/Pool/DB.hs +++ b/lib/core/src/Cardano/Pool/DB.hs @@ -128,7 +128,7 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer -> stm () -- ^ Remove pool metadata references from the database. - , peekPoolMetadataRef + , readPoolMetadataRef :: Int -> stm [(PoolId, StakePoolMetadataRef)] -- ^ Peek at some pool metadata ref. Returns at most 'n' elements, where diff --git a/lib/core/src/Cardano/Pool/DB/MVar.hs b/lib/core/src/Cardano/Pool/DB/MVar.hs index af34266e63d..f580fcf834f 100644 --- a/lib/core/src/Cardano/Pool/DB/MVar.hs +++ b/lib/core/src/Cardano/Pool/DB/MVar.hs @@ -26,12 +26,12 @@ import Cardano.Pool.DB.Model , mCleanPoolProduction , mDeletePoolMetadataRef , mListRegisteredPools - , mPeekPoolMetadataRef , mPutPoolMetadataRef , mPutPoolProduction , mPutPoolRegistration , mPutStakeDistribution , mReadCursor + , mReadPoolMetadataRef , mReadPoolProduction , mReadPoolRegistration , mReadStakeDistribution @@ -93,8 +93,8 @@ newDBLayer = do , deletePoolMetadataRef = void . alterPoolDB (const Nothing) db . mDeletePoolMetadataRef - , peekPoolMetadataRef = \a0 -> - modifyMVar db (pure . swap . mPeekPoolMetadataRef a0) + , readPoolMetadataRef = \a0 -> + modifyMVar db (pure . swap . mReadPoolMetadataRef a0) , readSystemSeed = modifyMVar db (fmap swap . mReadSystemSeed) diff --git a/lib/core/src/Cardano/Pool/DB/Model.hs b/lib/core/src/Cardano/Pool/DB/Model.hs index 10034995a4d..21f5e5c64da 100644 --- a/lib/core/src/Cardano/Pool/DB/Model.hs +++ b/lib/core/src/Cardano/Pool/DB/Model.hs @@ -43,7 +43,7 @@ module Cardano.Pool.DB.Model , mListRegisteredPools , mPutPoolMetadataRef , mDeletePoolMetadataRef - , mPeekPoolMetadataRef + , mReadPoolMetadataRef , mReadSystemSeed , mRollbackTo , mReadCursor @@ -225,8 +225,8 @@ mDeletePoolMetadataRef pid db@PoolDatabase{metadataRef} = , db { metadataRef = filter ((/= pid) . fst) metadataRef } ) -mPeekPoolMetadataRef :: Int -> PoolDatabase -> ([(PoolId, StakePoolMetadataRef)], PoolDatabase) -mPeekPoolMetadataRef n db@PoolDatabase{metadataRef} = +mReadPoolMetadataRef :: Int -> PoolDatabase -> ([(PoolId, StakePoolMetadataRef)], PoolDatabase) +mReadPoolMetadataRef n db@PoolDatabase{metadataRef} = ( take n metadataRef, db ) mReadSystemSeed diff --git a/lib/core/src/Cardano/Pool/DB/Sqlite.hs b/lib/core/src/Cardano/Pool/DB/Sqlite.hs index f8b861ec95c..e70a2b655be 100644 --- a/lib/core/src/Cardano/Pool/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Pool/DB/Sqlite.hs @@ -222,7 +222,7 @@ newDBLayer trace fp = do , deletePoolMetadataRef = \poolId -> do deleteWhere [PoolMetadataQueuePoolId ==. poolId] - , peekPoolMetadataRef = \n -> do + , readPoolMetadataRef = \n -> do fmap (fromPoolMetadataQueue . entityVal) <$> selectList [] [ LimitTo n ] , rollbackTo = \point -> do @@ -251,6 +251,8 @@ newDBLayer trace fp = do deleteWhere ([] :: [Filter PoolOwner]) deleteWhere ([] :: [Filter PoolRegistration]) deleteWhere ([] :: [Filter StakeDistribution]) + deleteWhere ([] :: [Filter PoolMetadata]) + deleteWhere ([] :: [Filter PoolMetadataQueue]) , atomically = runQuery }) diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index 38623564073..f2885177c67 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -590,7 +590,7 @@ data StakePoolMetadataRef = StakePoolMetadataRef -- ^ A URL location where to find pools metadata , metadataHash :: ByteString -- ^ A blake2b_256 hash of the pools' metadata. For verification. - } deriving (Eq, Show, Generic) + } deriving (Eq, Ord, Show, Generic) -- | Information about a stake pool, published by a stake pool owner in the -- stake pool registry. diff --git a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs index 97a8c4c55e2..e549aab2c32 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Arbitrary.hs @@ -26,6 +26,7 @@ import Cardano.Wallet.Primitive.Types , SlotId (..) , SlotNo (..) , SlotParameters (..) + , StakePoolMetadataRef (..) , slotSucc , unsafeEpochNo ) @@ -58,6 +59,7 @@ import Test.QuickCheck , vector ) +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import qualified Data.List as L @@ -170,3 +172,14 @@ instance Arbitrary StakePoolsFixture where appendPair pools pairs slot = do pool <- elements pools return $ (pool,slot):pairs + +instance Arbitrary StakePoolMetadataRef where + arbitrary = StakePoolMetadataRef <$> genURL <*> genHash + where + genHash = BS.pack <$> vector 32 + genURL = do + protocol <- elements [ "http", "https" ] + fstP <- elements [ "cardano", "ada", "pool", "staking", "reward" ] + sndP <- elements [ "rocks", "moon", "digital", "server", "fast" ] + extP <- elements [ ".io", ".dev", ".com", ".eu" ] + pure $ protocol <> "://" <> fstP <> "-" <> sndP <> extP diff --git a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs index e3f3fa9770a..36adf862863 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/Properties.hs @@ -27,6 +27,7 @@ import Cardano.Wallet.Primitive.Types , PoolId , PoolRegistrationCertificate (..) , SlotId (..) + , StakePoolMetadataRef ) import Cardano.Wallet.Unsafe ( unsafeRunExceptT ) @@ -70,7 +71,13 @@ import Test.Hspec , shouldReturn ) import Test.QuickCheck - ( Positive (..), Property, classify, counterexample, property ) + ( NonEmptyList (..) + , Positive (..) + , Property + , classify + , counterexample + , property + ) import Test.QuickCheck.Monadic ( assert, monadicIO, monitor, run ) @@ -140,6 +147,10 @@ properties = do (property . prop_listRegisteredPools) it "putPoolProduction* . readTotalProduction matches expectations" (property . prop_readTotalProduction) + it "putPoolMetadataRef . readPoolMetadataRef" + (property . prop_putReadMetadataRef) + it "propDeleteMetadataRef" + (property . prop_deleteMetadataRef) {------------------------------------------------------------------------------- Properties @@ -452,6 +463,45 @@ prop_listRegisteredPools DBLayer {..} entries = ] assert (pools == (poolId <$> reverse entries)) +prop_putReadMetadataRef + :: DBLayer IO + -> [(PoolId, StakePoolMetadataRef)] + -> Property +prop_putReadMetadataRef DBLayer{..} entries = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + prop = do + run . atomically $ mapM_ (uncurry putPoolMetadataRef) entries + refs <- run . atomically $ readPoolMetadataRef (length entries) + monitor $ counterexample $ unlines + [ "Stored " <> show (length entries) <> " entries" + , "Read " <> show (length refs) <> " entries" + , "Read from DB: " <> show refs + ] + assert (L.sort refs == L.sort entries) + +prop_deleteMetadataRef + :: DBLayer IO + -> NonEmptyList (PoolId, StakePoolMetadataRef) + -> Property +prop_deleteMetadataRef DBLayer{..} (NonEmpty entries) = + monadicIO (setup >> prop) + where + setup = run $ atomically cleanDB + prop = do + let removed = fst $ head entries + run . atomically $ mapM_ (uncurry putPoolMetadataRef) entries + run . atomically $ deletePoolMetadataRef removed + refs <- run . atomically $ readPoolMetadataRef (length entries) + monitor $ counterexample $ unlines + [ "Stored " <> show (length entries) <> " entries" + , "Read " <> show (length refs) <> " entries" + , "Removed: " <> show removed + , "Read from DB: " <> show refs + ] + assert (removed `notElem` (fst <$> refs)) + -- | successive readSystemSeed yield the exact same value prop_readSystemSeedIdempotent :: DBLayer IO diff --git a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs index a1de8471dfb..a2b20792a3f 100644 --- a/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Pool/DB/SqliteSpec.hs @@ -33,7 +33,7 @@ import Test.Utils.Trace ( captureLogging ) spec :: Spec -spec = describe "PATATE" $ do +spec = do withDB newMemoryDBLayer $ do describe "Sqlite" properties diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs index 90a60d65b62..bcda686ecc0 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/AddressDerivationSpec.hs @@ -92,7 +92,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T spec :: Spec -spec = describe "PATATE" $ do +spec = do describe "Bounded / Enum relationship" $ do it "The calls Index.succ maxBound should result in a runtime err (hard)" prop_succMaxBoundHardIx From f13f37e294f439f6eb1e7e1f296f7cc1b3a5c5b5 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 15:16:14 +0200 Subject: [PATCH 09/10] fixup follow --- lib/core/src/Cardano/Wallet/Network.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs index fdd17cb2331..0269b03414e 100644 --- a/lib/core/src/Cardano/Wallet/Network.hs +++ b/lib/core/src/Cardano/Wallet/Network.hs @@ -391,7 +391,7 @@ follow nl tr cps yield header = -- initiates the protocol by asking clients to rollback to the last -- known intersection. case (cursorSlotId nl cursor', cps) of - (sl, []) -> + (_, []) -> step delay0 cursor' (sl, _:_) | sl == slotId (last cps) -> step delay0 cursor' From ffe1b45eb97b96373217a35d4ce924e42502e887 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 16 Jun 2020 17:26:50 +0200 Subject: [PATCH 10/10] store block production in the pool monitoring worker --- .../Cardano/Wallet/Shelley/Compatibility.hs | 29 ++++++++++++------- .../src/Cardano/Wallet/Shelley/Pools.hs | 19 ++++++++++-- 2 files changed, 35 insertions(+), 13 deletions(-) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs index 3772a1ea1a4..6fb6e8a5b6e 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs @@ -62,6 +62,7 @@ module Cardano.Wallet.Shelley.Compatibility , fromPoolDistr , fromNonMyopicMemberRewards , optimumNumberOfPools + , getProducer , fromBlockNo , fromShelleyBlock @@ -340,6 +341,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 @@ -668,16 +676,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 @@ -703,7 +710,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) diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 1e86ec231e7..1978d9ce531 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs @@ -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 @@ -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 @@ -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 @@ -233,6 +242,7 @@ data StakePoolLog | MsgCrashMonitoring | MsgRollingBackTo SlotId | MsgStakePoolRegistration PoolRegistrationCertificate + | MsgErrProduction ErrPointAlreadyExists deriving (Show, Eq) instance HasPrivacyAnnotation StakePoolLog @@ -244,6 +254,7 @@ instance HasSeverityAnnotation StakePoolLog where MsgCrashMonitoring{} -> Error MsgRollingBackTo{} -> Info MsgStakePoolRegistration{} -> Info + MsgErrProduction{} -> Error instance ToText StakePoolLog where toText = \case @@ -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 + ]