Write ledger events to disk

  - For now, on a hard-coded file path 'ledger_events.cbor'
  - Also using a naive CBOR encoding where each event gets appended to
    the file.

  Ultimately, we may want a more fine grained control on the encoding to
  ensure a stable API, as well as some flexibility from the node's
  command-line to (a) mount or not the event handler and (b) choose the
  path of the file.

  We've also discussed the possibility of streaming those events through
  some socket.

cardano-node/cardano-node.cabal

@@ -145,6 +145,7 @@ library
                       , cardano-ledger-alonzo
                       , cardano-ledger-allegra
                       , cardano-ledger-babbage
+                      , cardano-ledger-binary
                       , cardano-ledger-byron
                       , cardano-ledger-conway
                       , cardano-ledger-core

cardano-node/src/Cardano/Node/LedgerEvent.hs

@@ -1,16 +1,19 @@
-{-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE NoImplicitPrelude     #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE PatternSynonyms       #-}
-{-# LANGUAGE RankNTypes            #-}
-{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE ConstraintKinds            #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE NoImplicitPrelude          #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE UndecidableInstances       #-}
 
 -- | Local representation for display purpose of cardano-ledger events.
 --
@@ -19,16 +22,21 @@ module Cardano.Node.LedgerEvent (
     ConvertLedgerEvent (..)
   , EventsConstraints
   , LedgerEvent (..)
-  , convertAuxLedgerEvent
-  , convertAuxLedgerEvent'
+  , fromAuxLedgerEvent
   , convertPoolRewards
   , ledgerEventName
+  , eventCodecVersion
   ) where
 
+import           Cardano.Prelude hiding (All, Sum)
+
+import           Cardano.Ledger.Binary (EncCBOR(..), Version)
+import           Cardano.Ledger.Binary.Coders (Encode (..), encode, (!>))
 import           Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
 import qualified Cardano.Ledger.Core as Ledger
+import           Cardano.Ledger.Core (eraProtVerLow)
 import qualified Cardano.Ledger.Credential as Ledger
-import           Cardano.Ledger.Crypto (StandardCrypto)
+import           Cardano.Ledger.Crypto (Crypto, StandardCrypto)
 import           Cardano.Ledger.Keys (KeyRole (StakePool))
 import           Cardano.Ledger.Shelley.API (InstantaneousRewards (..), KeyHash)
 import           Cardano.Ledger.Shelley.Core (EraCrypto)
@@ -37,18 +45,18 @@ import           Cardano.Ledger.Shelley.Rules (RupdEvent (..),
                      ShelleyEpochEvent (..), ShelleyMirEvent (..),
                      ShelleyNewEpochEvent, ShelleyPoolreapEvent (..),
                      ShelleyTickEvent (..))
-import           Cardano.Prelude hiding (All)
 import           Cardano.Slotting.Slot (EpochNo (..))
 import           Control.State.Transition (Event)
 import qualified Data.Map.Strict as Map
-import           Data.SOP.Strict (All, K (..), hcmap, hcollapse)
+import           Data.SOP.Strict (All, K (..), NS(..), hcmap, hcollapse)
 import qualified Data.Set as Set
 import           Data.Maybe.Strict(StrictMaybe(..))
 import           Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
 import           Ouroboros.Consensus.Cardano.Block (AllegraEra, AlonzoEra,
-                     BabbageEra, ConwayEra, HardForkBlock, MaryEra, ShelleyEra)
+                     BabbageEra, CardanoEras, ConwayEra, HardForkBlock,
+                     MaryEra, ShelleyEra)
 import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
-                     (getOneEraLedgerEvent)
+                     (OneEraLedgerEvent(..))
 import           Ouroboros.Consensus.Ledger.Abstract (AuxLedgerEvent,
                      LedgerState)
 import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock,
@@ -72,13 +80,38 @@ data LedgerEvent
   | LedgerTick
   deriving (Eq, Show)
 
+-- TODO: Review encoding & make future-proof (i.e. favor records over lists/tuples)
+instance EncCBOR LedgerEvent where
+  encCBOR = encode . \case
+    LedgerMirDist rewards ->
+      Sum LedgerMirDist 0 !> To rewards
+    LedgerPoolReap epoch rewards ->
+      Sum LedgerPoolReap 1 !> To epoch !> To rewards
+    LedgerIncrementalRewards epoch rewards ->
+      Sum LedgerIncrementalRewards 2 !> To epoch !> To rewards
+    LedgerDeltaRewards epoch rewards ->
+      Sum LedgerDeltaRewards 3 !> To epoch !> To rewards
+    LedgerRestrainedRewards epoch rewards credentials ->
+      Sum LedgerRestrainedRewards 4 !> To epoch !> To rewards !> To credentials
+    LedgerTotalRewards epoch rewards ->
+      Sum LedgerTotalRewards 5 !> To epoch !> To rewards
+    LedgerStartAtEpoch epoch ->
+      Sum LedgerStartAtEpoch 6 !> To epoch
+    LedgerBody ->
+      Sum LedgerBody 7
+    LedgerTick ->
+      Sum LedgerBody 8
+
 data Reward = Reward
   { rewardSource :: !RewardSource
   , rewardPool   :: !(StrictMaybe (PoolKeyHash))
   , rewardAmount :: !Coin
   }
   deriving (Eq, Ord, Show)
 
+instance EncCBOR Reward where
+  encCBOR = encode . Rec
+
 -- The following must be in alphabetic order.
 data RewardSource
   = RwdLeader
@@ -98,7 +131,8 @@ type StakeCred = Ledger.StakeCredential StandardCrypto
 newtype Rewards = Rewards
   { unRewards :: Map StakeCred (Set Reward)
   }
-  deriving (Eq, Show)
+  deriving stock (Eq, Show)
+  deriving newtype (EncCBOR)
 
 instance Ord LedgerEvent where
   a <= b = toOrdering a <= toOrdering b
@@ -128,11 +162,8 @@ ledgerEventName le =
     LedgerBody {}               -> "LedgerBody"
     LedgerTick {}               -> "LedgerTick"
 
-convertAuxLedgerEvent' :: forall xs blk . (All ConvertLedgerEvent xs, HardForkBlock xs ~ blk) => AuxLedgerEvent (LedgerState blk) -> Maybe LedgerEvent
-convertAuxLedgerEvent' = toLedgerEvent . WrapLedgerEvent @blk
-
-convertAuxLedgerEvent :: forall xs . (All ConvertLedgerEvent xs) => AuxLedgerEvent (LedgerState (HardForkBlock xs)) -> Maybe LedgerEvent
-convertAuxLedgerEvent = toLedgerEvent . WrapLedgerEvent @(HardForkBlock xs)
+fromAuxLedgerEvent :: forall xs . (All ConvertLedgerEvent xs) => AuxLedgerEvent (LedgerState (HardForkBlock xs)) -> Maybe LedgerEvent
+fromAuxLedgerEvent = toLedgerEvent . WrapLedgerEvent @(HardForkBlock xs)
 
 class ConvertLedgerEvent blk where
   toLedgerEvent :: WrapLedgerEvent blk -> Maybe LedgerEvent
@@ -200,6 +231,15 @@ instance ConvertLedgerEvent (ShelleyBlock p (ConwayEra StandardCrypto)) where
   -- TODO: do something with conway epoch events
   toLedgerEvent = const Nothing
 
+eventCodecVersion :: forall crypto. Crypto crypto => OneEraLedgerEvent (CardanoEras crypto) -> Version
+eventCodecVersion = \case
+  OneEraLedgerEvent (          S(Z{})     ) -> eraProtVerLow @(ShelleyEra crypto)
+  OneEraLedgerEvent (        S(S(Z{}))    ) -> eraProtVerLow @(AllegraEra crypto)
+  OneEraLedgerEvent (      S(S(S(Z{})))   ) -> eraProtVerLow @(MaryEra crypto)
+  OneEraLedgerEvent (    S(S(S(S(Z{}))))  ) -> eraProtVerLow @(AlonzoEra crypto)
+  OneEraLedgerEvent (  S(S(S(S(S(Z{}))))) ) -> eraProtVerLow @(BabbageEra crypto)
+  OneEraLedgerEvent (S(S(S(S(S(S(Z{}))))))) -> eraProtVerLow @(ConwayEra crypto)
+
 --------------------------------------------------------------------------------
 
 convertPoolDepositRefunds ::

cardano-node/src/Cardano/Node/Run.hs

@@ -37,6 +37,9 @@ import           Control.Monad.IO.Class (MonadIO (..))
 import           Control.Monad.Trans.Except (ExceptT, runExceptT)
 import           Control.Monad.Trans.Except.Extra (left)
 import           "contra-tracer" Control.Tracer
+import           Cardano.Ledger.Binary (serialize')
+import           System.IO (withFile, IOMode(..))
+import qualified Data.ByteString as BS
 import           Data.Either (partitionEithers)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -97,6 +100,9 @@ import qualified Ouroboros.Consensus.Node as Node (getChainDB, run)
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Util.Orphans ()
+import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras (OneEraHash(..),
+                   OneEraLedgerEvent(..))
+import           Ouroboros.Consensus.TypeFamilyWrappers (unwrapLedgerEvent)
 import qualified Ouroboros.Network.Diffusion as Diffusion
 import qualified Ouroboros.Network.Diffusion.NonP2P as NonP2P
 import qualified Ouroboros.Network.Diffusion.P2P as P2P
@@ -167,18 +173,23 @@ runNode cmdPc = do
               let ProtocolInfo { pInfoConfig } = Api.protocolInfo runP
               in getNetworkMagic $ Consensus.configBlock pInfoConfig
 
-    case p of
-      SomeConsensusProtocol blk runP ->
-        handleNodeWithTracers
-          (case blk of
-            Api.CardanoBlockType -> LedgerEventHandler $ \headerHash slotNo event -> do
-              putStrLn $ "New ledger event: " <> show headerHash <> " " <> show slotNo <> " " <> show (convertAuxLedgerEvent event)
-            Api.ByronBlockType{} ->
-              discardEvent
-            Api.ShelleyBlockType{} ->
-              discardEvent
-          )
-          cmdPc nc p networkMagic runP
+    withFile "ledger_events.cbor" AppendMode $ \h -> do
+      case p of
+        SomeConsensusProtocol blk runP ->
+          handleNodeWithTracers
+            (case blk of
+              Api.CardanoBlockType -> LedgerEventHandler $ \headerHash slotNo event -> do
+                  BS.hPut h $ serialize' (eventCodecVersion event)
+                    ( getOneEraHash headerHash
+                    , slotNo
+                    , fromAuxLedgerEvent event
+                    )
+              Api.ByronBlockType{} ->
+                discardEvent
+              Api.ShelleyBlockType{} ->
+                discardEvent
+            )
+            cmdPc nc p networkMagic runP
 
 -- | Workaround to ensure that the main thread throws an async exception on
 -- receiving a SIGTERM signal.