From d7eb87600ade02474b45a2dd07f16ed7c05478a4 Mon Sep 17 00:00:00 2001 From: Konstantinos Lambrou-Latreille Date: Fri, 6 Oct 2023 13:51:29 -0400 Subject: [PATCH] Updated ouroboros-consensus and move client-related function out of Cardano.Node.LedgerEvent * Updated ouroboros-consensus to latest changes wrt LedgerEventHandler * Move foldEvent and filterReward functions out of Cardano.Node.LedgerEvent --- cabal.project | 4 +- cardano-node/app/reward-history.hs | 39 ++++++++-- cardano-node/cardano-node.cabal | 4 ++ cardano-node/src/Cardano/Node/LedgerEvent.hs | 75 ++++++++------------ cardano-node/src/Cardano/Node/Run.hs | 4 +- nix/haskell.nix | 1 + 6 files changed, 72 insertions(+), 55 deletions(-) diff --git a/cabal.project b/cabal.project index 8cba429400a..fbdb93a45e4 100644 --- a/cabal.project +++ b/cabal.project @@ -83,8 +83,8 @@ constraints: source-repository-package type: git location: https://github.com/CardanoSolutions/ouroboros-consensus - tag: 26cfb9666efd78692912fbdcc41e927f64f282ae - --sha256: 0p4axag77by7bwc3wnbdphpc6ib57b0di4clzcb8c0za0gf1sw46 + tag: 2fe143f6750180aac22c13d64efa5f0caabe4d89 + --sha256: 169lvgq44r1w4ldbarr1md45raf3i69sca75m65vn55l3jjz4i67 subdir: ouroboros-consensus ouroboros-consensus-cardano diff --git a/cardano-node/app/reward-history.hs b/cardano-node/app/reward-history.hs index f9f777d8176..c943ed7fd82 100644 --- a/cardano-node/app/reward-history.hs +++ b/cardano-node/app/reward-history.hs @@ -1,16 +1,24 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} import Cardano.Node.LedgerEvent ( - AnchoredEvent (AnchoredEvent), + AnchoredEvent (AnchoredEvent, ledgerEvent), LedgerEvent (LedgerNewEpochEvent), - LedgerNewEpochEvent (LedgerStakeDistEvent), - foldEvent, - parseStakeCredential, + LedgerNewEpochEvent (LedgerStakeDistEvent, LedgerTotalRewards), + foldEvent, Credential, KeyRole (Staking), StandardCrypto, EpochNo, Coin ) import Control.Exception (bracket, bracketOnError) import Network.Socket import System.Environment (getArgs) import System.IO (IOMode (ReadMode)) +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Cardano.Node.LedgerEvent as Ledger +import qualified Data.ByteString.Base16 as Hex +import qualified Data.ByteString.Char8 as B8 +import qualified Cardano.Ledger.Address as Ledger +import Data.Function ((&)) -- Usage: reward-history << -- @@ -28,7 +36,7 @@ main = do putStrLn "Getting reward history..." -- void $ foldEvent h mempty $ \st e -> let r = filterRewards stakeCredential st e in print r >> pure r -- void $ foldEvent h mempty $ \st e -> let r = filterRewards stakeCredential st e in print r >> pure r - foldEvent h () $ \() -> \case AnchoredEvent _ _ (LedgerNewEpochEvent (LedgerStakeDistEvent e)) -> print e; _otherEvent -> pure () + foldEvent h () $ \() -> \case ae@(AnchoredEvent _ _ _ _ (LedgerNewEpochEvent (LedgerStakeDistEvent _))) -> print ae; _otherEvent -> pure () where expectStakeCredential = maybe (error "invalid / missing stake address as 1st argument") return @@ -46,3 +54,24 @@ runTCPClient host port client = withSocketsDo $ do open addr = bracketOnError (openSocket addr) close $ \sock -> do connect sock $ addrAddress addr return sock + +filterRewards + :: Credential 'Staking StandardCrypto + -> Map EpochNo Coin + -> AnchoredEvent + -> Map EpochNo Coin +filterRewards credential st = \case + AnchoredEvent{ledgerEvent = LedgerNewEpochEvent (LedgerTotalRewards epoch rewardsMap)} -> + let update = Map.lookup credential rewardsMap + & maybe id (Map.insert epoch . mergeRewards) + in update st + _otherEvent -> st + where + mergeRewards = Set.foldr (<>) mempty . Set.map Ledger.rewardAmount + +-- | Parse a 'Credential 'Staking' from a stake address in base16. +parseStakeCredential :: String -> Maybe (Credential 'Staking StandardCrypto) +parseStakeCredential str = + case Hex.decode (B8.pack str) of + Right bytes -> Ledger.getRwdCred <$> Ledger.decodeRewardAcnt bytes + Left{} -> Nothing diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 194f6c805f8..1bda8ebb9b6 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -235,6 +235,10 @@ executable reward-history build-depends: base >= 4.14 && < 4.17 , cardano-node , network + , containers + , bytestring + , base16-bytestring + , cardano-ledger-core test-suite cardano-node-test import: project-config diff --git a/cardano-node/src/Cardano/Node/LedgerEvent.hs b/cardano-node/src/Cardano/Node/LedgerEvent.hs index a385b3f336a..2249d0a4ec3 100644 --- a/cardano-node/src/Cardano/Node/LedgerEvent.hs +++ b/cardano-node/src/Cardano/Node/LedgerEvent.hs @@ -31,10 +31,6 @@ module Cardano.Node.LedgerEvent ( , withLedgerEventsServerStream , foldEvent - -- ** Example - , filterRewards - , parseStakeCredential - -- * Type-level plumbing , ConvertLedgerEvent (..) , eventCodecVersion @@ -49,6 +45,7 @@ module Cardano.Node.LedgerEvent ( , Reward (..) , ScriptHash (..) , SlotNo (..) + , BlockNo (..) , StandardCrypto , serialize' ) where @@ -64,7 +61,6 @@ import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..)) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Rewards (Reward(..)) import qualified Cardano.Ledger.Core as Ledger -import qualified Cardano.Ledger.Address as Ledger import Cardano.Ledger.Core (eraProtVerLow) import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import Cardano.Ledger.Keys (KeyRole (..)) @@ -76,18 +72,16 @@ import Cardano.Ledger.Shelley.Rules (RupdEvent (..), ShelleyEpochEvent (..), ShelleyMirEvent (..), ShelleyNewEpochEvent, ShelleyPoolreapEvent (..), ShelleyTickEvent (..)) -import Cardano.Slotting.Slot (SlotNo (..), EpochNo (..)) +import Cardano.Slotting.Slot (SlotNo (..), EpochNo (..), WithOrigin (..)) +import Cardano.Slotting.Block (BlockNo(..)) import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Write as CBOR import Control.State.Transition (Event) import Data.ByteString.Short(ShortByteString) -import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as Hex -import qualified Data.Map.Strict as Map import Data.SOP.Strict (All, K (..), NS(..), hcmap, hcollapse) import qualified Data.Set as Set import Data.String (String) @@ -113,6 +107,7 @@ import qualified Cardano.Ledger.Conway.Rules as Conway import qualified Cardano.Ledger.Shelley.API as ShelleyAPI import Cardano.Ledger.Alonzo.Rules (AlonzoBbodyEvent (ShelleyInAlonzoEvent), AlonzoUtxowEvent (WrappedShelleyEraEvent), AlonzoUtxoEvent (UtxosEvent), AlonzoUtxosEvent) import GHC.IO.Exception (IOException(IOError, ioe_type), IOErrorType (ResourceVanished)) +import Ouroboros.Network.Block (ChainHash(GenesisHash, BlockHash)) type LedgerState crypto = ExtLedgerState (HardForkBlock (CardanoEras crypto)) @@ -307,13 +302,6 @@ instance Crypto crypto => DecCBOR (LedgerRewardUpdateEvent crypto) where decRaw n = Invalid n --- | Parse a 'Credential 'Staking' from a stake address in base16. -parseStakeCredential :: String -> Maybe (Credential 'Staking StandardCrypto) -parseStakeCredential str = - case Hex.decode (B8.pack str) of - Right bytes -> Ledger.getRwdCred <$> Ledger.decodeRewardAcnt bytes - Left{} -> Nothing - instance Ord (LedgerEvent crypto) where a <= b = toOrdering a <= toOrdering b @@ -710,17 +698,21 @@ eventCodecVersion = \case data AnchoredEvent = AnchoredEvent - { headerHash :: !ShortByteString + { prevBlockHeaderHash :: !(WithOrigin ShortByteString) + , blockHeaderHash :: !ShortByteString , slotNo :: !SlotNo + , blockNo :: !BlockNo , ledgerEvent :: !(LedgerEvent StandardCrypto) } deriving (Eq, Show) instance EncCBOR AnchoredEvent where - encCBOR AnchoredEvent{headerHash, slotNo, ledgerEvent} = + encCBOR AnchoredEvent{prevBlockHeaderHash, blockHeaderHash , slotNo, blockNo, ledgerEvent} = encode $ Rec AnchoredEvent - !> To headerHash + !> To prevBlockHeaderHash + !> To blockHeaderHash !> To slotNo + !> To blockNo !> To ledgerEvent instance DecCBOR AnchoredEvent where @@ -729,6 +721,8 @@ instance DecCBOR AnchoredEvent where AnchoredEvent -> ByteString serializeAnchoredEvent version event = @@ -772,23 +766,9 @@ foldEvent h st0 fn = st' <- fn st event go st' events -filterRewards - :: Credential 'Staking StandardCrypto - -> Map EpochNo Coin - -> AnchoredEvent - -> Map EpochNo Coin -filterRewards credential st = \case - AnchoredEvent{ledgerEvent = LedgerNewEpochEvent (LedgerTotalRewards epoch rewardsMap)} -> - let update = Map.lookup credential rewardsMap - & maybe identity (Map.insert epoch . mergeRewards) - in update st - _otherEvent -> st - where - mergeRewards = Set.foldr (<>) mempty . Set.map Ledger.rewardAmount - withLedgerEventsServerStream :: PortNumber - -> (LedgerEventHandler IO (LedgerState StandardCrypto) -> IO ()) + -> (LedgerEventHandler IO (LedgerState StandardCrypto) (HardForkBlock (CardanoEras crypto)) -> IO ()) -> IO () withLedgerEventsServerStream port handler = do withSocketsDo $ do @@ -808,15 +788,18 @@ withLedgerEventsServerStream port handler = do closeSockets = close - writeLedgerEvents h headerHash slotNo event = do - case fromAuxLedgerEvent event of - Nothing -> pure () - Just e -> do - let anchoredEvent = AnchoredEvent (getOneEraHash headerHash) slotNo e - catch (BS.hPut h $ serializeAnchoredEvent (eventCodecVersion event) anchoredEvent) $ \case - -- If the client closes the socket, we continue running the node, but ignore the events. - IOError { ioe_type = ResourceVanished } -> do - pure () - err -> do - print err - throwIO err + writeLedgerEvents h ph headerHash slotNo blockNo events = do + forM_ events $ \event -> do + case fromAuxLedgerEvent event of + Nothing -> pure () + Just e -> do + let chainHashToHeaderHash GenesisHash = Origin + chainHashToHeaderHash (BlockHash bh) = At bh + let anchoredEvent = AnchoredEvent (getOneEraHash <$> chainHashToHeaderHash ph) (getOneEraHash headerHash) slotNo blockNo e + catch (BS.hPut h $ serializeAnchoredEvent (eventCodecVersion event) anchoredEvent) $ \case + -- If the client closes the socket, we continue running the node, but ignore the events. + IOError { ioe_type = ResourceVanished } -> do + pure () + err -> do + print err + throwIO err diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 1a0a2a97d19..4b525caa9e8 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -206,7 +206,7 @@ handleNodeWithTracers :: ( TraceConstraints blk , Api.Protocol IO blk ) - => LedgerEventHandler IO (ExtLedgerState blk) + => LedgerEventHandler IO (ExtLedgerState blk) blk -> PartialNodeConfiguration -> NodeConfiguration -> SomeConsensusProtocol @@ -343,7 +343,7 @@ handlePeersListSimple tr nodeKern = forever $ do handleSimpleNode :: forall blk p2p . Api.Protocol IO blk - => LedgerEventHandler IO (ExtLedgerState blk) + => LedgerEventHandler IO (ExtLedgerState blk) blk -> Api.ProtocolInfoArgs IO blk -> NetworkP2PMode p2p -> Tracers RemoteConnectionId LocalConnectionId blk p2p diff --git a/nix/haskell.nix b/nix/haskell.nix index bb46dd832eb..92b49394618 100644 --- a/nix/haskell.nix +++ b/nix/haskell.nix @@ -46,6 +46,7 @@ let cabal tullia nix-systems + pkgs.cargo ]; withHoogle = true;