From 5a88f27f355c01f0de6133de6ddfc41d6139c8f9 Mon Sep 17 00:00:00 2001 From: euonymos Date: Wed, 20 Nov 2024 11:26:19 -0600 Subject: [PATCH 1/2] fix: last never-forking era --- emulator/src/Cardano/Node/Socket/Emulator/Query.hs | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/emulator/src/Cardano/Node/Socket/Emulator/Query.hs b/emulator/src/Cardano/Node/Socket/Emulator/Query.hs index ea55f1f..60584c1 100644 --- a/emulator/src/Cardano/Node/Socket/Emulator/Query.hs +++ b/emulator/src/Cardano/Node/Socket/Emulator/Query.hs @@ -57,6 +57,7 @@ import Ouroboros.Consensus.HardFork.History.Summary ( Bound (..), EraSummary (..), Summary (..), + neverForksSummary, ) import Ouroboros.Consensus.Ledger.Query (Query (..)) import Ouroboros.Consensus.Protocol.Praos (Praos) @@ -176,7 +177,7 @@ emulatorEraHistory params = C.EraHistory (Ouroboros.mkInterpreter $ Ouroboros.su lastS = Ouroboros.nonEmptyHead $ Ouroboros.getSummary $ - skipSummary lastEndBound emulatorEpochSize (slotLength params) emulatorGenesisWindow + neverForksSummary emulatorEpochSize (slotLength params) emulatorGenesisWindow list = Ouroboros.Exactly $ K one :* K one :* K one :* K one :* K one :* K one :* K lastS :* Nil -- | 'Summary' for a ledger that never forks @@ -196,14 +197,6 @@ skipSummary endBound epochSize slotLen genesisWindow = } } -lastEndBound :: Bound -lastEndBound = - Bound - { boundTime = RelativeTime 50 - , boundSlot = SlotNo 1 - , boundEpoch = EpochNo 500 - } - emulatorGenesisWindow :: GenesisWindow emulatorGenesisWindow = GenesisWindow window where From b80892e830d334f7b2bd4afaf13191af6fbe2c2c Mon Sep 17 00:00:00 2001 From: euonymos Date: Wed, 20 Nov 2024 21:08:43 -0600 Subject: [PATCH 2/2] feat: implement getChainPoint query --- .../src/Cardano/Node/Socket/Emulator/Query.hs | 11 +++++--- .../Cardano/Node/Socket/Emulator/Server.hs | 20 +++++++++++---- .../src/Cardano/Node/Socket/Emulator/Types.hs | 25 ++++++++++++++++++- 3 files changed, 47 insertions(+), 9 deletions(-) diff --git a/emulator/src/Cardano/Node/Socket/Emulator/Query.hs b/emulator/src/Cardano/Node/Socket/Emulator/Query.hs index 60584c1..a9333bd 100644 --- a/emulator/src/Cardano/Node/Socket/Emulator/Query.hs +++ b/emulator/src/Cardano/Node/Socket/Emulator/Query.hs @@ -18,13 +18,14 @@ import Cardano.Node.Socket.Emulator.Types ( AppState (..), EmulatorMsg, clbState, + getChainPointTime, getTip, runClbInIO', socketEmulatorState, ) import Cardano.Slotting.EpochInfo (epochInfoEpoch) import Cardano.Slotting.Slot (WithOrigin (..)) -import Cardano.Slotting.Time (RelativeTime (RelativeTime), SlotLength, mkSlotLength) +import Cardano.Slotting.Time (SlotLength, mkSlotLength) import Clb (ClbT, chainState, clbConfig, getClbConfig, getCurrentSlot, getGlobals, getStakePools, getUtxosAt) import Clb qualified as E import Clb.Config (ClbConfig (..)) @@ -47,7 +48,7 @@ import Data.SOP.Counting qualified as Ouroboros import Data.SOP.NonEmpty qualified as Ouroboros import Data.SOP.Strict (NP (Nil, (:*)), NS (S, Z)) import Data.Set qualified as Set -import Ouroboros.Consensus.Block (EpochNo (EpochNo), EpochSize, GenesisWindow (..), SlotNo (SlotNo)) +import Ouroboros.Consensus.Block (EpochSize, GenesisWindow (..)) import Ouroboros.Consensus.Cardano.Block (BlockQuery (..), CardanoBlock) import Ouroboros.Consensus.HardFork.Combinator (QueryHardFork (..)) import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus @@ -123,7 +124,11 @@ handleQueryConwayEra trace state q = let ret = At curBlockNo logInfo $ "Tip is: " <> show ret pure ret - GetChainPoint -> printError "Unimplemented GetChainPoint was received" + query@GetChainPoint -> do + logInfo $ "Query was received (5): " ++ show query + ret <- getChainPointTime state + logInfo $ "Chain point time is: " <> show ret + pure ret queryIfCurrentConway :: (block ~ Shelley.ShelleyBlock (Praos StandardCrypto) (ConwayEra StandardCrypto)) => diff --git a/emulator/src/Cardano/Node/Socket/Emulator/Server.hs b/emulator/src/Cardano/Node/Socket/Emulator/Server.hs index b6d6cc9..5f1d454 100644 --- a/emulator/src/Cardano/Node/Socket/Emulator/Server.hs +++ b/emulator/src/Cardano/Node/Socket/Emulator/Server.hs @@ -88,11 +88,11 @@ import Cardano.Node.Socket.Emulator.Types ( txSubmissionCodec, ) import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..)) -import Clb (ValidationResult (..)) +import Clb (ValidationResult (..), chainState) import Clb qualified as E import Clb.EmulatedLedgerState qualified as E import Clb.Era (IsCardanoLedgerEra) -import Clb.TimeSlot (Slot) +import Clb.TimeSlot (Slot, fromSlot) import Clb.Tx (pattern CardanoEmulatorEraTx) import Clb.Tx qualified as E (getEmulatorEraTx) import Control.Monad.Freer.Extras (logInfo) @@ -280,6 +280,14 @@ handleCommand trace CommandChannel {ccCommand, ccResponse} mvAppState = do atomically (readTQueue ccCommand) >>= \case ModifySlot f -> do s <- runClb trace mvAppState (E.modifySlot f) + -- FIXME: This is unfortunate we have to look after two ledger envs. + liftIO $ modifyMVar mvAppState $ \appState -> do + let newState = + over + (socketEmulatorState . cachedState) + (E.setSlot $ fromSlot s) + appState + pure (newState, ()) atomically $ writeTQueue ccResponse (SlotChanged s) TryProduceBlock -> do @@ -318,10 +326,13 @@ processBlock trace mvAppState = logInfo @EmulatorMsg $ "Block is: " <> show newBlock logInfo @EmulatorMsg "Updating chain state..." let s = appState ^. (socketEmulatorState . clbState) + let cachedState' = appState ^. (socketEmulatorState . cachedState) + let currentSlot = + E.getSlot (appState ^. socketEmulatorState . clbState . chainState) (_, s') <- runStateT ( modify $ - over E.chainState (const $ appState ^. (socketEmulatorState . cachedState)) + over E.chainState (const (E.setSlot currentSlot cachedState')) . over E.knownDatums (`M.union` blockDatums) ) s @@ -489,8 +500,7 @@ nextState :: (m (ServerStNext block (Point block) Tip m ())) ) nextState localChannel@(LocalChannel channel') = do - chainState <- ask - tip' <- getTip chainState + tip' <- getTip =<< ask (liftIO . atomically $ tryReadTChan channel') >>= \case Nothing -> do Right . pure <$> do diff --git a/emulator/src/Cardano/Node/Socket/Emulator/Types.hs b/emulator/src/Cardano/Node/Socket/Emulator/Types.hs index b5f1f8e..87d20d2 100644 --- a/emulator/src/Cardano/Node/Socket/Emulator/Types.hs +++ b/emulator/src/Cardano/Node/Socket/Emulator/Types.hs @@ -9,6 +9,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -45,6 +46,7 @@ import Clb ( ClbT, EmulatedLedgerState, OnChainTx (..), + chainState, ) import Clb qualified as E import Clb.EmulatedLedgerState qualified as E (getSlot) @@ -80,6 +82,7 @@ import Data.Foldable (toList, traverse_) import Data.Functor ((<&>)) import Data.ListMap qualified as LM import Data.Map qualified as Map +import Data.Maybe (listToMaybe) import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Data.Time.Format.ISO8601 qualified as F @@ -106,7 +109,11 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion ( import Ouroboros.Consensus.Protocol.Praos.Header qualified as Praos import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import Ouroboros.Consensus.Shelley.Ledger qualified as Shelley -import Ouroboros.Network.Block (Point) +import Ouroboros.Network.Block ( + Point, + pattern BlockPoint, + pattern GenesisPoint, + ) import Ouroboros.Network.Block qualified as Ouroboros import Ouroboros.Network.NodeToClient ( NodeToClientVersion (..), @@ -255,6 +262,22 @@ getChannel mv = liftIO (readMVar mv) <&> view (socketEmulatorState . channel) getTip :: (MonadIO m) => MVar (AppState era) -> m Tip getTip mv = liftIO (readMVar mv) <&> view (socketEmulatorState . tip) +-- Get so-called "chain point" time +getChainPointTime :: + ( MonadIO m + , block ~ CardanoBlock StandardCrypto + , CBOR.ToCBOR (Core.Tx (CardanoLedgerEra era)) + ) => + MVar (AppState era) -> + m (Point block) +getChainPointTime mv = do + st <- liftIO (readMVar mv) + case listToMaybe $ st ^. socketEmulatorState . chainNewestFirst of + Just newest -> do + let slot = E.getSlot $ st ^. socketEmulatorState . clbState . chainState + pure $ BlockPoint slot (coerce $ blockId newest) + Nothing -> pure GenesisPoint + -- Set the new tip setTip :: (MonadIO m, CBOR.ToCBOR (Core.Tx (CardanoLedgerEra era))) => MVar (AppState era) -> Block era -> m () setTip mv block = liftIO $ modifyMVar_ mv $ \oldState -> do