added headerValidationDelay to PraosConfig

input-output-hk · Nov 7, 2024 · 4e3ba8c · 4e3ba8c
1 parent 8233dd4
commit 4e3ba8c
Show file tree

Hide file tree

Showing 7 changed files with 40 additions and 18 deletions.
diff --git a/simulation/src/PraosProtocol/ChainSync.hs b/simulation/src/PraosProtocol/ChainSync.hs
@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -150,18 +151,24 @@ newtype ChainConsumerState m = ChainConsumerState
   { chainVar :: TVar m (Chain BlockHeader)
   }
 
-runChainConsumer :: MonadSTM m => Chan m ChainSyncMessage -> ChainConsumerState m -> m ()
-runChainConsumer chan st =
-  void $ runPeerWithDriver (chanDriver decideChainSyncState chan) (chainConsumer st)
+runChainConsumer ::
+  (MonadSTM m, MonadDelay m) =>
+  PraosConfig ->
+  Chan m ChainSyncMessage ->
+  ChainConsumerState m ->
+  m ()
+runChainConsumer cfg chan st =
+  void $ runPeerWithDriver (chanDriver decideChainSyncState chan) (chainConsumer cfg st)
 
 type ChainConsumer st m a = TC.Client ChainSyncState 'NonPipelined st m a
 
 chainConsumer ::
   forall m.
-  MonadSTM m =>
+  (MonadSTM m, MonadDelay m) =>
+  PraosConfig ->
   ChainConsumerState m ->
   ChainConsumer 'StIdle m ()
-chainConsumer (ChainConsumerState hchainVar) = idle True
+chainConsumer cfg (ChainConsumerState hchainVar) = idle True
  where
   -- NOTE: The specification says to do an initial intersection with
   --       exponentially spaced points, and perform binary search to
@@ -194,9 +201,11 @@ chainConsumer (ChainConsumerState hchainVar) = idle True
 
   rollForward :: BlockHeader -> ChainConsumer 'StIdle m ()
   rollForward header =
-    TC.Effect $ atomically $ do
-      modifyTVar' hchainVar $ Chain.addBlock header
-      return $ idle False
+    TC.Effect $ do
+      threadDelaySI (cfg.headerValidationDelay header)
+      atomically $ do
+        modifyTVar' hchainVar $ Chain.addBlock header
+        return $ idle False
 
   rollBackward :: Point BlockHeader -> ChainConsumer 'StIdle m ()
   rollBackward hpoint =

diff --git a/simulation/src/PraosProtocol/Common.hs b/simulation/src/PraosProtocol/Common.hs
@@ -34,6 +34,7 @@ module PraosProtocol.Common (
   MessageSize (..),
   kilobytes,
   module TimeCompat,
+  defaultPraosConfig,
 ) where
 
 import Control.Concurrent.Class.MonadSTM (
@@ -145,10 +146,21 @@ data PraosNodeEvent
   deriving (Show)
 
 data PraosConfig = PraosConfig
-  { slotConfig :: SlotConfig
-  , blockValidationDelay :: Block -> DiffTime
+  { slotConfig :: !SlotConfig
+  , blockValidationDelay :: !(Block -> DiffTime)
+  , headerValidationDelay :: !(BlockHeader -> DiffTime)
   }
 
+defaultPraosConfig :: MonadTime m => m PraosConfig
+defaultPraosConfig = do
+  slotConfig <- slotConfigFromNow
+  return
+    PraosConfig
+      { slotConfig
+      , blockValidationDelay = const 0.1
+      , headerValidationDelay = const 0.005
+      }
+
 --------------------------------
 ---- Common Utility Types
 --------------------------------

diff --git a/simulation/src/PraosProtocol/ExamplesPraosP2P.hs b/simulation/src/PraosProtocol/ExamplesPraosP2P.hs
@@ -215,6 +215,7 @@ example1Trace rng0 blockInterval p2pTopography =
               PraosConfig
                 { slotConfig
                 , blockValidationDelay = const 0.1 -- 100ms
+                , headerValidationDelay = const 0.005 -- 5ms
                 }
           , blockMarker = BS8.pack $ show nid ++ ": "
           , chain = Genesis
@@ -297,6 +298,7 @@ example2 =
                   PraosConfig
                     { slotConfig
                     , blockValidationDelay = const 0.1 -- 100ms
+                    , headerValidationDelay = const 0.005 -- 5ms
                     }
               , chain = Genesis
               , blockMarker = BS8.pack $ show nid ++ ": "

diff --git a/simulation/src/PraosProtocol/PraosNode.hs b/simulation/src/PraosProtocol/PraosNode.hs
@@ -67,7 +67,7 @@ runPeer ::
 runPeer tracer cfg st peerId chan = do
   let chainConsumerState = st.chainSyncConsumerStates Map.! peerId
   let blockFetchConsumerState = initBlockFetchConsumerStateForPeerId tracer peerId st.blockFetchControllerState
-  [ Concurrently $ runChainConsumer (protocolChainSync chan) chainConsumerState
+  [ Concurrently $ runChainConsumer cfg (protocolChainSync chan) chainConsumerState
     , Concurrently $ runBlockFetchConsumer tracer cfg (protocolBlockFetch chan) blockFetchConsumerState
     ]
 

diff --git a/simulation/src/PraosProtocol/SimBlockFetch.hs b/simulation/src/PraosProtocol/SimBlockFetch.hs
@@ -69,8 +69,7 @@ traceRelayLink1 tcpprops =
               [(NodeId 0, NodeId 1), (NodeId 1, NodeId 0)]
           )
       (inChan, outChan) <- newConnectionTCP (linkTracer na nb) tcpprops
-      slotConfig <- slotConfigFromNow
-      let praosConfig = PraosConfig{slotConfig, blockValidationDelay = const 0.1}
+      praosConfig <- defaultPraosConfig
       concurrently_
         (nodeA praosConfig outChan)
         (nodeB inChan)

diff --git a/simulation/src/PraosProtocol/SimChainSync.hs b/simulation/src/PraosProtocol/SimChainSync.hs
@@ -81,14 +81,15 @@ traceRelayLink1 tcpprops =
               [(NodeId 0, NodeId 1), (NodeId 1, NodeId 0)]
           )
       (inChan, outChan) <- newConnectionTCP (linkTracer na nb) tcpprops
+      praosConfig <- defaultPraosConfig
       concurrently_
-        (consumerNode inChan)
+        (consumerNode praosConfig inChan)
         (producerNode outChan)
       return ()
  where
-  consumerNode chan = do
+  consumerNode cfg chan = do
     st <- ChainConsumerState <$> newTVarIO Chain.Genesis
-    runChainConsumer chan st
+    runChainConsumer cfg chan st
   producerNode chan = do
     let chain = mkChainSimple $ replicate 10 (BlockBody $ BS.replicate 100 0)
     let (cps, fId) = initFollower GenesisPoint $ initChainProducerState chain

diff --git a/simulation/src/PraosProtocol/SimPraos.hs b/simulation/src/PraosProtocol/SimPraos.hs
@@ -68,8 +68,7 @@ traceRelayLink1 tcpprops =
           ( Set.fromList
               [(nodeA, nodeB), (nodeB, nodeA)]
           )
-      slotConfig <- slotConfigFromNow
-      let praosConfig = PraosConfig{slotConfig, blockValidationDelay = const 0.1}
+      praosConfig <- defaultPraosConfig
       let chainA = mkChainSimple $ [BlockBody (BS.singleton word) | word <- [0 .. 9]]
       let chainB = Genesis
       (pA, cB) <- newConnectionBundleTCP (praosTracer nodeA nodeB) tcpprops