From f59abbf1657d835b85c736a992e85c2d5e97f100 Mon Sep 17 00:00:00 2001 From: David Eichmann Date: Fri, 27 Aug 2021 18:30:09 +0100 Subject: [PATCH 1/2] Add chainSyncClientWithLedgerState and chainSyncClientPipelinedWithLedgerState These wrap a ChainSyncClient(Pipelined) with logic to track the ledger state while also supporting rollback. --- cardano-api/src/Cardano/Api.hs | 2 + cardano-api/src/Cardano/Api/LedgerState.hs | 259 ++++++++++++++---- .../ChainSyncClientWithLedgerState.hs | 134 +++++++++ cardano-client-demo/cardano-client-demo.cabal | 15 + 4 files changed, 359 insertions(+), 51 deletions(-) create mode 100644 cardano-client-demo/ChainSyncClientWithLedgerState.hs diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 3ec2f9726ba..d0cbdee762a 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -485,6 +485,8 @@ module Cardano.Api ( -- *** Traversing the block chain foldBlocks, + chainSyncClientWithLedgerState, + chainSyncClientPipelinedWithLedgerState, -- *** Errors FoldBlocksError(..), diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index c15d168df25..3a59bdfa25d 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -23,6 +23,8 @@ module Cardano.Api.LedgerState -- * Traversing the block chain , foldBlocks + , chainSyncClientWithLedgerState + , chainSyncClientPipelinedWithLedgerState -- * Errors , FoldBlocksError(..) @@ -100,10 +102,8 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Shelley import qualified Ouroboros.Consensus.Shelley.Ledger.Ledger as Shelley import qualified Ouroboros.Consensus.Shelley.Protocol as Shelley import qualified Ouroboros.Network.Block -import Ouroboros.Network.Protocol.ChainSync.ClientPipelined - (ChainSyncClientPipelined (ChainSyncClientPipelined), - ClientPipelinedStIdle (CollectResponse, SendMsgDone, SendMsgRequestNextPipelined), - ClientStNext (..)) +import qualified Ouroboros.Network.Protocol.ChainSync.Client as CS +import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as CSP import Ouroboros.Network.Protocol.ChainSync.PipelineDecision import qualified Shelley.Spec.Ledger.Genesis as Shelley.Spec import qualified Shelley.Spec.Ledger.PParams as Shelley.Spec @@ -218,12 +218,15 @@ foldBlocks -- ^ The initial accumulator state. -> (Env -> LedgerState -> BlockInMode CardanoMode -> a -> IO a) -- ^ Accumulator function Takes: - -- * Environment (this is a constant over the whole fold) - -- * The current Ledger state (with the current block applied) - -- * The current Block - -- * The previous state -- - -- And this should return the new state. + -- * Environment (this is a constant over the whole fold). + -- * The Ledger state (with block @i@ applied) at block @i@. + -- * Block @i@. + -- * The accumulator state at block @i - 1@. + -- + -- And returns: + -- + -- * The accumulator state at block @i@ -- -- Note: This function can safely assume no rollback will occur even though -- internally this is implemented with a client protocol that may require @@ -290,28 +293,6 @@ foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation stat localStateQueryClient = Nothing } - -- | Add a new ledger state to the history - pushLedgerState - :: Env -- ^ Environement used to get the security param, k. - -> LedgerStateHistory -- ^ History of k ledger states. - -> SlotNo -- ^ Slot number of the new ledger state. - -> LedgerState -- ^ New ledger state to add to the history - -> BlockInMode CardanoMode - -- ^ The block that (when applied to the previous - -- ledger state) resulted in the new ledger state. - -> (LedgerStateHistory, LedgerStateHistory) - -- ^ ( The new history with the new state appended - -- , Any exisiting ledger states that are now past the security parameter - -- and hence can no longer be rolled back. - -- ) - pushLedgerState env hist ix st block - = Seq.splitAt - (fromIntegral $ envSecurityParam env + 1) - ((ix, st, At block) Seq.:<| hist) - - rollBackLedgerStateHist :: LedgerStateHistory -> SlotNo -> LedgerStateHistory - rollBackLedgerStateHist hist maxInc = Seq.dropWhileL ((> maxInc) . (\(x,_,_) -> x)) hist - -- | Defines the client side of the chain sync protocol. chainSyncClient :: Word32 -- ^ The maximum number of concurrent requests. @@ -321,38 +302,36 @@ foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation stat -- completion. -> Env -> LedgerState - -> ChainSyncClientPipelined + -> CSP.ChainSyncClientPipelined (BlockInMode CardanoMode) ChainPoint ChainTip IO () -- ^ Client returns maybe an error. chainSyncClient pipelineSize stateIORef errorIORef env ledgerState0 - = ChainSyncClientPipelined $ pure $ clientIdle_RequestMoreN Origin Origin Zero initialLedgerStateHistory + = CSP.ChainSyncClientPipelined $ pure $ clientIdle_RequestMoreN Origin Origin Zero initialLedgerStateHistory where initialLedgerStateHistory = Seq.singleton (0, ledgerState0, Origin) - pushLedgerState' = pushLedgerState env - clientIdle_RequestMoreN :: WithOrigin BlockNo -> WithOrigin BlockNo -> Nat n -- Number of requests inflight. -> LedgerStateHistory - -> ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO () + -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO () clientIdle_RequestMoreN clientTip serverTip n knownLedgerStates = case pipelineDecisionMax pipelineSize n clientTip serverTip of Collect -> case n of - Succ predN -> CollectResponse Nothing (clientNextN predN knownLedgerStates) - _ -> SendMsgRequestNextPipelined (clientIdle_RequestMoreN clientTip serverTip (Succ n) knownLedgerStates) + Succ predN -> CSP.CollectResponse Nothing (clientNextN predN knownLedgerStates) + _ -> CSP.SendMsgRequestNextPipelined (clientIdle_RequestMoreN clientTip serverTip (Succ n) knownLedgerStates) clientNextN :: Nat n -- Number of requests inflight. -> LedgerStateHistory - -> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () + -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () clientNextN n knownLedgerStates = - ClientStNext { - recvMsgRollForward = \blockInMode@(BlockInMode block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do + CSP.ClientStNext { + CSP.recvMsgRollForward = \blockInMode@(BlockInMode block@(Block (BlockHeader slotNo _ currBlockNo) _) _era) serverChainTip -> do let newLedgerStateE = applyBlock env (maybe @@ -365,7 +344,7 @@ foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation stat case newLedgerStateE of Left err -> clientIdle_DoneN n (Just err) Right newLedgerState -> do - let (knownLedgerStates', committedStates) = pushLedgerState' knownLedgerStates slotNo newLedgerState blockInMode + let (knownLedgerStates', committedStates) = pushLedgerState env knownLedgerStates slotNo newLedgerState blockInMode newClientTip = At currBlockNo newServerTip = fromChainTip serverChainTip forM_ committedStates $ \(_, currLedgerState, currBlockMay) -> case currBlockMay of @@ -376,7 +355,7 @@ foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation stat if newClientTip == newServerTip then clientIdle_DoneN n Nothing else return (clientIdle_RequestMoreN newClientTip newServerTip n knownLedgerStates') - , recvMsgRollBackward = \chainPoint serverChainTip -> do + , CSP.recvMsgRollBackward = \chainPoint serverChainTip -> do let newClientTip = Origin -- We don't actually keep track of blocks so we temporarily "forget" the tip. newServerTip = fromChainTip serverChainTip truncatedKnownLedgerStates = case chainPoint of @@ -388,21 +367,21 @@ foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation stat clientIdle_DoneN :: Nat n -- Number of requests inflight. -> Maybe Text -- Return value (maybe an error) - -> IO (ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()) + -> IO (CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode) ChainPoint ChainTip IO ()) clientIdle_DoneN n errorMay = case n of - Succ predN -> return (CollectResponse Nothing (clientNext_DoneN predN errorMay)) -- Ignore remaining message responses + Succ predN -> return (CSP.CollectResponse Nothing (clientNext_DoneN predN errorMay)) -- Ignore remaining message responses Zero -> do writeIORef errorIORef errorMay - return (SendMsgDone ()) + return (CSP.SendMsgDone ()) clientNext_DoneN :: Nat n -- Number of requests inflight. -> Maybe Text -- Return value (maybe an error) - -> ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () + -> CSP.ClientStNext n (BlockInMode CardanoMode) ChainPoint ChainTip IO () clientNext_DoneN n errorMay = - ClientStNext { - recvMsgRollForward = \_ _ -> clientIdle_DoneN n errorMay - , recvMsgRollBackward = \_ _ -> clientIdle_DoneN n errorMay + CSP.ClientStNext { + CSP.recvMsgRollForward = \_ _ -> clientIdle_DoneN n errorMay + , CSP.recvMsgRollBackward = \_ _ -> clientIdle_DoneN n errorMay } fromChainTip :: ChainTip -> WithOrigin BlockNo @@ -410,6 +389,161 @@ foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation stat ChainTipAtGenesis -> Origin ChainTip _ _ bno -> At bno +-- | Wrap a 'ChainSyncClient' with logic that tracks the ledger state. +chainSyncClientWithLedgerState + :: forall m a. + Monad m + => Env + -> LedgerState + -- ^ Initial ledger state + -> Bool + -- ^ True to enable validation. Under the hood this will use @applyBlock@ + -- instead of @reapplyBlock@ from the @ApplyBlock@ type class. Even when + -- @False@, a fast check of hashes is still done, so applying blocks can still + -- result in an error. + -> CS.ChainSyncClient (BlockInMode CardanoMode, Either Text LedgerState) + ChainPoint + ChainTip + m + a + -- ^ A client to wrap. The block is annotated with a 'Either Text + -- LedgerState'. This is either an error from validating a block or + -- the current 'LedgerState' from applying the current block. If we + -- trust the node, then we generally expect blocks to validate. Also note that + -- after a block fails to validate we may still roll back to a validated + -- block, in which case the valid 'LedgerState' will be passed here again. + -> CS.ChainSyncClient (BlockInMode CardanoMode) + ChainPoint + ChainTip + m + a + -- ^ A client that acts just like the wrapped client but doesn't require the + -- 'LedgerState' annotation on the block type. +chainSyncClientWithLedgerState env ledgerState0 enableValidation (CS.ChainSyncClient clientTop) + = CS.ChainSyncClient (goClientStIdle initialLedgerStateHistory <$> clientTop) + where + goClientStIdle + :: History (Either Text LedgerState) + -> CS.ClientStIdle (BlockInMode CardanoMode, Either Text LedgerState) ChainPoint ChainTip m a + -> CS.ClientStIdle (BlockInMode CardanoMode ) ChainPoint ChainTip m a + goClientStIdle history client = case client of + CS.SendMsgRequestNext a b -> CS.SendMsgRequestNext (goClientStNext history a) (goClientStNext history <$> b) + CS.SendMsgFindIntersect ps a -> CS.SendMsgFindIntersect ps (goClientStIntersect history a) + CS.SendMsgDone a -> CS.SendMsgDone a + + -- This is where the magic happens. We intercept the blocks and rollbacks + -- and use it to maintain the correct ledger state. + goClientStNext + :: History (Either Text LedgerState) + -> CS.ClientStNext (BlockInMode CardanoMode, Either Text LedgerState) ChainPoint ChainTip m a + -> CS.ClientStNext (BlockInMode CardanoMode ) ChainPoint ChainTip m a + goClientStNext history (CS.ClientStNext recvMsgRollForward recvMsgRollBackward) = CS.ClientStNext + (\blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) tip -> CS.ChainSyncClient $ let + newLedgerStateE = case Seq.lookup 0 history of + Nothing -> Left "Rolled back too far." + Just (_, Left err, _) -> Left err + Just (_, Right oldLedgerState, _) -> applyBlock + env + oldLedgerState + enableValidation + blk + (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode + in goClientStIdle history' <$> CS.runChainSyncClient (recvMsgRollForward (blkInMode, newLedgerStateE) tip) + ) + (\point tip -> let + history' = case point of + ChainPointAtGenesis -> initialLedgerStateHistory + ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo + in CS.ChainSyncClient $ goClientStIdle history' <$> CS.runChainSyncClient (recvMsgRollBackward point tip) + ) + + goClientStIntersect + :: History (Either Text LedgerState) + -> CS.ClientStIntersect (BlockInMode CardanoMode, Either Text LedgerState) ChainPoint ChainTip m a + -> CS.ClientStIntersect (BlockInMode CardanoMode ) ChainPoint ChainTip m a + goClientStIntersect history (CS.ClientStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = CS.ClientStIntersect + (\point tip -> CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectFound point tip))) + (\tip -> CS.ChainSyncClient (goClientStIdle history <$> CS.runChainSyncClient (recvMsgIntersectNotFound tip))) + + initialLedgerStateHistory :: History (Either Text LedgerState) + initialLedgerStateHistory = Seq.singleton (0, Right ledgerState0, Origin) + +-- | See 'chainSyncClientWithLedgerState'. +chainSyncClientPipelinedWithLedgerState + :: forall m a. + Monad m + => Env + -> LedgerState + -> Bool + -> CSP.ChainSyncClientPipelined + (BlockInMode CardanoMode, Either Text LedgerState) + ChainPoint + ChainTip + m + a + -> CSP.ChainSyncClientPipelined + (BlockInMode CardanoMode) + ChainPoint + ChainTip + m + a +chainSyncClientPipelinedWithLedgerState env ledgerState0 enableValidation (CSP.ChainSyncClientPipelined clientTop) + = CSP.ChainSyncClientPipelined (goClientPipelinedStIdle initialLedgerStateHistory Zero <$> clientTop) + where + goClientPipelinedStIdle + :: History (Either Text LedgerState) + -> Nat n + -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode, Either Text LedgerState) ChainPoint ChainTip m a + -> CSP.ClientPipelinedStIdle n (BlockInMode CardanoMode ) ChainPoint ChainTip m a + goClientPipelinedStIdle history n client = case client of + CSP.SendMsgRequestNext a b -> CSP.SendMsgRequestNext (goClientStNext history n a) (goClientStNext history n <$> b) + CSP.SendMsgRequestNextPipelined a -> CSP.SendMsgRequestNextPipelined (goClientPipelinedStIdle history (Succ n) a) + CSP.SendMsgFindIntersect ps a -> CSP.SendMsgFindIntersect ps (goClientPipelinedStIntersect history n a) + CSP.CollectResponse a b -> case n of + Succ nPrev -> CSP.CollectResponse ((fmap . fmap) (goClientPipelinedStIdle history n) a) (goClientStNext history nPrev b) + CSP.SendMsgDone a -> CSP.SendMsgDone a + + -- This is where the magic happens. We intercept the blocks and rollbacks + -- and use it to maintain the correct ledger state. + goClientStNext + :: History (Either Text LedgerState) + -> Nat n + -> CSP.ClientStNext n (BlockInMode CardanoMode, Either Text LedgerState) ChainPoint ChainTip m a + -> CSP.ClientStNext n (BlockInMode CardanoMode ) ChainPoint ChainTip m a + goClientStNext history n (CSP.ClientStNext recvMsgRollForward recvMsgRollBackward) = CSP.ClientStNext + (\blkInMode@(BlockInMode blk@(Block (BlockHeader slotNo _ _) _) _) tip -> let + newLedgerStateE = case Seq.lookup 0 history of + Nothing -> Left "Rolled back too far." + Just (_, Left err, _) -> Left err + Just (_, Right oldLedgerState, _) -> applyBlock + env + oldLedgerState + enableValidation + blk + (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode + in goClientPipelinedStIdle history' n <$> recvMsgRollForward (blkInMode, newLedgerStateE) tip + ) + (\point tip -> let + history' = case point of + ChainPointAtGenesis -> initialLedgerStateHistory + ChainPoint slotNo _ -> rollBackLedgerStateHist history slotNo + in goClientPipelinedStIdle history' n <$> recvMsgRollBackward point tip + ) + + goClientPipelinedStIntersect + :: History (Either Text LedgerState) + -> Nat n + -> CSP.ClientPipelinedStIntersect (BlockInMode CardanoMode, Either Text LedgerState) ChainPoint ChainTip m a + -> CSP.ClientPipelinedStIntersect (BlockInMode CardanoMode ) ChainPoint ChainTip m a + goClientPipelinedStIntersect history _ (CSP.ClientPipelinedStIntersect recvMsgIntersectFound recvMsgIntersectNotFound) = CSP.ClientPipelinedStIntersect + (\point tip -> goClientPipelinedStIdle history Zero <$> recvMsgIntersectFound point tip) + (\tip -> goClientPipelinedStIdle history Zero <$> recvMsgIntersectNotFound tip) + + initialLedgerStateHistory :: History (Either Text LedgerState) + initialLedgerStateHistory = Seq.singleton (0, Right ledgerState0, Origin) + +{- HLINT ignore chainSyncClientPipelinedWithLedgerState "Use fmap" -} + -- | A history of k (security parameter) recent ledger states. The head is the -- most recent item. Elements are: -- @@ -417,7 +551,30 @@ foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation stat -- * The ledger state after applying the new block -- * The new block -- -type LedgerStateHistory = Seq (SlotNo, LedgerState, WithOrigin (BlockInMode CardanoMode)) +type LedgerStateHistory = History LedgerState +type History a = Seq (SlotNo, a, WithOrigin (BlockInMode CardanoMode)) + +-- | Add a new ledger state to the history +pushLedgerState + :: Env -- ^ Environement used to get the security param, k. + -> History a -- ^ History of k items. + -> SlotNo -- ^ Slot number of the new item. + -> a -- ^ New item to add to the history + -> BlockInMode CardanoMode + -- ^ The block that (when applied to the previous + -- item) resulted in the new item. + -> (History a, History a) + -- ^ ( The new history with the new item appended + -- , Any exisiting items that are now past the security parameter + -- and hence can no longer be rolled back. + -- ) +pushLedgerState env hist ix st block + = Seq.splitAt + (fromIntegral $ envSecurityParam env + 1) + ((ix, st, At block) Seq.:<| hist) + +rollBackLedgerStateHist :: History a -> SlotNo -> History a +rollBackLedgerStateHist hist maxInc = Seq.dropWhileL ((> maxInc) . (\(x,_,_) -> x)) hist -------------------------------------------------------------------------------- -- Everything below was copied/adapted from db-sync -- diff --git a/cardano-client-demo/ChainSyncClientWithLedgerState.hs b/cardano-client-demo/ChainSyncClientWithLedgerState.hs new file mode 100644 index 00000000000..aab1a7aeb33 --- /dev/null +++ b/cardano-client-demo/ChainSyncClientWithLedgerState.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +import Cardano.Api +import Cardano.Api.ChainSync.Client +import qualified Cardano.Chain.Slotting as Byron (EpochSlots (..)) +import Cardano.Slotting.Slot +import qualified Ouroboros.Consensus.Cardano.Block as C +import qualified Ouroboros.Consensus.HardFork.Combinator.Basics as C +import qualified Ouroboros.Consensus.HardFork.Combinator.State.Types as C +import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Telescope as TSP + +import Control.Monad (when) +import Control.Monad.Trans.Except +import Data.Kind +import Data.Proxy +import qualified Data.SOP as SOP +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Data.Word (Word32) +import qualified GHC.TypeLits as GHC +import System.Environment (getArgs) +import System.FilePath (()) + +-- | Connects to a local cardano node, requests the blocks and prints out some +-- information from each ledger state. To run this, you must first start a local +-- node e.g.: +-- +-- $ cabal run cardano-node:cardano-node -- run \ +-- --config configuration/cardano/mainnet-config.json \ +-- --topology configuration/cardano/mainnet-topology.json \ +-- --database-path db \ +-- --socket-path db/node.sock \ +-- --host-addr 127.0.0.1 \ +-- --port 3001 \ +-- +-- Then run this with the path to the config file and the node.sock: +-- +-- $ cabal run cardano-client-demo:chain-sync-client-with-ledger-state -- \ +-- configuration/cardano/mainnet-config.json \ +-- db/node.sock +-- +main :: IO () +main = do + -- Get config and socket path from CLI argument. + configFilePath : socketPath : xs <- getArgs + byronSlotLength <- case xs of + byronSlotLengthStr : _ -> return (read byronSlotLengthStr) + _ -> do + let l = 21600 + putStrLn $ "Using default byron slots per epoch: " <> show l + return l + + -- Use 'chainSyncClientWithLedgerState' to support ledger state. + Right (env, initialLedgerState) <- runExceptT $ initialLedgerState configFilePath + let client = chainSyncClientWithLedgerState + env + initialLedgerState + True + chainSyncClient + + protocols :: LocalNodeClientProtocolsInMode CardanoMode + protocols = + LocalNodeClientProtocols { + localChainSyncClient = LocalChainSyncClient client, + localTxSubmissionClient = Nothing, + localStateQueryClient = Nothing + } + + -- Connect to the node. + putStrLn $ "Connecting to socket: " <> socketPath + connectToLocalNode + (connectInfo socketPath) + protocols + where + connectInfo :: FilePath -> LocalNodeConnectInfo CardanoMode + connectInfo socketPath = + LocalNodeConnectInfo { + localConsensusModeParams = CardanoModeParams (Byron.EpochSlots 21600), + localNodeNetworkId = Mainnet, + localNodeSocketPath = socketPath + } + +-- | Defines the client side of the chain sync protocol. +chainSyncClient + :: ChainSyncClient + (BlockInMode CardanoMode, Either Text LedgerState) + ChainPoint + ChainTip + IO + () +chainSyncClient = ChainSyncClient $ do + startTime <- getCurrentTime + let + clientStIdle :: ClientStIdle (BlockInMode CardanoMode, Either Text LedgerState) + ChainPoint ChainTip IO () + clientStIdle = SendMsgRequestNext + clientStNext + (pure clientStNext) + + clientStNext :: ClientStNext (BlockInMode CardanoMode, Either Text LedgerState) + ChainPoint ChainTip IO () + clientStNext = + ClientStNext { + recvMsgRollForward = + \( BlockInMode block@(Block (BlockHeader _ _ (BlockNo blockNo)) _) _ + , ledgerStateE + ) + _tip -> + ChainSyncClient $ case ledgerStateE of + Left err -> do + putStrLn $ "Ledger state error: " <> T.unpack err + return (SendMsgDone ()) + Right (LedgerState (C.HardForkLedgerState (C.HardForkState ledgerState))) -> do + when (blockNo `mod` 1000 == 0) $ do + printLedgerState ledgerState + now <- getCurrentTime + let elapsedTime = realToFrac (now `diffUTCTime` startTime) :: Float + rate = fromIntegral blockNo / elapsedTime + putStrLn $ "Rate = " ++ show rate ++ " blocks/second" + return clientStIdle + , recvMsgRollBackward = \_ _ -> ChainSyncClient $ do + putStrLn "Rollback!" + return clientStIdle + } + + printLedgerState :: TSP.Telescope (SOP.K C.Past) (C.Current C.LedgerState) xs -> IO () + printLedgerState ls = case ls of + TSP.TZ (C.Current bound _) -> putStrLn $ "curren't era bounds: " <> show bound + TSP.TS _ ls' -> printLedgerState ls' + return clientStIdle + diff --git a/cardano-client-demo/cardano-client-demo.cabal b/cardano-client-demo/cardano-client-demo.cabal index ffc0c571247..06b8ac82579 100644 --- a/cardano-client-demo/cardano-client-demo.cabal +++ b/cardano-client-demo/cardano-client-demo.cabal @@ -36,6 +36,21 @@ executable scan-blocks-pipelined , filepath , time +executable chain-sync-client-with-ledger-state + import: base, project-config + main-is: ChainSyncClientWithLedgerState.hs + build-depends: cardano-api + , cardano-ledger-byron + , cardano-slotting + , ouroboros-consensus + , ouroboros-consensus-cardano + + , filepath + , sop-core + , text + , time + , transformers + executable ledger-state import: base, project-config main-is: LedgerState.hs From 993825845e054678a3efadc75373ab3a223160e5 Mon Sep 17 00:00:00 2001 From: David Eichmann Date: Mon, 30 Aug 2021 17:44:10 +0100 Subject: [PATCH 2/2] Use ValidationMode instead of Bool for LedgerState tracking --- cardano-api/src/Cardano/Api.hs | 1 + cardano-api/src/Cardano/Api/LedgerState.hs | 52 +++++++++---------- .../ChainSyncClientWithLedgerState.hs | 2 +- cardano-client-demo/LedgerState.hs | 2 +- 4 files changed, 29 insertions(+), 28 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index d0cbdee762a..14b9c5539b2 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -482,6 +482,7 @@ module Cardano.Api ( LedgerState(..), initialLedgerState, applyBlock, + ValidationMode(..), -- *** Traversing the block chain foldBlocks, diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index 3a59bdfa25d..3f9c4867662 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -20,6 +20,7 @@ module Cardano.Api.LedgerState ) , initialLedgerState , applyBlock + , ValidationMode(..) -- * Traversing the block chain , foldBlocks @@ -150,15 +151,13 @@ applyBlock -- ^ The environment returned by @initialLedgerState@ -> LedgerState -- ^ The current ledger state - -> Bool - -- ^ True to perform validation. If True, `tickThenApply` will be used instead - -- of `tickThenReapply`. + -> ValidationMode -> Block era -- ^ Some block to apply -> Either Text LedgerState -- ^ The new ledger state (or an error). -applyBlock env oldState enableValidation block - = applyBlock' env oldState enableValidation $ case block of +applyBlock env oldState validationMode block + = applyBlock' env oldState validationMode $ case block of ByronBlock byronBlock -> Consensus.BlockByron byronBlock ShelleyBlock blockEra shelleyBlock -> case blockEra of ShelleyBasedEraShelley -> Consensus.BlockShelley shelleyBlock @@ -211,9 +210,7 @@ foldBlocks -- mainnet that should be 21600). -> FilePath -- ^ Path to local cardano-node socket. This is the path specified by the @--socket-path@ command line option when running the node. - -> Bool - -- ^ True to enable validation. Under the hood this will use @applyBlock@ - -- instead of @reapplyBlock@ from the @ApplyBlock@ type class. + -> ValidationMode -> a -- ^ The initial accumulator state. -> (Env -> LedgerState -> BlockInMode CardanoMode -> a -> IO a) @@ -235,7 +232,7 @@ foldBlocks -- truncating the last k blocks before the node's tip. -> ExceptT FoldBlocksError IO a -- ^ The final state -foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation state0 accumulate = do +foldBlocks nodeConfigFilePath cardanoModeParams socketPath validationMode state0 accumulate = do -- NOTE this was originally implemented with a non-pipelined client then -- changed to a pipelined client for a modest speedup: -- * Non-pipelined: 1h 0m 19s @@ -339,7 +336,7 @@ foldBlocks nodeConfigFilePath cardanoModeParams socketPath enableValidation stat (\(_,x,_) -> x) (Seq.lookup 0 knownLedgerStates) ) - enableValidation + validationMode block case newLedgerStateE of Left err -> clientIdle_DoneN n (Just err) @@ -396,11 +393,7 @@ chainSyncClientWithLedgerState => Env -> LedgerState -- ^ Initial ledger state - -> Bool - -- ^ True to enable validation. Under the hood this will use @applyBlock@ - -- instead of @reapplyBlock@ from the @ApplyBlock@ type class. Even when - -- @False@, a fast check of hashes is still done, so applying blocks can still - -- result in an error. + -> ValidationMode -> CS.ChainSyncClient (BlockInMode CardanoMode, Either Text LedgerState) ChainPoint ChainTip @@ -419,7 +412,7 @@ chainSyncClientWithLedgerState a -- ^ A client that acts just like the wrapped client but doesn't require the -- 'LedgerState' annotation on the block type. -chainSyncClientWithLedgerState env ledgerState0 enableValidation (CS.ChainSyncClient clientTop) +chainSyncClientWithLedgerState env ledgerState0 validationMode (CS.ChainSyncClient clientTop) = CS.ChainSyncClient (goClientStIdle initialLedgerStateHistory <$> clientTop) where goClientStIdle @@ -445,7 +438,7 @@ chainSyncClientWithLedgerState env ledgerState0 enableValidation (CS.ChainSyncCl Just (_, Right oldLedgerState, _) -> applyBlock env oldLedgerState - enableValidation + validationMode blk (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode in goClientStIdle history' <$> CS.runChainSyncClient (recvMsgRollForward (blkInMode, newLedgerStateE) tip) @@ -474,7 +467,7 @@ chainSyncClientPipelinedWithLedgerState Monad m => Env -> LedgerState - -> Bool + -> ValidationMode -> CSP.ChainSyncClientPipelined (BlockInMode CardanoMode, Either Text LedgerState) ChainPoint @@ -487,7 +480,7 @@ chainSyncClientPipelinedWithLedgerState ChainTip m a -chainSyncClientPipelinedWithLedgerState env ledgerState0 enableValidation (CSP.ChainSyncClientPipelined clientTop) +chainSyncClientPipelinedWithLedgerState env ledgerState0 validationMode (CSP.ChainSyncClientPipelined clientTop) = CSP.ChainSyncClientPipelined (goClientPipelinedStIdle initialLedgerStateHistory Zero <$> clientTop) where goClientPipelinedStIdle @@ -518,7 +511,7 @@ chainSyncClientPipelinedWithLedgerState env ledgerState0 enableValidation (CSP.C Just (_, Right oldLedgerState, _) -> applyBlock env oldLedgerState - enableValidation + validationMode blk (history', _) = pushLedgerState env history slotNo newLedgerStateE blkInMode in goClientPipelinedStIdle history' n <$> recvMsgRollForward (blkInMode, newLedgerStateE) tip @@ -1024,23 +1017,30 @@ envSecurityParam env = k = HFC.hardForkConsensusConfigK $ envProtocolConfig env +-- | How to do validation when applying a block to a ledger state. +data ValidationMode + -- | Do all validation implied by the ledger layer's 'applyBlock`. + = FullValidation + -- | Only check that the previous hash from the block matches the head hash of + -- the ledger state. + | QuickValidation + -- The function 'tickThenReapply' does zero validation, so add minimal -- validation ('blockPrevHash' matches the tip hash of the 'LedgerState'). This -- was originally for debugging but the check is cheap enough to keep. applyBlock' :: Env -> LedgerState - -> Bool - -- ^ True to validate + -> ValidationMode -> HFC.HardForkBlock (Consensus.CardanoEras Consensus.StandardCrypto) -> Either Text LedgerState -applyBlock' env oldState enableValidation block = do +applyBlock' env oldState validationMode block = do let config = envLedgerConfig env stateOld = clsState oldState - stateNew <- if enableValidation - then tickThenApply config block stateOld - else tickThenReapplyCheckHash config block stateOld + stateNew <- case validationMode of + FullValidation -> tickThenApply config block stateOld + QuickValidation -> tickThenReapplyCheckHash config block stateOld return oldState { clsState = stateNew } -- Like 'Consensus.tickThenReapply' but also checks that the previous hash from diff --git a/cardano-client-demo/ChainSyncClientWithLedgerState.hs b/cardano-client-demo/ChainSyncClientWithLedgerState.hs index aab1a7aeb33..05458023c81 100644 --- a/cardano-client-demo/ChainSyncClientWithLedgerState.hs +++ b/cardano-client-demo/ChainSyncClientWithLedgerState.hs @@ -58,7 +58,7 @@ main = do let client = chainSyncClientWithLedgerState env initialLedgerState - True + FullValidation chainSyncClient protocols :: LocalNodeClientProtocolsInMode CardanoMode diff --git a/cardano-client-demo/LedgerState.hs b/cardano-client-demo/LedgerState.hs index b4ea02b61d6..8d1b95f3203 100644 --- a/cardano-client-demo/LedgerState.hs +++ b/cardano-client-demo/LedgerState.hs @@ -41,7 +41,7 @@ main = do configFilePath (CardanoModeParams (EpochSlots byronSlotLength)) socketPath - True -- enable validation? + FullValidation (0 :: Int) -- We just use a count of the blocks as the current state (\_env !ledgerState