diff --git a/analysis/sims/trace-processor/src/Leios/Tracing/Cpu.hs b/analysis/sims/trace-processor/src/Leios/Tracing/Cpu.hs index 4fcc30059..a3d9a7b5c 100644 --- a/analysis/sims/trace-processor/src/Leios/Tracing/Cpu.hs +++ b/analysis/sims/trace-processor/src/Leios/Tracing/Cpu.hs @@ -21,8 +21,7 @@ import System.IO (IOMode (WriteMode), hClose, hPutStrLn, openFile) import qualified Data.Text as T (unpack) -data ItemKey - = ItemKey +data ItemKey = ItemKey { slot :: Int , node :: Text , task :: Text diff --git a/analysis/sims/trace-processor/src/Leios/Tracing/Lifecycle.hs b/analysis/sims/trace-processor/src/Leios/Tracing/Lifecycle.hs index 167e61134..8b695ce8f 100644 --- a/analysis/sims/trace-processor/src/Leios/Tracing/Lifecycle.hs +++ b/analysis/sims/trace-processor/src/Leios/Tracing/Lifecycle.hs @@ -14,7 +14,7 @@ import Control.Concurrent.MVar (MVar, takeMVar) import Control.Monad ((<=<)) import Control.Monad.IO.Class (liftIO) import Control.Monad.State.Strict (StateT, execStateT, gets, modify') -import Data.Aeson (Value (Object), withObject, (.:)) +import Data.Aeson (Value (Object), withObject, (.:), (.:?)) import Data.Aeson.Types (Parser, parseMaybe) import Data.Function (on) import Data.List (intercalate) @@ -28,15 +28,13 @@ import qualified Data.Map.Strict as M (elems, fromList, insertWith, restrictKeys import qualified Data.Set as S (map, singleton) import qualified Data.Text as T (unpack) -data ItemKey - = ItemKey +data ItemKey = ItemKey { kind :: Text , item :: Text } deriving (Eq, Ord, Show) -data ItemInfo - = ItemInfo +data ItemInfo = ItemInfo { size :: Minimum Int , references :: Sum Int , created :: Minimum Double @@ -137,7 +135,7 @@ parseMessage "EBGenerated" item created = do size <- message .: "size_bytes" let destination = mempty{toEB = created, inEBs = S.singleton item, references = Sum 1} - txs <- mapM (fmap ((,destination) . ItemKey "TX") . (.: "id")) =<< message .: "transactions" + txs <- maybe (pure []) (mapM (fmap ((,destination) . ItemKey "TX") . (.: "id"))) =<< message .:? "transactions" ibs <- mapM (fmap ((,destination) . ItemKey "IB") . (.: "id")) =<< message .: "input_blocks" ebs <- mapM (fmap ((,destination) . ItemKey "EB") . (.: "id")) =<< message .: "endorser_blocks" pure (ItemKey{kind = "EB", item}, mempty{size, created}, M.fromList $ txs <> ibs <> ebs) @@ -150,7 +148,7 @@ parseMessage "RBGenerated" item created = (pure mempty) (fmap (pure . (,mempty{toRB = created, references = Sum 1}) . ItemKey "EB") . (.: "id") <=< (.: "eb")) =<< message .: "endorsement" - txs <- fmap ((,mempty{inRB = created, references = Sum 1}) . ItemKey "TX") <$> message .: "transactions" + txs <- maybe [] (fmap ((,mempty{inRB = created, references = Sum 1}) . ItemKey "TX")) <$> message .: "transactions" pure (ItemKey{kind = "RB", item}, mempty{size, created}, M.fromList $ ebs <> txs) parseMessage _ _ _ = const $ fail "Ignore" diff --git a/analysis/sims/trace-processor/src/Leios/Tracing/Receipt.hs b/analysis/sims/trace-processor/src/Leios/Tracing/Receipt.hs index a5932dc36..993cf04d1 100644 --- a/analysis/sims/trace-processor/src/Leios/Tracing/Receipt.hs +++ b/analysis/sims/trace-processor/src/Leios/Tracing/Receipt.hs @@ -26,15 +26,13 @@ import System.IO (IOMode (WriteMode), hClose, hPutStrLn, openFile) import qualified Data.Map.Strict as M (insertWith, (!)) import qualified Data.Text as T (unpack) -data ItemKey - = ItemKey +data ItemKey = ItemKey { kind :: Text , item :: Text } deriving (Eq, Ord, Show) -data ItemInfo - = ItemInfo +data ItemInfo = ItemInfo { producer :: Text , sent :: Minimum Double , size :: Maximum Double diff --git a/analysis/sims/trace-processor/src/Leios/Tracing/Resource.hs b/analysis/sims/trace-processor/src/Leios/Tracing/Resource.hs index 87d955ddd..4e12e820b 100644 --- a/analysis/sims/trace-processor/src/Leios/Tracing/Resource.hs +++ b/analysis/sims/trace-processor/src/Leios/Tracing/Resource.hs @@ -25,15 +25,13 @@ import Leios.Tracing.Util (Maximum (..)) import qualified Data.Map.Strict as M (insertWith, map, mapKeysWith, toList) import qualified Data.Text as T (unpack) -data ItemKey' - = ItemKey' +data ItemKey' = ItemKey' { slot' :: Int , node' :: Text } deriving (Eq, Ord, Show) -data ItemInfo' - = ItemInfo' +data ItemInfo' = ItemInfo' { egress' :: Sum Double , disk' :: Sum Double , cpu' :: Sum Double @@ -58,14 +56,12 @@ instance Monoid ItemInfo' where type Index' = Map ItemKey' ItemInfo' -newtype ItemKey - = ItemKey +newtype ItemKey = ItemKey { node :: Text } deriving (Eq, Ord, Show) -data ItemInfo - = ItemInfo +data ItemInfo = ItemInfo { egress :: Sum Double , disk :: Sum Double , totalCpu :: Sum Double diff --git a/data/simulation/config.default.yaml b/data/simulation/config.default.yaml index ebe7faeec..3c1770d7d 100644 --- a/data/simulation/config.default.yaml +++ b/data/simulation/config.default.yaml @@ -177,6 +177,9 @@ eb-max-age-for-relay-slots: 40 # Only relevant when running with the "full-without-ibs" variant. eb-referenced-txs-max-size-bytes: 16384000 +# For Linear Leios +eb-body-avg-size-bytes: 2500000 + ################################################################################ # Vote Configuration ################################################################################ diff --git a/leios-trace-hs/src/LeiosConfig.hs b/leios-trace-hs/src/LeiosConfig.hs index c0a2902e1..f9246cc7b 100644 --- a/leios-trace-hs/src/LeiosConfig.hs +++ b/leios-trace-hs/src/LeiosConfig.hs @@ -85,7 +85,7 @@ instance Default CleanupPolicies where allCleanupPolicies :: CleanupPolicies allCleanupPolicies = CleanupPolicies $ Set.fromList [minBound .. maxBound] -data LeiosVariant = Short | Full +data LeiosVariant = Short | Full | Linear deriving (Show, Eq, Generic) data Config = Config @@ -97,6 +97,8 @@ data Config = Config , simulateTransactions :: Bool , leiosStageLengthSlots :: Word , leiosStageActiveVotingSlots :: Word + , linearVoteStageLengthSlots :: Word + , linearDiffuseStageLengthSlots :: Word , leiosVoteSendRecvStages :: Bool , leiosVariant :: LeiosVariant , leiosLateIbInclusion :: Bool @@ -132,6 +134,9 @@ data Config = Config , ebValidationCpuTimeMs :: DurationMs , ebSizeBytesConstant :: SizeBytes , ebSizeBytesPerIb :: SizeBytes + , ebBodyAvgSizeBytes :: SizeBytes + , ebBodyValidationCpuTimeMsConstant :: DurationMs + , ebBodyValidationCpuTimeMsPerByte :: DurationMs , ebDiffusionStrategy :: DiffusionStrategy , ebDiffusionMaxWindowSize :: Word16 , ebDiffusionMaxHeadersToRequest :: Word16 @@ -141,6 +146,7 @@ data Config = Config , voteGenerationProbability :: Double , voteGenerationCpuTimeMsConstant :: DurationMs , voteGenerationCpuTimeMsPerIb :: DurationMs + , voteGenerationCpuTimeMsPerTx :: DurationMs , voteValidationCpuTimeMs :: DurationMs , voteThreshold :: Word , voteBundleSizeBytesConstant :: SizeBytes @@ -170,6 +176,8 @@ instance Default Config where , simulateTransactions = True , leiosStageLengthSlots = 20 , leiosStageActiveVotingSlots = 1 + , linearVoteStageLengthSlots = 5 + , linearDiffuseStageLengthSlots = 5 , leiosVoteSendRecvStages = False , leiosVariant = Short , leiosLateIbInclusion = True @@ -205,6 +213,9 @@ instance Default Config where , ebValidationCpuTimeMs = 1.0 , ebSizeBytesConstant = 240 , ebSizeBytesPerIb = 32 + , ebBodyAvgSizeBytes = 2500000 + , ebBodyValidationCpuTimeMsConstant = 50.0 + , ebBodyValidationCpuTimeMsPerByte = 0.0005 , ebDiffusionStrategy = PeerOrder , ebDiffusionMaxWindowSize = 100 , ebDiffusionMaxHeadersToRequest = 100 @@ -214,6 +225,7 @@ instance Default Config where , voteGenerationProbability = 500.0 , voteGenerationCpuTimeMsConstant = 0.164 , voteGenerationCpuTimeMsPerIb = 0.0 + , voteGenerationCpuTimeMsPerTx = 0.0 , voteValidationCpuTimeMs = 0.816 , voteThreshold = 300 , voteBundleSizeBytesConstant = 0 @@ -282,6 +294,9 @@ configToKVsWith getter cfg = , get @"ebValidationCpuTimeMs" getter cfg , get @"ebSizeBytesConstant" getter cfg , get @"ebSizeBytesPerIb" getter cfg + , get @"ebBodyAvgSizeBytes" getter cfg + , get @"ebBodyValidationCpuTimeMsConstant" getter cfg + , get @"ebBodyValidationCpuTimeMsPerByte" getter cfg , get @"ebDiffusionStrategy" getter cfg , get @"ebDiffusionMaxWindowSize" getter cfg , get @"ebDiffusionMaxHeadersToRequest" getter cfg @@ -291,6 +306,7 @@ configToKVsWith getter cfg = , get @"voteGenerationProbability" getter cfg , get @"voteGenerationCpuTimeMsConstant" getter cfg , get @"voteGenerationCpuTimeMsPerIb" getter cfg + , get @"voteGenerationCpuTimeMsPerTx" getter cfg , get @"voteValidationCpuTimeMs" getter cfg , get @"voteThreshold" getter cfg , get @"voteBundleSizeBytesConstant" getter cfg @@ -339,6 +355,8 @@ instance FromJSON Config where leiosStageLengthSlots <- parseFieldOrDefault @Config @"leiosStageLengthSlots" obj leiosStageActiveVotingSlots <- parseFieldOrDefault @Config @"leiosStageActiveVotingSlots" obj leiosVoteSendRecvStages <- parseFieldOrDefault @Config @"leiosVoteSendRecvStages" obj + linearVoteStageLengthSlots <- parseFieldOrDefault @Config @"linearVoteStageLengthSlots" obj + linearDiffuseStageLengthSlots <- parseFieldOrDefault @Config @"linearDiffuseStageLengthSlots" obj txGenerationDistribution <- parseFieldOrDefault @Config @"txGenerationDistribution" obj txSizeBytesDistribution <- parseFieldOrDefault @Config @"txSizeBytesDistribution" obj txValidationCpuTimeMs <- parseFieldOrDefault @Config @"txValidationCpuTimeMs" obj @@ -369,6 +387,9 @@ instance FromJSON Config where ebValidationCpuTimeMs <- parseFieldOrDefault @Config @"ebValidationCpuTimeMs" obj ebSizeBytesConstant <- parseFieldOrDefault @Config @"ebSizeBytesConstant" obj ebSizeBytesPerIb <- parseFieldOrDefault @Config @"ebSizeBytesPerIb" obj + ebBodyAvgSizeBytes <- parseFieldOrDefault @Config @"ebBodyAvgSizeBytes" obj + ebBodyValidationCpuTimeMsConstant <- parseFieldOrDefault @Config @"ebBodyValidationCpuTimeMsConstant" obj + ebBodyValidationCpuTimeMsPerByte <- parseFieldOrDefault @Config @"ebBodyValidationCpuTimeMsPerByte" obj ebDiffusionStrategy <- parseFieldOrDefault @Config @"ebDiffusionStrategy" obj ebDiffusionMaxWindowSize <- parseFieldOrDefault @Config @"ebDiffusionMaxWindowSize" obj ebDiffusionMaxHeadersToRequest <- parseFieldOrDefault @Config @"ebDiffusionMaxHeadersToRequest" obj @@ -378,6 +399,7 @@ instance FromJSON Config where voteGenerationProbability <- parseFieldOrDefault @Config @"voteGenerationProbability" obj voteGenerationCpuTimeMsConstant <- parseFieldOrDefault @Config @"voteGenerationCpuTimeMsConstant" obj voteGenerationCpuTimeMsPerIb <- parseFieldOrDefault @Config @"voteGenerationCpuTimeMsPerIb" obj + voteGenerationCpuTimeMsPerTx <- parseFieldOrDefault @Config @"voteGenerationCpuTimeMsPerTx" obj voteValidationCpuTimeMs <- parseFieldOrDefault @Config @"voteValidationCpuTimeMs" obj voteThreshold <- parseFieldOrDefault @Config @"voteThreshold" obj voteBundleSizeBytesConstant <- parseFieldOrDefault @Config @"voteBundleSizeBytesConstant" obj diff --git a/leios-trace-verifier/hs-src/test/Spec/Scenario.hs b/leios-trace-verifier/hs-src/test/Spec/Scenario.hs index 0fa8deb15..cc0e6801b 100644 --- a/leios-trace-verifier/hs-src/test/Spec/Scenario.hs +++ b/leios-trace-verifier/hs-src/test/Spec/Scenario.hs @@ -11,6 +11,7 @@ module Spec.Scenario ( ) where import Control.Monad (mzero) +import Data.Default (Default (..)) import LeiosConfig (CleanupPolicies (..), CleanupPolicy (..), Config (..), DiffusionStrategy (..), Distribution (..), LeiosVariant (..), RelayStrategy (..)) import LeiosTopology (BandwidthBps (..), CpuCoreCount (..), LinkInfo (..), Location (..), LocationKind (..), Node (..), NodeInfo (..), NodeName (..), Topology (..)) import LeiosTypes (Point (..)) @@ -19,7 +20,7 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S config :: Config -config = Config{relayStrategy = RequestFromFirst, tcpCongestionControl = True, multiplexMiniProtocols = True, treatBlocksAsFull = False, cleanupPolicies = CleanupPolicies (S.fromList [CleanupExpiredVote]), simulateTransactions = True, leiosStageLengthSlots = 2, leiosStageActiveVotingSlots = 1, leiosVoteSendRecvStages = False, leiosVariant = Short, leiosLateIbInclusion = False, leiosHeaderDiffusionTimeMs = 1000.0, praosChainQuality = 20.0, txGenerationDistribution = Exp{lambda = 0.85, scale = pure 1000.0}, txSizeBytesDistribution = LogNormal{mu = 6.833, sigma = 1.127}, txValidationCpuTimeMs = 1.5, txMaxSizeBytes = 16384, rbGenerationProbability = 5.0e-2, rbGenerationCpuTimeMs = 1.0, rbHeadValidationCpuTimeMs = 1.0, rbHeadSizeBytes = 1024, rbBodyMaxSizeBytes = 90112, rbBodyLegacyPraosPayloadValidationCpuTimeMsConstant = 50.0, rbBodyLegacyPraosPayloadValidationCpuTimeMsPerByte = 5.0e-4, rbBodyLegacyPraosPayloadAvgSizeBytes = 0, ibGenerationProbability = 5.0, ibGenerationCpuTimeMs = 130.0, ibHeadSizeBytes = 304, ibHeadValidationCpuTimeMs = 1.0, ibBodyValidationCpuTimeMsConstant = 50.0, ibBodyValidationCpuTimeMsPerByte = 5.0e-4, ibBodyMaxSizeBytes = 327680, ibBodyAvgSizeBytes = 98304, ibDiffusionStrategy = FreshestFirst, ibDiffusionMaxWindowSize = 100, ibDiffusionMaxHeadersToRequest = 100, ibDiffusionMaxBodiesToRequest = 1, ibShards = 50, ebGenerationProbability = 1.5, ebGenerationCpuTimeMs = 75.0, ebValidationCpuTimeMs = 1.0, ebSizeBytesConstant = 240, ebSizeBytesPerIb = 32, ebDiffusionStrategy = PeerOrder, ebDiffusionMaxWindowSize = 100, ebDiffusionMaxHeadersToRequest = 100, ebDiffusionMaxBodiesToRequest = 1, ebMaxAgeSlots = 100, ebMaxAgeForRelaySlots = 40, voteGenerationProbability = 500.0, voteGenerationCpuTimeMsConstant = 0.164, voteGenerationCpuTimeMsPerIb = 0.0, voteValidationCpuTimeMs = 0.816, voteThreshold = 300, voteBundleSizeBytesConstant = 0, voteBundleSizeBytesPerEb = 105, voteDiffusionStrategy = PeerOrder, voteDiffusionMaxWindowSize = 100, voteDiffusionMaxHeadersToRequest = 100, voteDiffusionMaxBodiesToRequest = 1, certGenerationCpuTimeMsConstant = 90.0, certGenerationCpuTimeMsPerNode = 0.0, certValidationCpuTimeMsConstant = 130.0, certValidationCpuTimeMsPerNode = 0.0, certSizeBytesConstant = 7168, certSizeBytesPerNode = 0} +config = def{relayStrategy = RequestFromFirst, tcpCongestionControl = True, multiplexMiniProtocols = True, treatBlocksAsFull = False, cleanupPolicies = CleanupPolicies (S.fromList [CleanupExpiredVote]), simulateTransactions = True, leiosStageLengthSlots = 2, leiosStageActiveVotingSlots = 1, leiosVoteSendRecvStages = False, leiosVariant = Short, leiosLateIbInclusion = False, leiosHeaderDiffusionTimeMs = 1000.0, praosChainQuality = 20.0, txGenerationDistribution = Exp{lambda = 0.85, scale = pure 1000.0}, txSizeBytesDistribution = LogNormal{mu = 6.833, sigma = 1.127}, txValidationCpuTimeMs = 1.5, txMaxSizeBytes = 16384, rbGenerationProbability = 5.0e-2, rbGenerationCpuTimeMs = 1.0, rbHeadValidationCpuTimeMs = 1.0, rbHeadSizeBytes = 1024, rbBodyMaxSizeBytes = 90112, rbBodyLegacyPraosPayloadValidationCpuTimeMsConstant = 50.0, rbBodyLegacyPraosPayloadValidationCpuTimeMsPerByte = 5.0e-4, rbBodyLegacyPraosPayloadAvgSizeBytes = 0, ibGenerationProbability = 5.0, ibGenerationCpuTimeMs = 130.0, ibHeadSizeBytes = 304, ibHeadValidationCpuTimeMs = 1.0, ibBodyValidationCpuTimeMsConstant = 50.0, ibBodyValidationCpuTimeMsPerByte = 5.0e-4, ibBodyMaxSizeBytes = 327680, ibBodyAvgSizeBytes = 98304, ibDiffusionStrategy = FreshestFirst, ibDiffusionMaxWindowSize = 100, ibDiffusionMaxHeadersToRequest = 100, ibDiffusionMaxBodiesToRequest = 1, ibShards = 50, ebGenerationProbability = 1.5, ebGenerationCpuTimeMs = 75.0, ebValidationCpuTimeMs = 1.0, ebSizeBytesConstant = 240, ebSizeBytesPerIb = 32, ebDiffusionStrategy = PeerOrder, ebDiffusionMaxWindowSize = 100, ebDiffusionMaxHeadersToRequest = 100, ebDiffusionMaxBodiesToRequest = 1, ebMaxAgeSlots = 100, ebMaxAgeForRelaySlots = 40, voteGenerationProbability = 500.0, voteGenerationCpuTimeMsConstant = 0.164, voteGenerationCpuTimeMsPerIb = 0.0, voteValidationCpuTimeMs = 0.816, voteThreshold = 300, voteBundleSizeBytesConstant = 0, voteBundleSizeBytesPerEb = 105, voteDiffusionStrategy = PeerOrder, voteDiffusionMaxWindowSize = 100, voteDiffusionMaxHeadersToRequest = 100, voteDiffusionMaxBodiesToRequest = 1, certGenerationCpuTimeMsConstant = 90.0, certGenerationCpuTimeMsPerNode = 0.0, certValidationCpuTimeMsConstant = 130.0, certValidationCpuTimeMsPerNode = 0.0, certSizeBytesConstant = 7168, certSizeBytesPerNode = 0} topology :: Topology 'COORD2D topology = Topology{nodes = M.fromList [(NodeName "node-0", Node{nodeInfo = NodeInfo{stake = 500, cpuCoreCount = CpuCoreCount mzero, location = LocCoord2D{coord2D = Point{_1 = 0.12000040231003672, _2 = 0.1631004621065356}}, adversarial = mzero}, producers = M.fromList [(NodeName "node-1", LinkInfo{latencyMs = 141.01364015418432, bandwidthBytesPerSecond = BandwidthBps $ pure 1024000}), (NodeName "node-2", LinkInfo{latencyMs = 254.6249782835189, bandwidthBytesPerSecond = BandwidthBps $ pure 1024000})]}), (NodeName "node-1", Node{nodeInfo = NodeInfo{stake = 200, cpuCoreCount = CpuCoreCount mzero, location = LocCoord2D{coord2D = Point{_1 = 0.34276660615051174, _2 = 0.2636899791034371}}, adversarial = mzero}, producers = M.fromList [(NodeName "node-2", LinkInfo{latencyMs = 175.32530255486685, bandwidthBytesPerSecond = BandwidthBps $ pure 1024000}), (NodeName "node-3", LinkInfo{latencyMs = 379.1167948193313, bandwidthBytesPerSecond = BandwidthBps $ pure 1024000})]}), (NodeName "node-2", Node{nodeInfo = NodeInfo{stake = 100, cpuCoreCount = CpuCoreCount mzero, location = LocCoord2D{coord2D = Point{_1 = 0.5150493264153491, _2 = 0.27873594531347595}}, adversarial = mzero}, producers = M.fromList [(NodeName "node-3", LinkInfo{latencyMs = 248.31457793649423, bandwidthBytesPerSecond = BandwidthBps $ pure 1024000})]}), (NodeName "node-3", Node{nodeInfo = NodeInfo{stake = 0, cpuCoreCount = CpuCoreCount mzero, location = LocCoord2D{coord2D = Point{_1 = 0.3503537969220088, _2 = 0.13879558055660354}}, adversarial = mzero}, producers = M.fromList [(NodeName "node-0", LinkInfo{latencyMs = 140.19739576271448, bandwidthBytesPerSecond = BandwidthBps $ pure 1024000})]})]} diff --git a/leios-trace-verifier/hs-src/test/Spec/Transition.hs b/leios-trace-verifier/hs-src/test/Spec/Transition.hs index 6fffb57de..b9711bdd1 100644 --- a/leios-trace-verifier/hs-src/test/Spec/Transition.hs +++ b/leios-trace-verifier/hs-src/test/Spec/Transition.hs @@ -23,8 +23,7 @@ import qualified Data.Set as S import qualified Data.Text as T import qualified Spec.Scenario as Scenario (config, idOther, idSut) -data TracingContext - = TracingContext +data TracingContext = TracingContext { _clock :: Time , _slotNo :: SlotNo , _rbs :: Map Text Text diff --git a/simulation/docs/SimulatorModel.md b/simulation/docs/SimulatorModel.md index 95ff3cf07..952e35ff8 100644 --- a/simulation/docs/SimulatorModel.md +++ b/simulation/docs/SimulatorModel.md @@ -347,3 +347,84 @@ These variables maintain tasks blocked on some missing input. - `taskQueue`. A queue of tasks scheduled for the CPU, labeled according to what they model (eg "validate an RB"). Tasks are only removed when they are executed. + +# Alternative Design: Linear Leios + +## Motivation + +In Linear Leios, every time any party issues an RB, they also issue an EB. +In effect, the RB now consists of three parts: a header, a first body (the standard RB body), and a second body (the EB) that extends the first. +The EB includes txs (either by value or by reference)---there are no IBs. +When a (child) RB extends some (parent) RB, it will sometimes include a certificate that demonstrates a quorum of stake has already validated the parent RB's second body. +If the child RB includes that certificate, then its first body extends the parent's second body. +If the child RB excludes that certificate, then its first body instead extends the parent's first body---the parent's second body is irrevocably lost (except maybe on other chains extending that same parent RB). + +This variant is _linear_ because the txs that end up on some chain are never unordered: they are ordered in the mempools and they are ordered in the roughly-alternating chain of RBs and EBs. +This is in crucial contrast to Short Leios and its extensions: there, txs included (directly or indirectly) via EBs are concurrent until an RB serializes them (at the latest possible moment). +As a result, this variant is immediately compatible with today's ledger interface, as is---possibly other than reward calculations etc. + +## A Terse Interpretation of the Linear Leois Specification + +- A node should fetch EBs according to a FreshestFirst policy. +- A node should validate an EB as soon as possible while both of the following are true. + - It has validated the EB's parent RB. + The node cannot validate the EB before validating its parent RB. + - The EB's parent RB is the tip of the best RB header chain it has validated, excluding RB header's whose body turned out to be invalid. + Any RB that extends the EB's parent RB either excludes the EB or else certifies its validity---in either case, the node no longer needs to validate the EB. + Note that this conjunct is non-monotonic, due to a relevant RB header being later disqualified when its RB body is recognized as invalid. + TODO for now, it's merely what the chain has selected, regardless of any better headers. +- A node should vote for an EB as soon as possible within the following interval. + - The interval ends `L_vote` slots after the onset of the EB's slot (aka `linear-vote-stage-length-slots`). + - The interval begins either when the node validates the EB or three \Delta_hdr of the onset of the EB's slot, whichever happens last (ie combined the two times via `max`). + A node must not vote for an EB if it receives evidence of the issuer's equivocation within three \Delta_hdr of the EB's slot onset. +- A node should include an EB certificate, if any, in a new RB that extends the EB's parent if the new RB is at least `L_vote + L_diff` slots younger than the EB's parent (aka `linear-vote-stage-length-slots + linear-diffuse-stage-length-slots`). + It is important to clarify that an RB remains valid if it excludes the certificate even when those constraints are satisfied. +- A node should diffuse an EB even before it knows whether it's invalid (ie it should enable "EB diffusion pipelining"). + TODO would it even be worth going one step further: _streaming_ the EB, ie diffusing its prefix before its suffix has been received (and therefore before the EB could have been parsed)? +- A node should diffuse RB headers (at most two per election proof) even if it they're not on the best header chain, since such a header might still evidence equivocation. + We anticipate this happening separately (and redundantly) of ChainSync and BlockFetch. + TODO it can also abort validation of the EB, right? + TODO should it exclude the certificate of an equivocated EB if it issues the next RB? + +A node should acquire EBs from election opportunities even if they're on competing forks. +That way, if the node switches chains, it will already have the necessary EBs. +It won't have validated them, but that's fine, since it will only need to apply them when a certificate forces them to, so they can skip the validation checks. + +In order for the node to receive EBs for RB chains it doesn't necessarily have the RB headers for, RB headers will also be propogated via Relay in addition to and completely independently from their diffusion via ChainSync and BlockFetch. +This is because the RB header announces not just the RB body but also the EB (via the new `EBannounced` field in the RB header from the Linear Leios spec). + +## Implementation Notes + +The Linear Leios specification indicates that an RB header names the EB that occurs on the chain before the RB, if any, the EB that occurs after the RB, if any, and an EB names the RB that it follows. +However, in the absence of an attacker, the simulator can simply use the existing data types for Linear Leios even though the RB header type excludes those two fields. + +- The simulator does not currently have extensible data types for Praos headers, so it would not be trivial to add these header fields. +- In the absence of an attacker within the simulation, the new RB header fields aren't _necessary_. +- Despite being unnecessary, having the RB header announce its second body EB would plausibly decrease the average latency of the EBs. + But that decrease should be _very_ minor; with the current overly-coarse multiplexer logic (see [Issue 453](https://github.com/input-output-hk/ouroboros-leios/issues/453)), the EB's `RelayHeader` will arrive immediately after the ChainSync header (which are small), except perhaps during severe congestion. + +The Linear Leios simulator adds the following new variables, some of which also require new threads. + +- `relayLinearEBState`. + As a shortcut, the first Linear Leios simulator will instantiate `Relay` with `RelayHeader InputBlockId` and `InputBlock`. + This is because the IB specified in Short Leios has just a few small fields more than the EB specified in Linear Leios. + - It is remarkable that the Linear EB is added to the Relay buffer immediately, before its validated. + This is "EB Diffusion Pipelining", as indicated in the Linear Leios specification. +- `linearLedgerStateVar`, `waitingForLinearLedgerStateVar`, and `waitingForWaitingForLinearLedgerStateVar`. + An RB that contains an EB cert canot be validated without the the certified EB's ledger state. + However, that EB is necessarily certified, so its ledger state can be built comparatively cheaply now, but still not for free. + - The arrival of a Linear EB populates `waitingForWaitingForLinearLedgerStateVar` (and also `waitingForTipVar`; see below). + - The arrival of an RB populates `waitingForLinearLedgerStateVar`, which triggers the `waitingForWaitingForLinearLedgerStateVar` action to populate `linearLedgerStateVar` via the comparatively cheap `reapply` task. +- `waitingForTipVar`. + The Linear EB should be validated the first time that both it has arrived and its parent RB is the tip of the node's selection. +- `linearEbsToVoteVar`. + Once a Linear EB has been validated, it should be voted for. + A new custom thread monitors this variable in addition to the clock, so that it can avoid issugin a vote too early or too late. +- `linearEbOfRb`. + A mapping from RB to its announced Linear EB _that has been validated_, which is needed when issuing an RB. +- `pruneExpiredLinearVotes`. + This thread prunes votes 30 seconds after the onset of their EB's slot. + +TODO RB Diffusion is not pipelined + +TODO RBs are so far only distributed by ChainSync and BlockFetch diff --git a/simulation/ouroboros-leios-sim.cabal b/simulation/ouroboros-leios-sim.cabal index a6ddfee44..6aeabee64 100644 --- a/simulation/ouroboros-leios-sim.cabal +++ b/simulation/ouroboros-leios-sim.cabal @@ -139,6 +139,7 @@ library , io-classes , io-sim , kdt + , lens , leios-trace-hs , linear , mtl diff --git a/simulation/src/Chan.hs b/simulation/src/Chan.hs index 3906b1714..1441392fb 100644 --- a/simulation/src/Chan.hs +++ b/simulation/src/Chan.hs @@ -33,7 +33,7 @@ import Control.Monad.Class.MonadFork (MonadFork) import Control.Tracer (Contravariant (contramap), Tracer) import Data.Maybe (fromMaybe) import GHC.Generics -import ModelTCP (kilobytes, mkTcpConnProps) +import ModelTCP (kibibytes, lensTcpEvent, mkTcpConnProps) import TimeCompat (DiffTime, MonadDelay, MonadMonotonicTimeNSec, MonadTime) data ConnectionConfig = ConnectionConfig @@ -47,7 +47,7 @@ mkConnectionConfig tcp mux tcpLatency maybeTcpBandwidth = ConnectionConfig{..} transportConfig | tcp = TransportTcp (mkTcpConnProps tcpLatency (fromMaybe defaultTcpBandwidth maybeTcpBandwidth)) | otherwise = TransportSimple (SimpleConnProps tcpLatency maybeTcpBandwidth) - defaultTcpBandwidth = (kilobytes 1000) + defaultTcpBandwidth = (kibibytes 1000) data TransportConfig = TransportSimple !SimpleConnProps @@ -64,14 +64,14 @@ newConnectionBundle tracer = \case newUnMuxedConnectionBundle $ \tofrom -> newConnectionSimple (traceAsBundleMsg @bundle tofrom tracer) simpleConnProps ConnectionConfig (TransportSimple simpleConnProps) _mux@True -> do - let tracer' = contramap ((fmap . fmap) fromBearerMsg) tracer + let tracer' = mapBearerTracer (lensLabelTcpDir . lensTcpEvent) tracer (mA, mB) <- newConnectionSimple tracer' simpleConnProps (,) <$> newMuxChan mA <*> newMuxChan mB ConnectionConfig (TransportTcp tcpConnProps) _mux@False -> newUnMuxedConnectionBundle $ \tofrom -> newConnectionTCP (traceAsBundleMsg @bundle tofrom tracer) tcpConnProps ConnectionConfig (TransportTcp tcpConnProps) _mux@True -> do - let tracer' = contramap ((fmap . fmap) fromBearerMsg) tracer + let tracer' = mapBearerTracer (lensLabelTcpDir . lensTcpEvent) tracer (mA, mB) <- newConnectionTCP tracer' tcpConnProps (,) <$> newMuxChan mA <*> newMuxChan mB diff --git a/simulation/src/Chan/Mux.hs b/simulation/src/Chan/Mux.hs index 71614026e..63ae80cd2 100644 --- a/simulation/src/Chan/Mux.hs +++ b/simulation/src/Chan/Mux.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,17 +15,21 @@ module Chan.Mux ( ToFromBundleMsg (..), ConnectionBundle (..), - fromBearerMsg, + mapBearerTracer, newMuxChan, ) where import Chan.Core (Chan (..)) -import Chan.TCP (MessageSize (..)) +import Chan.TCP (Bytes, MessageSize (..)) import qualified Control.Category as Cat import Control.Concurrent.Class.MonadMVar (MonadMVar (..)) -import Control.Monad (forever) +import qualified Control.Lens as Lens +import Control.Monad (forM_, forever) import Control.Monad.Class.MonadFork (MonadFork (forkIO)) +import Control.Tracer (Tracer (Tracer), traceWith) import Data.Array (Array, listArray, (!)) +import Data.Foldable (traverse_) +import Data.Functor.Const (Const (Const), getConst) import Data.Kind import STMCompat @@ -43,8 +48,7 @@ class ConnectionBundle bundle where -- 'toBundleMsg'. For example, a valid implementation would be: -- -- > ToFromBundleMsg toDynamic (fromJust . fromDynamic) -data ToFromBundleMsg mm a - = ToFromBundleMsg +data ToFromBundleMsg mm a = ToFromBundleMsg { toBundleMsg :: a -> mm , fromBundleMsg :: mm -> a } @@ -56,30 +60,46 @@ instance Cat.Category ToFromBundleMsg where -- dynToFromBundleMsg :: Typeable a => ToFromBundleMsg Dynamic a -- dynToFromBundleMsg = ToFromBundleMsg toDyn (fromJust . fromDynamic) -data BearerMsg a = BearerMsg !Int a +data BorneMsg a = BorneMsg !Int a -fromBearerMsg :: BearerMsg a -> a -fromBearerMsg (BearerMsg _ a) = a - -instance MessageSize a => MessageSize (BearerMsg a) where - messageSizeBytes (BearerMsg _ a) = 1 + messageSizeBytes a +-- | Each bearer message is some slices of various 'BorneMsg's +-- +-- The mini protocols never see this, so this type is not exported. It does +-- occur in the argument types of some exported functions, but the caller +-- should be using parametric functions to generate those arguments. +data BearerMsg a + = -- | the cumulative size of the slices the borne messages whose /final/ slice + -- is in this message + BearerMsg !Bytes [BorneMsg a] + +instance MessageSize (BearerMsg a) where + messageSizeBytes (BearerMsg sz _) = 1 + sz + +mapBearerTracer :: + Applicative m => + Lens.Lens s t (BearerMsg a) a -> + Tracer m t -> + Tracer m s +mapBearerTracer lens tracer = Tracer $ \x -> do + let BearerMsg _ msgs = getConst $ lens Const x -- why doesn't Lens.view lens x type check? + flip traverse_ msgs $ \(BorneMsg _ a) -> do + traceWith tracer $ Lens.set lens a x newMuxChan :: forall bundle m. - (ConnectionBundle bundle, MonadMVar m, MonadSTM m, MonadFork m) => + (ConnectionBundle bundle, MonadMVar m, MonadSTM m, MonadFork m, MessageSize (BundleMsg bundle)) => Chan m (BearerMsg (BundleMsg bundle)) -> m (bundle (Chan m)) newMuxChan bearer = do - sendLock <- newMVar () -- Bit of a hack to use these TVars, could run the traverseConnectionBundle -- in a reader+state monad instead. That'd be cleaner. recvQueuesAccum <- newTVarIO [] recvQueuesIx <- newTVarIO (0 :: Int) + sendQueue <- newTQueueIO chans <- traverseConnectionBundle ( newMuxChanSingle @bundle - bearer - sendLock + sendQueue recvQueuesIx recvQueuesAccum ) @@ -87,35 +107,40 @@ newMuxChan bearer = do recvQueues <- reverse <$> readTVarIO recvQueuesAccum let recvQueues' = listArray (0, length recvQueues - 1) recvQueues _ <- forkIO $ demuxer @bundle bearer recvQueues' + _ <- forkIO $ muxer @bundle bearer sendQueue return chans newMuxChanSingle :: forall bundle m a. - (MonadMVar m, MonadSTM m) => - Chan m (BearerMsg (BundleMsg bundle)) -> - MVar m () -> + (MonadMVar m, MonadSTM m, MessageSize (BundleMsg bundle)) => + TQueue m (MVar m (), Bytes, BorneMsg (BundleMsg bundle)) -> TVar m Int -> TVar m [RecvQueue m (BundleMsg bundle)] -> ToFromBundleMsg (BundleMsg bundle) a -> m (Chan m a) newMuxChanSingle - bearer - sendLock + sendQueue recvQueuesIx recvQueuesAccum ToFromBundleMsg{..} = do - queue <- newTQueueIO + recvQueue <- newTQueueIO + -- A mini protocol can have at most one message in the send buffer. + sendLock <- newMVar () i <- atomically $ do - modifyTVar recvQueuesAccum (RecvQueue fromBundleMsg queue :) + modifyTVar recvQueuesAccum (RecvQueue fromBundleMsg recvQueue :) i <- readTVar recvQueuesIx writeTVar recvQueuesIx $! (i + 1) return i return Chan - { readChan = atomically (readTQueue queue) - , writeChan = \msg -> - let !muxmsg = BearerMsg i (toBundleMsg msg) - in withMVar sendLock $ \_ -> writeChan bearer muxmsg + { readChan = atomically (readTQueue recvQueue) + , writeChan = \msg -> do + let !bundleMsg = toBundleMsg msg + !muxmsg = BorneMsg i bundleMsg + takeMVar sendLock + atomically $ + writeTQueue sendQueue $ + (sendLock, messageSizeBytes bundleMsg, muxmsg) } data RecvQueue m mm where @@ -129,10 +154,51 @@ demuxer :: m () demuxer bearer queues = forever $ do - BearerMsg i msg <- readChan bearer - case queues ! i of - RecvQueue convert queue -> - atomically $ writeTQueue queue $! convert msg + BearerMsg _ msgs <- readChan bearer + forM_ msgs $ \(BorneMsg i msg) -> + case queues ! i of + RecvQueue convert queue -> + atomically $ writeTQueue queue $! convert msg + +muxer :: + forall bundle m. + (MonadMVar m, MonadSTM m) => + Chan m (BearerMsg (BundleMsg bundle)) -> + TQueue m (MVar m (), Bytes, BorneMsg (BundleMsg bundle)) -> + m () +muxer bearer sendQueue = + forever $ do + x <- atomically (readTQueue sendQueue) + (muxmsg, locks) <- go 0 [] [] x + mapM_ (flip putMVar ()) locks + writeChan bearer muxmsg + where + --- from ouroboros-network's @Network.Mux.Bearer.makeSocketBearer'@ + sliceBytes = 12288 + loafBytes = 131072 + + go !accBytes acc locks (lock, bytes, msg) = do + let !accBytes' = accBytes + min sliceBytes bytes + (acc', locks') <- + if bytes <= sliceBytes + then do + -- We do not release the lock before finalizing the loaf because a + -- single loaf should include slices from at most one borne message + -- per protocol. + pure (msg : acc, lock : locks) + else do + -- reenqueue the rest of the message + let !bytes' = bytes - sliceBytes + atomically $ writeTQueue sendQueue (lock, bytes', msg) + pure (acc, locks) + + let result = (BearerMsg accBytes' acc', locks') + if accBytes' >= loafBytes + then pure result + else do + atomically (tryReadTQueue sendQueue) >>= \case + Nothing -> pure result + Just x -> go accBytes' acc' locks' x data ExampleBundle f = ExampleBundle { exampleFoo :: f Int diff --git a/simulation/src/Chan/TCP.hs b/simulation/src/Chan/TCP.hs index 2bd39ea6b..7bd99fd6c 100644 --- a/simulation/src/Chan/TCP.hs +++ b/simulation/src/Chan/TCP.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -35,6 +36,11 @@ import TimeCompat data LabelTcpDir e = DirClientToServer e | DirServerToClient e deriving (Eq, Ord, Show, Functor) +lensLabelTcpDir :: Functor f => (a -> f b) -> LabelTcpDir a -> f (LabelTcpDir b) +lensLabelTcpDir f = \case + DirClientToServer x -> DirClientToServer <$> f x + DirServerToClient x -> DirServerToClient <$> f x + -- | Class for messages to be sent over a simulated TCP connection. -- To correctly model the timing of the messages sent over the connection we -- need to know a reasonable approximation of the message size. This does not diff --git a/simulation/src/ExamplesRelay.hs b/simulation/src/ExamplesRelay.hs index 4e15f126b..2b136ea91 100644 --- a/simulation/src/ExamplesRelay.hs +++ b/simulation/src/ExamplesRelay.hs @@ -1,7 +1,7 @@ module ExamplesRelay where import Data.Word (Word8) -import ModelTCP (kilobytes, mkTcpConnProps) +import ModelTCP (kibibytes, mkTcpConnProps) import RelayProtocol (BlockRelayMessage (..), BlockTTL) import SimRelay ( PacketGenerationPattern (UniformGenerationPattern), @@ -35,8 +35,8 @@ example1 = where trace = traceRelayLink1 - (mkTcpConnProps 0.3 (kilobytes 1000)) - (UniformGenerationPattern (kilobytes 100) 0.2 5.0) + (mkTcpConnProps 0.3 (kibibytes 1000)) + (UniformGenerationPattern (kibibytes 100) 0.2 5.0) example2 :: Visualization example2 = @@ -50,8 +50,8 @@ example2 = where trace = traceRelayLink4 - (mkTcpConnProps 0.3 (kilobytes 1000)) - (UniformGenerationPattern (kilobytes 100) 0.2 5.0) + (mkTcpConnProps 0.3 (kibibytes 1000)) + (UniformGenerationPattern (kibibytes 100) 0.2 5.0) example3 :: Visualization example3 = @@ -65,9 +65,9 @@ example3 = where trace = traceRelayLink4Asymmetric - (mkTcpConnProps 0.2 (kilobytes 1000)) - (mkTcpConnProps 0.3 (kilobytes 1000)) - (UniformGenerationPattern (kilobytes 100) 0.2 5.0) + (mkTcpConnProps 0.2 (kibibytes 1000)) + (mkTcpConnProps 0.3 (kibibytes 1000)) + (UniformGenerationPattern (kibibytes 100) 0.2 5.0) examplesRelaySimVizConfig :: RelaySimVizConfig examplesRelaySimVizConfig = diff --git a/simulation/src/ExamplesRelayP2P.hs b/simulation/src/ExamplesRelayP2P.hs index f0b980b13..f62e098df 100644 --- a/simulation/src/ExamplesRelayP2P.hs +++ b/simulation/src/ExamplesRelayP2P.hs @@ -5,7 +5,7 @@ module ExamplesRelayP2P where import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Maybe (fromMaybe) import Data.Word (Word8) -import ModelTCP (kilobytes, mkTcpConnProps) +import ModelTCP (kibibytes, mkTcpConnProps) import P2P (P2PTopographyCharacteristics (..), genArbitraryP2PTopography) import RelayProtocol import SimRelay @@ -63,7 +63,7 @@ example1 = { blockProcessingDelay = const (secondsToDiffTime 0.1) -- 100ms , blockGeneration = PoissonGenerationPattern - (kilobytes 96) + (kibibytes 96) rng -- average seconds between blocks: (0.2 * fromIntegral p2pNumNodes) @@ -156,7 +156,7 @@ example2 = { blockProcessingDelay = const (secondsToDiffTime 0.1) -- 100ms , blockGeneration = PoissonGenerationPattern - (kilobytes 96) + (kibibytes 96) rng -- average seconds between blocks: (0.5 * fromIntegral p2pNumNodes) diff --git a/simulation/src/ExamplesTCP.hs b/simulation/src/ExamplesTCP.hs index 7d0400048..2b5ebf1da 100644 --- a/simulation/src/ExamplesTCP.hs +++ b/simulation/src/ExamplesTCP.hs @@ -39,8 +39,8 @@ example1 = model = tcpSimVizModel trace where trace = traceTcpLinks1 tcpprops trafficPattern - tcpprops = mkTcpConnProps 0.3 (kilobytes 1000) - trafficPattern = mkUniformTrafficPattern 20 (kilobytes 100) 0 + tcpprops = mkTcpConnProps 0.3 (kibibytes 1000) + trafficPattern = mkUniformTrafficPattern 20 (kibibytes 100) 0 title = "Sending 20x 100kb messages over TCP" @@ -112,10 +112,10 @@ example2 = trace1 = traceTcpLinks4 tcpprops1 tcpprops1 tcpprops1 trafficPattern trace2 = traceTcpLinks4 tcpprops2 tcpprops2 tcpprops2 trafficPattern - tcpprops1 = mkTcpConnProps 0.3 (kilobytes 1000) - tcpprops2 = mkTcpConnProps 0.3 (kilobytes 10000) + tcpprops1 = mkTcpConnProps 0.3 (kibibytes 1000) + tcpprops2 = mkTcpConnProps 0.3 (kibibytes 10000) - trafficPattern = mkUniformTrafficPattern 15 (kilobytes 100) 0 + trafficPattern = mkUniformTrafficPattern 15 (kibibytes 100) 0 example3 :: Visualization example3 = @@ -141,10 +141,10 @@ example3 = trace1 = traceTcpLinks4 tcpprops tcpprops tcpprops trafficPattern1 trace2 = traceTcpLinks4 tcpprops tcpprops tcpprops trafficPattern2 - tcpprops = mkTcpConnProps 0.3 (kilobytes 1000) + tcpprops = mkTcpConnProps 0.3 (kibibytes 1000) - trafficPattern1 = mkUniformTrafficPattern 15 (kilobytes 100) 1.2 - trafficPattern2 = mkUniformTrafficPattern 30 (kilobytes 50) 0.6 + trafficPattern1 = mkUniformTrafficPattern 15 (kibibytes 100) 1.2 + trafficPattern2 = mkUniformTrafficPattern 30 (kibibytes 50) 0.6 examplesTcpSimVizConfig :: TcpSimVizConfig TestMessage examplesTcpSimVizConfig = diff --git a/simulation/src/LeiosProtocol/Common.hs b/simulation/src/LeiosProtocol/Common.hs index ebd598761..def3a2f83 100644 --- a/simulation/src/LeiosProtocol/Common.hs +++ b/simulation/src/LeiosProtocol/Common.hs @@ -147,6 +147,9 @@ inputBlockInvariant ib = ib.header.id == ib.body.id instance HasField "id" InputBlock InputBlockId where getField = (.id) . (.header) +instance HasField "slot" InputBlock SlotNo where + getField = (.slot) . (.header) + data EndorseBlockId = EndorseBlockId { node :: !NodeId , num :: !Int diff --git a/simulation/src/LeiosProtocol/RelayBuffer.hs b/simulation/src/LeiosProtocol/RelayBuffer.hs index c0f00a2fa..4cbc7048e 100644 --- a/simulation/src/LeiosProtocol/RelayBuffer.hs +++ b/simulation/src/LeiosProtocol/RelayBuffer.hs @@ -22,8 +22,7 @@ import Data.Word (Word64) ---- Relay Buffer -------------------------------- -data RelayBuffer key value - = RelayBuffer +data RelayBuffer key value = RelayBuffer { entries :: !(FingerTree TicketRange (EntryWithTicket key value)) , index :: !(Map key Ticket) , nextTicket :: !Ticket diff --git a/simulation/src/LeiosProtocol/Short.hs b/simulation/src/LeiosProtocol/Short.hs index 834e95eb8..730199403 100644 --- a/simulation/src/LeiosProtocol/Short.hs +++ b/simulation/src/LeiosProtocol/Short.hs @@ -45,6 +45,8 @@ data SizesConfig = SizesConfig , inputBlockBodyAvgSize :: !Bytes -- ^ as we do not model transactions we just use a fixed size for bodies. , inputBlockBodyMaxSize :: !Bytes + , endorseBlockBodyAvgSize :: !Bytes + -- ^ unused by Short/Full Leios, used by Linear Leios eg , endorseBlock :: !(EndorseBlock -> Bytes) , voteMsg :: !(VoteMsg -> Bytes) , certificate :: !(Certificate -> Bytes) @@ -62,7 +64,10 @@ data LeiosDelays = LeiosDelays -- ^ hash matching and payload validation (incl. tx scripts) , endorseBlockGeneration :: !(EndorseBlock -> DiffTime) , endorseBlockValidation :: !(EndorseBlock -> DiffTime) + , linearEndorseBlockGeneration :: !(InputBlock -> DiffTime) + , linearEndorseBlockValidation :: !(InputBlock -> DiffTime) , voteMsgGeneration :: !(VoteMsg -> [EndorseBlock] -> DiffTime) + , linearVoteMsgGeneration :: !(VoteMsg -> [InputBlock] -> DiffTime) , voteMsgValidation :: !(VoteMsg -> DiffTime) , certificateGeneration :: !(Certificate -> DiffTime) , certificateValidation :: !(Certificate -> DiffTime) @@ -91,7 +96,10 @@ data RelayDiffusionConfig = RelayDiffusionConfig , maxBodiesToRequest :: !Word16 } -data LeiosConfig = forall p. IsPipeline p => LeiosConfig +data LeiosConfig + = forall p. + IsPipeline p => + LeiosConfig { praos :: PraosConfig RankingBlockBody , pipeline :: SingPipeline p , sliceLength :: Int @@ -122,6 +130,8 @@ data LeiosConfig = forall p. IsPipeline p => LeiosConfig , votesForCertificate :: Int , sizes :: SizesConfig , delays :: LeiosDelays + , linearVoteStageLengthSlots :: Int + , linearDiffuseStageLengthSlots :: Int , ibDiffusion :: RelayDiffusionConfig , ebDiffusion :: RelayDiffusionConfig , voteDiffusion :: RelayDiffusionConfig @@ -153,11 +163,13 @@ convertConfig disk = , headerDiffusionTime = realToFrac $ durationMsToDiffTime disk.leiosHeaderDiffusionTimeMs , lateIbInclusion = disk.leiosLateIbInclusion , pipelinesToReferenceFromEB = - if disk.leiosVariant == Full - then - ceiling ((3 * disk.praosChainQuality) / fromIntegral sliceLength) - 2 - else 0 + case disk.leiosVariant of + Full -> ceiling ((3 * disk.praosChainQuality) / fromIntegral sliceLength) - 2 + Short -> 0 + Linear -> 0 , activeVotingStageLength = fromIntegral disk.leiosStageActiveVotingSlots + , linearVoteStageLengthSlots = fromIntegral disk.linearVoteStageLengthSlots + , linearDiffuseStageLengthSlots = fromIntegral disk.linearDiffuseStageLengthSlots , votingFrequencyPerStage = disk.voteGenerationProbability , votesForCertificate = fromIntegral disk.voteThreshold , sizes @@ -221,33 +233,43 @@ convertConfig disk = certificateSize (Certificate votesMap) = fromIntegral $ disk.certSizeBytesConstant - + disk.certSizeBytesPerNode `forEachKey` votesMap + + disk.certSizeBytesPerNode + `forEachKey` votesMap sizes = SizesConfig { inputBlockHeader = fromIntegral disk.ibHeadSizeBytes , inputBlockBodyAvgSize = fromIntegral disk.ibBodyAvgSizeBytes , inputBlockBodyMaxSize = fromIntegral disk.ibBodyMaxSizeBytes + , endorseBlockBodyAvgSize = fromIntegral disk.ebBodyAvgSizeBytes , endorseBlock = \eb -> fromIntegral $ disk.ebSizeBytesConstant - + disk.ebSizeBytesPerIb `forEach` eb.inputBlocks + + disk.ebSizeBytesPerIb + `forEach` eb.inputBlocks -- TODO: make it a per-ref field. - + disk.ebSizeBytesPerIb `forEach` eb.endorseBlocksEarlierPipeline + + disk.ebSizeBytesPerIb + `forEach` eb.endorseBlocksEarlierPipeline , voteMsg = \vt -> fromIntegral $ disk.voteBundleSizeBytesConstant - + disk.voteBundleSizeBytesPerEb `forEach` vt.endorseBlocks - , certificate = const $ error "certificate size config already included in PraosConfig{bodySize}" + + disk.voteBundleSizeBytesPerEb + `forEach` vt.endorseBlocks + , certificate = \_cert -> + fromIntegral $ + assert (0 == disk.certSizeBytesPerNode) $ -- TODO + disk.certSizeBytesConstant , rankingBlockLegacyPraosPayloadAvgSize = fromIntegral disk.rbBodyLegacyPraosPayloadAvgSizeBytes } certificateGeneration (Certificate votesMap) = durationMsToDiffTime $ disk.certGenerationCpuTimeMsConstant - + disk.certGenerationCpuTimeMsPerNode `forEachKey` votesMap + + disk.certGenerationCpuTimeMsPerNode + `forEachKey` votesMap certificateValidation (Certificate votesMap) = durationMsToDiffTime $ disk.certValidationCpuTimeMsConstant - + disk.certValidationCpuTimeMsPerNode `forEachKey` votesMap + + disk.certValidationCpuTimeMsPerNode + `forEachKey` votesMap delays = LeiosDelays { inputBlockGeneration = const $ durationMsToDiffTime disk.ibGenerationCpuTimeMs @@ -258,15 +280,27 @@ convertConfig disk = + disk.ibBodyValidationCpuTimeMsPerByte * fromIntegral ib.body.size , endorseBlockGeneration = const $ durationMsToDiffTime disk.ebGenerationCpuTimeMs , endorseBlockValidation = const $ durationMsToDiffTime disk.ebValidationCpuTimeMs + , linearEndorseBlockGeneration = const $ durationMsToDiffTime disk.ebGenerationCpuTimeMs + , linearEndorseBlockValidation = \ib -> + durationMsToDiffTime $ + disk.ebBodyValidationCpuTimeMsConstant + + disk.ebBodyValidationCpuTimeMsPerByte * fromIntegral ib.body.size , -- TODO: can parallelize? voteMsgGeneration = \vm ebs -> assert (vm.endorseBlocks == map (.id) ebs) $ durationMsToDiffTime $ sum [ disk.voteGenerationCpuTimeMsConstant - + disk.voteGenerationCpuTimeMsPerIb `forEach` eb.inputBlocks + + disk.voteGenerationCpuTimeMsPerIb + `forEach` eb.inputBlocks | eb <- ebs ] + , linearVoteMsgGeneration = \vm ibs -> + assert (1 == length vm.endorseBlocks) $ + assert (vm.endorseBlocks == map (convertLinearId . (.id)) ibs) $ + assert (0 == disk.voteGenerationCpuTimeMsPerTx) $ -- TODO + durationMsToDiffTime $ + disk.voteGenerationCpuTimeMsConstant `forEach` ibs , voteMsgValidation = \vm -> durationMsToDiffTime $ disk.voteValidationCpuTimeMs `forEach` vm.endorseBlocks @@ -274,6 +308,12 @@ convertConfig disk = , certificateValidation = const $ error "certificateValidation delay included in RB validation" } +convertLinearId :: InputBlockId -> EndorseBlockId +convertLinearId (InputBlockId x y) = EndorseBlockId x y + +unconvertLinearId :: EndorseBlockId -> InputBlockId +unconvertLinearId (EndorseBlockId x y) = InputBlockId x y + delaysAndSizesAsFull :: LeiosConfig -> LeiosConfig delaysAndSizesAsFull cfg@LeiosConfig{pipeline, voteSendStage} = -- Fields spelled out to more likely trigger an error and review when type changes. @@ -293,6 +333,8 @@ delaysAndSizesAsFull cfg@LeiosConfig{pipeline, voteSendStage} = , lateIbInclusion = cfg.lateIbInclusion , pipelinesToReferenceFromEB = cfg.pipelinesToReferenceFromEB , activeVotingStageLength = cfg.activeVotingStageLength + , linearVoteStageLengthSlots = cfg.linearVoteStageLengthSlots + , linearDiffuseStageLengthSlots = cfg.linearDiffuseStageLengthSlots , votingFrequencyPerStage = cfg.votingFrequencyPerStage , voteSendStage = voteSendStage , votesForCertificate = cfg.votesForCertificate @@ -310,6 +352,15 @@ delaysAndSizesAsFull cfg@LeiosConfig{pipeline, voteSendStage} = | id' <- fullVT.endorseBlocks , let EndorseBlock{..} = fullEB ] + fullLinearEBsVotedFor = + [ InputBlock + { body = fullIB.body + , header = + let InputBlockHeader{..} = fullIB.header + in InputBlockHeader{id = unconvertLinearId id', ..} + } + | id' <- fullVT.endorseBlocks + ] fullRB = mockFullRankingBlock cfg fullCert = mockFullCertificate cfg praos = @@ -329,6 +380,7 @@ delaysAndSizesAsFull cfg@LeiosConfig{pipeline, voteSendStage} = { inputBlockHeader = cfg.sizes.inputBlockHeader :: Bytes , inputBlockBodyAvgSize = cfg.sizes.inputBlockBodyAvgSize :: Bytes , inputBlockBodyMaxSize = cfg.sizes.inputBlockBodyMaxSize :: Bytes + , endorseBlockBodyAvgSize = cfg.sizes.endorseBlockBodyAvgSize :: Bytes , endorseBlock = const @Bytes $ cfg.sizes.endorseBlock $ mockFullEndorseBlock cfg , voteMsg = const @Bytes $ cfg.sizes.voteMsg $ mockFullVoteMsg cfg , certificate = const @Bytes $ cfg.sizes.certificate $ mockFullCertificate cfg @@ -341,12 +393,20 @@ delaysAndSizesAsFull cfg@LeiosConfig{pipeline, voteSendStage} = , inputBlockValidation = const @DiffTime $ cfg.delays.inputBlockValidation fullIB , endorseBlockGeneration = const @DiffTime $ cfg.delays.endorseBlockGeneration fullEB , endorseBlockValidation = const @DiffTime $ cfg.delays.endorseBlockValidation fullEB + , linearEndorseBlockGeneration = const @DiffTime $ cfg.delays.linearEndorseBlockGeneration fullIB + , linearEndorseBlockValidation = const @DiffTime $ cfg.delays.linearEndorseBlockValidation fullIB , voteMsgGeneration = const $ const @DiffTime $ cfg.delays.voteMsgGeneration fullVT fullEBsVotedFor + , linearVoteMsgGeneration = + const $ + const @DiffTime $ + cfg.delays.linearVoteMsgGeneration + fullVT + fullLinearEBsVotedFor , voteMsgValidation = const @DiffTime $ cfg.delays.voteMsgValidation fullVT , certificateGeneration = const @DiffTime $ cfg.delays.certificateGeneration fullCert , certificateValidation = const @DiffTime $ cfg.delays.certificateValidation fullCert @@ -661,7 +721,8 @@ mockFullCertificate cfg = mockCertificate cfg cfg.votesForCertificate -- Buffers views, divided to avoid reading unneeded buffers. data NewRankingBlockData = NewRankingBlockData - { certifiedEBforRBAt :: SlotNo -> Maybe (EndorseBlockId, Certificate) + { prevChain :: Chain RankingBlock + , mbEbCert :: Maybe (EndorseBlockId, Certificate) , txsPayload :: Bytes } @@ -758,13 +819,14 @@ endorseBlocksToReference :: EndorseBlocksSnapshot -> (PipelineNo -> UTCTime -> Bool) -> [(PipelineNo, [EndorseBlock])] -endorseBlocksToReference LeiosConfig{variant = Short} _ _ _ = [] -endorseBlocksToReference cfg@LeiosConfig{variant = Full} pl EndorseBlocksSnapshot{..} checkDeliveryTime = - assert - ( all (\(p, ebs) -> all (\eb -> p == endorseBlockPipeline cfg eb) ebs && succ (succ p) <= pl) result - && (\ps -> sort ps == ps) (map fst result) - ) - result +endorseBlocksToReference cfg pl EndorseBlocksSnapshot{..} checkDeliveryTime + | Full <- cfg.variant = + assert + ( all (\(p, ebs) -> all (\eb -> p == endorseBlockPipeline cfg eb) ebs && succ (succ p) <= pl) result + && (\ps -> sort ps == ps) (map fst result) + ) + result + | otherwise = [] where result = [ (p, [eb | (eb, _, _) <- es]) diff --git a/simulation/src/LeiosProtocol/Short/DataSimP2P.hs b/simulation/src/LeiosProtocol/Short/DataSimP2P.hs index dedadc756..af4b2372b 100644 --- a/simulation/src/LeiosProtocol/Short/DataSimP2P.hs +++ b/simulation/src/LeiosProtocol/Short/DataSimP2P.hs @@ -153,6 +153,11 @@ accumLeiosSimState _cfg now (LeiosEventNode (LabelNode nid (LeiosNodeEvent event { ebDiffusionLatency = accumDiffusionLatency' now nid event x.id x ebDiffusionLatency , .. } + EventLinearEB x -> + LeiosSimState + { ibDiffusionLatency = accumDiffusionLatency' now nid event x.id x.header ibDiffusionLatency + , .. + } EventVote x -> LeiosSimState { voteDiffusionLatency = accumDiffusionLatency' now nid event x.id x voteDiffusionLatency diff --git a/simulation/src/LeiosProtocol/Short/Generate.hs b/simulation/src/LeiosProtocol/Short/Generate.hs index 1d139e38c..3cc7d3b63 100644 --- a/simulation/src/LeiosProtocol/Short/Generate.hs +++ b/simulation/src/LeiosProtocol/Short/Generate.hs @@ -27,17 +27,22 @@ import LeiosProtocol.Common import LeiosProtocol.Config import LeiosProtocol.Short hiding (Stage (..)) import qualified LeiosProtocol.Short as Short +import qualified PraosProtocol.Common.Chain as Chain import STMCompat data BuffersView m = BuffersView - { newRBData :: STM m NewRankingBlockData + { newRBData :: STM m (SlotNo -> NewRankingBlockData) , newIBData :: STM m NewInputBlockData , ibs :: STM m InputBlocksSnapshot , ebs :: STM m EndorseBlocksSnapshot } data Role :: Type -> Type where - Base :: Role RankingBlock + Base :: + -- | For Linear Leios, we have two 'Base' roles: one for 'Left' and one for 'Right'. + -- + -- In Short or Full Leios, it's only the 'Left' role. + Role (Either (Chain RankingBlock, RankingBlock) InputBlock) Propose :: {ibSlot :: Maybe SlotNo, delay :: Maybe DiffTime} -> Role InputBlock Endorse :: Role EndorseBlock Vote :: Role VoteMsg @@ -70,17 +75,26 @@ leiosBlockGenerator LeiosGeneratorConfig{..} = actions <- concat <$> mapM (execute slot) roles lift $ submit actions , slotConfig + , initial = 0 } where execute slot (SomeRole r, wins) = assert (wins >= 1) $ (map . second) (SomeAction r) <$> execute' slot r wins execute' :: SlotNo -> Role a -> Word64 -> StateT Int m [(DiffTime, a)] execute' slot Base _wins = do - rbData <- lift $ atomically buffers.newRBData - let meb = rbData.certifiedEBforRBAt slot - let body = mkRankingBlockBody leios nodeId meb rbData.txsPayload - let !rb = mkPartialBlock slot body + rbData <- fmap (\f -> f slot) $ lift $ atomically buffers.newRBData + let body = mkRankingBlockBody leios nodeId rbData.mbEbCert rbData.txsPayload + let !rb = fixSize leios $ fixupBlock (Chain.headAnchor rbData.prevChain) $ mkPartialBlock slot body let !task = leios.praos.blockGenerationDelay rb - return [(task, rb)] + case leios.variant of + Short -> return [(task, Left (rbData.prevChain, rb))] + Full -> return [(task, Left (rbData.prevChain, rb))] + Linear -> do + ibData <- lift $ atomically buffers.newIBData + i <- nextBlkId InputBlockId + let header = mkInputBlockHeader leios i slot (SubSlotNo 0) nodeId (BlockHash $ blockHash rb) + let !ib = mkInputBlock leios header ibData.txsPayload + let !task2 = leios.delays.linearEndorseBlockGeneration ib + return [(task, Left (rbData.prevChain, rb)), (task2, Right ib)] execute' slot Propose{ibSlot, delay} wins = do ibData <- lift $ atomically buffers.newIBData forM [toEnum $ fromIntegral sub | sub <- [0 .. wins - 1]] $ \sub -> do @@ -94,6 +108,7 @@ leiosBlockGenerator LeiosGeneratorConfig{..} = ibs <- lift $ atomically buffers.ibs referencedEBs <- case leios.variant of Short -> pure [] + Linear -> pure [] Full -> do ebs <- lift $ atomically buffers.ebs let p = case leios of diff --git a/simulation/src/LeiosProtocol/Short/Node.hs b/simulation/src/LeiosProtocol/Short/Node.hs index 9c40dd3e0..1a3aa2000 100644 --- a/simulation/src/LeiosProtocol/Short/Node.hs +++ b/simulation/src/LeiosProtocol/Short/Node.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedRecordDot #-} @@ -19,14 +20,21 @@ import Control.Category ((>>>)) import Control.Concurrent.Class.MonadMVar import Control.Concurrent.Class.MonadSTM.TSem import Control.Exception (assert) -import Control.Monad (forever, guard, replicateM, unless, when) +import Control.Monad (forever, guard, replicateM, unless, void, when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow +import Control.Monad.State ( + MonadState (get, put), + MonadTrans (lift), + StateT, + execStateT, + ) import Control.Tracer import Data.Bifunctor import Data.Coerce (coerce) import Data.Foldable (Foldable (foldl'), forM_, for_) +import Data.Functor ((<&>)) import Data.Ix (Ix) import Data.List (sortOn) import Data.Map (Map) @@ -64,6 +72,7 @@ import System.Random data LeiosEventBlock = EventIB !InputBlock | EventEB !EndorseBlock + | EventLinearEB !InputBlock | EventVote !VoteMsg deriving (Show) @@ -140,17 +149,36 @@ data LeiosNodeState m = LeiosNodeState -- -- INVARIANT: @all (\k v -> all ((k ==) . pipelineOf cfg Propose) v)@. , relayEBState :: !(RelayEBState m) + , relayLinearEBState :: !(RelayLinearEBState m) , prunedUnadoptedEBStateToVar :: !(TVar m SlotNo) , prunedUncertifiedEBStateToVar :: !(TVar m SlotNo) , relayVoteState :: !(RelayVoteState m) , prunedVoteStateToVar :: !(TVar m SlotNo) -- ^ TODO: refactor into RelayState. , taskQueue :: !(TaskMultiQueue LeiosNodeTask m) + , waitingForTipVar :: !(TVar m (Map (HeaderHash RankingBlock) [STM m ()])) + -- ^ waiting for an RB to be selected + -- + -- It's triggered by the 'preferredChain' that Praos maintains. , waitingForRBVar :: !(TVar m (Map (HeaderHash RankingBlock) [STM m ()])) - -- ^ waiting for RB block itself to be validated. + -- ^ waiting for RB to arrive + -- + -- It's triggered by a variable Praos's BlockFetch maintains. , waitingForLedgerStateVar :: !(TVar m (Map (HeaderHash RankingBlock) [STM m ()])) - -- ^ waiting for ledger state of RB block to be validated. + -- ^ waiting for RB to be validated , ledgerStateVar :: !(TVar m (Map (HeaderHash RankingBlock) LedgerState)) + , linearLedgerStateVar :: !(TVar m (Map EndorseBlockId LedgerState)) + , waitingForLinearLedgerStateVar :: !(TVar m (Map EndorseBlockId [STM m ()])) + -- ^ waiting for a Linear EB to be validated + , waitingForWaitingForLinearLedgerStateVar :: !(TVar m (Map EndorseBlockId [STM m ()])) + -- ^ waiting for a Linear EB's ledger state to be demanded + , linearEbOfRb :: !(TVar m (Map (HeaderHash RankingBlock) EndorseBlockId)) + -- ^ mapping from RB's to their linear EB that has already been validated + , linearEbsToVoteVar :: !(TVar m (Map SlotNo (Map InputBlockId InputBlock))) + -- ^ mapping from slot number to EBs that this node should vote for during + -- that slot; the key will be exactly @3*leios-header-diffusion-time-ms@ + -- later than the slot of the EB; consumed by the 'mkLinearVoteGenerator' + -- thread , ibsNeededForEBVar :: !(TVar m (Map EndorseBlockId (Set InputBlockId))) , ibsValidationActionsVar :: !(TVar m (Map InputBlockId (STM m ()))) , votesForEBVar :: !(TVar m (Map EndorseBlockId CertificateProgress)) @@ -193,6 +221,7 @@ data NodeRelayState id header body m = NodeRelayState } type RelayIBState = NodeRelayState InputBlockId InputBlockHeader InputBlockBody type RelayEBState = NodeRelayState EndorseBlockId (RelayHeader EndorseBlockId) EndorseBlock +type RelayLinearEBState = NodeRelayState EndorseBlockId (RelayHeader EndorseBlockId) InputBlock type RelayVoteState = NodeRelayState VoteId (RelayHeader VoteId) VoteMsg data LedgerState = LedgerState @@ -201,6 +230,8 @@ data ValidationRequest m = ValidateRB !RankingBlock !(m ()) | ValidateIBs ![((InputBlockHeader, InputBlockBody), IbDeliveryStage)] !([(InputBlockHeader, InputBlockBody)] -> STM m ()) | ValidateEBS ![EndorseBlock] !([EndorseBlock] -> STM m ()) + | ValidateLinearEBs ![InputBlock] !([(EndorseBlockId, InputBlock)] -> STM m ()) + | ReapplyLinearEB !InputBlock !(STM m ()) | ValidateVotes ![VoteMsg] !UTCTime !([VoteMsg] -> STM m ()) -------------------------------------------------------------- @@ -215,12 +246,14 @@ instance MessageSize id => MessageSize (RelayHeader id) where type RelayIBMessage = RelayMessage InputBlockId InputBlockHeader InputBlockBody type RelayEBMessage = RelayMessage EndorseBlockId (RelayHeader EndorseBlockId) EndorseBlock +type RelayLinearEBMessage = RelayMessage EndorseBlockId (RelayHeader EndorseBlockId) InputBlock type RelayVoteMessage = RelayMessage VoteId (RelayHeader VoteId) VoteMsg type PraosMessage = PraosNode.PraosMessage RankingBlockBody data LeiosMessage = RelayIB {fromRelayIB :: !RelayIBMessage} | RelayEB {fromRelayEB :: !RelayEBMessage} + | RelayLinearEB {fromRelayLinearEB :: !RelayLinearEBMessage} | RelayVote {fromRelayVote :: !RelayVoteMessage} | PraosMsg {fromPraosMsg :: !PraosMessage} deriving (Show) @@ -228,6 +261,7 @@ data LeiosMessage data Leios f = Leios { protocolIB :: f RelayIBMessage , protocolEB :: f RelayEBMessage + , protocolLinearEB :: f RelayLinearEBMessage , protocolVote :: f RelayVoteMessage , protocolPraos :: PraosNode.Praos RankingBlockBody f } @@ -236,6 +270,7 @@ instance MessageSize LeiosMessage where messageSizeBytes lm = case lm of RelayIB m -> messageSizeBytes m RelayEB m -> messageSizeBytes m + RelayLinearEB m -> messageSizeBytes m RelayVote m -> messageSizeBytes m PraosMsg m -> messageSizeBytes m @@ -246,6 +281,7 @@ instance ConnectionBundle Leios where Leios { protocolIB = ToFromBundleMsg RelayIB (.fromRelayIB) , protocolEB = ToFromBundleMsg RelayEB (.fromRelayEB) + , protocolLinearEB = ToFromBundleMsg RelayLinearEB (.fromRelayLinearEB) , protocolVote = ToFromBundleMsg RelayVote (.fromRelayVote) , protocolPraos = case toFromBundleMsgBundle @(PraosNode.Praos RankingBlockBody) of PraosNode.Praos a b -> PraosNode.Praos (p >>> a) (p >>> b) @@ -253,7 +289,7 @@ instance ConnectionBundle Leios where where p = ToFromBundleMsg PraosMsg (.fromPraosMsg) - traverseConnectionBundle f (Leios a b c d) = Leios <$> f a <*> f b <*> f c <*> traverseConnectionBundle f d + traverseConnectionBundle f (Leios a b c d e) = Leios <$> f a <*> f b <*> f c <*> f d <*> traverseConnectionBundle f e -------------------------------------------------------------- @@ -356,6 +392,45 @@ relayEBConfig _tracer cfg@LeiosNodeConfig{leios = LeiosConfig{pipeline = (_ :: S ebTooOld1 || ebTooOld2 || ebAlreadyInBuffer } +relayLinearEBConfig :: + (MonadTime m, MonadDelay m, MonadSTM m) => + Tracer m LeiosNodeEvent -> + LeiosNodeConfig -> + SubmitBlocks m EndorseBlockId InputBlock -> + RelayLinearEBState m -> + RelayConsumerConfig EndorseBlockId (RelayHeader EndorseBlockId) InputBlock m +relayLinearEBConfig _tracer cfg submitBlocks st = + RelayConsumerConfig + { relay = RelayConfig{maxWindowSize = coerce cfg.leios.ebDiffusion.maxWindowSize} + , headerId = (.id) + , validateHeaders = const $ return () + , prioritize = prioritize cfg.leios.ebDiffusion.strategy (.slot) + , submitPolicy = SubmitAll + , maxHeadersToRequest = cfg.leios.ebDiffusion.maxHeadersToRequest + , maxBodiesToRequest = cfg.leios.ebDiffusion.maxBodiesToRequest + , submitBlocks = \hbs t k -> + submitBlocks + [(rh.id, ib) | (rh, ib) <- hbs] + t + (k . map (\(ebId, ib) -> (RelayHeader ebId ib.slot, ib))) + , shouldNotRequest = do + -- We possibly prune certified EBs (not referenced in the + -- chain) after maxEndorseBlockAgeSlots, so we should not end + -- up asking for their bodies again, in the remote possibility + -- they get offered. + assert (cfg.leios.maxEndorseBlockAgeForRelaySlots <= cfg.leios.maxEndorseBlockAgeSlots) $ do + currSlot <- currentSlotNo cfg.slotConfig + let oldestEBToRelay = currSlot - fromIntegral cfg.leios.maxEndorseBlockAgeForRelaySlots + atomically $ do + ebBuffer <- readTVar st.relayBufferVar + pure $ \ebHeader -> do + -- Check whether or not the EB is older than "eb-max-age-for-relay-slots" + let ebTooOld = ebHeader.slot < oldestEBToRelay + -- Check whether or not the EB is already in the relay buffer + let ebAlreadyInBuffer = RB.member ebHeader.id ebBuffer + ebTooOld || ebAlreadyInBuffer + } + relayVoteConfig :: (MonadDelay m, Monad (STM m), MonadSTM m, MonadTime m) => Tracer m LeiosNodeEvent -> @@ -404,19 +479,58 @@ newLeiosNodeState cfg = do relayIBState <- newRelayState iBsForEBsAndVotesVar <- newTVarIO Map.empty relayEBState <- newRelayState + relayLinearEBState <- newRelayState prunedUnadoptedEBStateToVar <- newTVarIO (toEnum 0) prunedUncertifiedEBStateToVar <- newTVarIO (toEnum 0) relayVoteState <- newRelayState prunedVoteStateToVar <- newTVarIO (toEnum 0) ibsNeededForEBVar <- newTVarIO Map.empty + waitingForWaitingForLinearLedgerStateVar <- newTVarIO Map.empty + waitingForLinearLedgerStateVar <- newTVarIO Map.empty + linearLedgerStateVar <- newTVarIO Map.empty + linearEbOfRb <- newTVarIO Map.empty ledgerStateVar <- newTVarIO Map.empty waitingForRBVar <- newTVarIO Map.empty waitingForLedgerStateVar <- newTVarIO Map.empty + waitingForTipVar <- newTVarIO Map.empty taskQueue <- atomically $ newTaskMultiQueue cfg.processingQueueBound votesForEBVar <- newTVarIO Map.empty + linearEbsToVoteVar <- newTVarIO Map.empty ibsValidationActionsVar <- newTVarIO Map.empty return $ LeiosNodeState{..} +-- | PREREQUISITE: the parent RB has already been validated +unblockRb :: + forall m. + ( MonadMVar m + , MonadFork m + , MonadAsync m + , MonadSTM m + , MonadTime m + , MonadDelay m + ) => + Tracer m LeiosNodeEvent -> + LeiosNodeConfig -> + LeiosNodeState m -> + InputBlock -> + STM m () +unblockRb tracer cfg leiosState ib = do + let ebId = convertLinearId ib.id + -- If an RB is waiting for this Linear EB's ledger state, then this Linear EB + -- is certified and so we can @reapply@ this ledger state. + waitFor leiosState.waitingForWaitingForLinearLedgerStateVar $ (\m -> [(ebId, [m])]) $ do + linearLedgerState <- readTVar leiosState.linearLedgerStateVar + -- Be a no-op if the Linear EB was already validated (eg for the sake of + -- voting) before any RB demanded it; TODO short fork race condition + case Map.lookup ebId linearLedgerState of + Just LedgerState -> pure () + Nothing -> do + dispatchValidationSTM tracer cfg leiosState $! ReapplyLinearEB ib $ do + modifyTVar' leiosState.linearLedgerStateVar $ Map.insert ebId LedgerState + case ib.header.rankingBlock of + GenesisHash -> error "invalid Linear EB" + BlockHash hdrHash -> modifyTVar' leiosState.linearEbOfRb $ Map.insert hdrHash ebId + leiosNode :: forall m. ( MonadMVar m @@ -453,12 +567,34 @@ leiosNode tracer cfg followers peers = do let submitEB (map snd -> xs) _ completion = do traceReceived xs EventEB dispatch $! ValidateEBS xs $ completion . map (\eb -> (eb.id, eb)) + let submitLinearEB (map snd -> xs) _deliveryTime completion = do + traceReceived xs EventLinearEB + unless (null xs) $ do + atomically $ forM_ xs $ \ib -> do + waitFor + leiosState.waitingForLedgerStateVar + [ (rbHash, [unblockRb tracer cfg leiosState ib]) + | BlockHash rbHash <- [ib.header.rankingBlock] + ] + dispatch $! ValidateLinearEBs xs completion let valHeaderIB = queueAndWait leiosState ValIH . map (cpuTask "ValIH" cfg.leios.delays.inputBlockHeaderValidation) let valHeaderRB h = do let !task = cpuTask "ValRH" cfg.leios.praos.headerValidationDelay h queueAndWait leiosState ValRH [task] + let unlessLinear :: m [a] -> m [a] + unlessLinear m = case cfg.leios.variant of + Linear -> pure [] + Short -> m + Full -> m + + let whenLinear :: m [a] -> m [a] + whenLinear m = case cfg.leios.variant of + Linear -> m + Short -> pure [] + Full -> pure [] + praosThreads <- PraosNode.setupPraosThreads' (contramap PraosNodeEvent tracer) @@ -470,21 +606,33 @@ leiosNode tracer cfg followers peers = do (map (.protocolPraos) peers) ibThreads <- - setupRelay - cfg.leios - (relayIBConfig tracer cfg valHeaderIB submitIB leiosState) - relayIBState - (map (.protocolIB) followers) - (map (.protocolIB) peers) - - ebThreads <- - setupRelay - cfg.leios - (relayEBConfig tracer cfg submitEB relayEBState leiosState) - relayEBState - (map (.protocolEB) followers) - (map (.protocolEB) peers) - + unlessLinear $ + setupRelay + cfg.leios + (relayIBConfig tracer cfg valHeaderIB submitIB leiosState) + relayIBState + (map (.protocolIB) followers) + (map (.protocolIB) peers) + + ebThreads1 <- + unlessLinear $ + setupRelay + cfg.leios + (relayEBConfig tracer cfg submitEB relayEBState leiosState) + relayEBState + (map (.protocolEB) followers) + (map (.protocolEB) peers) + + ebThreads2 <- + whenLinear $ + setupRelay + cfg.leios + (relayLinearEBConfig tracer cfg submitLinearEB relayLinearEBState) + relayLinearEBState + (map (.protocolLinearEB) followers) + (map (.protocolLinearEB) peers) + + let ebThreads = ebThreads1 ++ ebThreads2 -- only one is non-empty voteThreads <- setupRelay cfg.leios @@ -495,31 +643,67 @@ leiosNode tracer cfg followers peers = do let processWaitingForRB = processWaiting' - praosState.blockFetchControllerState.blocksVar + (readTVar praosState.blockFetchControllerState.blocksVar) waitingForRBVar let processWaitingForLedgerState = processWaiting' - ledgerStateVar + (readTVar ledgerStateVar) waitingForLedgerStateVar + let processWaitingForLinearLedgerStateVar = + processWaiting' + (readTVar linearLedgerStateVar) + waitingForLinearLedgerStateVar + + let processWaitingForWaitingForLinearLedgerStateVar = + processWaiting' + (readTVar waitingForLinearLedgerStateVar) + waitingForWaitingForLinearLedgerStateVar + + let processWaitingForTip = + processWaiting' + ( PraosNode.preferredChain leiosState.praosState <&> \case + Genesis -> Map.empty + _ :> b -> Map.singleton (blockHash b) () + ) + waitingForTipVar + let processingThreads = [ processCPUTasks cfg.processingCores (contramap LeiosNodeEventCPU tracer) leiosState.taskQueue - , processWaitingForRB , processWaitingForLedgerState ] + ++ if cfg.leios.variant /= Linear + then [processWaitingForRB] + else + [ processWaitingForWaitingForLinearLedgerStateVar + , processWaitingForLinearLedgerStateVar + , processWaitingForTip + ] - let blockGenerationThreads = [generator tracer cfg leiosState] + blockGenerationThreads <- + if cfg.leios.variant /= Linear + then pure [generator tracer cfg leiosState] + else do + let (rng1, rng2) = split cfg.rng + x <- mkLinearVoteGenerator tracer cfg{rng = rng1} leiosState + pure $ generator tracer cfg{rng = rng2} leiosState : x let computeLedgerStateThreads = - [ computeLedgerStateThread tracer cfg leiosState - -- , validateIBsOfCertifiedEBs tracer cfg leiosState - ] + if cfg.leios.variant == Linear + then [] + else + [ computeLedgerStateThread tracer cfg leiosState + -- , validateIBsOfCertifiedEBs tracer cfg leiosState + ] let pruningThreads = concat [ [ pruneExpiredVotes tracer cfg leiosState - | CleanupExpiredVote `isEnabledIn` cfg.leios.cleanupPolicies + | Linear /= cfg.leios.variant && CleanupExpiredVote `isEnabledIn` cfg.leios.cleanupPolicies + ] + , [ pruneExpiredLinearVotes tracer cfg leiosState + | Linear == cfg.leios.variant && CleanupExpiredVote `isEnabledIn` cfg.leios.cleanupPolicies ] , [ pruneExpiredUncertifiedEBs tracer cfg leiosState | CleanupExpiredUncertifiedEb `isEnabledIn` cfg.leios.cleanupPolicies @@ -706,6 +890,28 @@ pruneExpiredVotes _tracer LeiosNodeConfig{leios = leios@LeiosConfig{pipeline = _ -- traceWith tracer $! LeiosNodeEvent Pruned (EventVote $ snd vt) go (succ p) +-- | Prune votes 30 seconds after the supported EB. TODO magic number +pruneExpiredLinearVotes :: + (Monad m, MonadDelay m, MonadTime m, MonadSTM m) => + Tracer m LeiosNodeEvent -> + LeiosNodeConfig -> + LeiosNodeState m -> + m () +pruneExpiredLinearVotes _tracer cfg st = go (SlotNo 0) + where + go pruneTo = do + _ <- waitNextSlot cfg.slotConfig (SlotNo $ unSlotNo pruneTo + 30) -- TODO magic number + _votesPruned <- atomically $ do + writeTVar st.prunedVoteStateToVar $! pruneTo + partitionRBVar st.relayVoteState.relayBufferVar $ + \voteEntry -> + let voteSlot = (snd voteEntry.value).slot + in voteSlot < pruneTo + -- TODO: batch these, too many events. + -- for_ votesPruned $ \vt -> do + -- traceWith tracer $! LeiosNodeEvent Pruned (EventVote $ snd vt) + go (succ pruneTo) + referencedEBs :: MonadSTM m => LeiosConfig -> LeiosNodeState m -> Set EndorseBlockId -> STM m [EndorseBlockId] referencedEBs cfg st ebIds0 | null ebIds0 = return [] @@ -814,7 +1020,7 @@ validateIBsOfCertifiedEBs _trace _cfg st = forever . atomically $ do -- An IB that arrived later than it should have will not even be validated. adoptIB :: MonadSTM m => LeiosConfig -> LeiosNodeState m -> InputBlock -> IbDeliveryStage -> STM m () adoptIB cfg leiosState ib deliveryStage = do - let !ibSlot = ib.header.slot + let !ibSlot = ib.slot !p = case cfg of LeiosConfig{pipeline = _ :: SingPipeline p} -> pipelineOf @p cfg Short.Propose ibSlot @@ -831,6 +1037,26 @@ adoptEB leiosState eb = do let ibsNeeded = Map.fromList [(eb.id, Set.fromList eb.inputBlocks Set.\\ ibs)] modifyTVar' leiosState.ibsNeededForEBVar (`Map.union` ibsNeeded) +-- | Called after a Linear EB has been validated +adoptLinearEB :: MonadSTM m => LeiosNodeConfig -> LeiosNodeState m -> InputBlock -> STM m () +adoptLinearEB cfg leiosState ib = do + let ebId = convertLinearId ib.id + case ib.header.rankingBlock of + GenesisHash -> error "invalid Linear EB" + BlockHash hdrHash -> modifyTVar' leiosState.linearEbOfRb $ Map.insert hdrHash ebId + + votesForEB <- readTVar leiosState.votesForEBVar + let alreadyCertified = case Map.lookup ebId votesForEB of + Just Certified{} -> True + _ -> False + unless alreadyCertified $ do + let key = SlotNo $ unSlotNo ib.slot + toEnum (linearMinimumVoteDelaySlots cfg) + modifyTVar' leiosState.linearEbsToVoteVar $ Map.insertWith Map.union key (Map.singleton ib.id ib) + +linearMinimumVoteDelaySlots :: LeiosNodeConfig -> Int +linearMinimumVoteDelaySlots cfg = + ceiling $ (3 * cfg.leios.headerDiffusionTime) / cfg.slotConfig.duration + adoptVote :: MonadSTM m => LeiosConfig -> LeiosNodeState m -> VoteMsg -> UTCTime -> STM m () adoptVote leios leiosState v deliveryTime = do -- We keep tally for each EB as votes arrive, so the relayVoteBuffer @@ -846,9 +1072,21 @@ dispatchValidation :: ValidationRequest m -> m () dispatchValidation tracer cfg leiosState req = - atomically $ queue =<< go req + atomically $ dispatchValidationSTM tracer cfg leiosState req + +dispatchValidationSTM :: + forall m. + (MonadMVar m, MonadFork m, MonadAsync m, MonadSTM m, MonadTime m, MonadDelay m) => + Tracer m LeiosNodeEvent -> + LeiosNodeConfig -> + LeiosNodeState m -> + ValidationRequest m -> + STM m () +dispatchValidationSTM tracer cfg leiosState req = + queue =<< go req where queue = mapM_ (uncurry $ writeTMQueue leiosState.taskQueue) + labelTask :: (LeiosNodeTask, (String -> CPUTask, m ())) -> (LeiosNodeTask, (CPUTask, m ())) labelTask (tag, (f, m)) = let !task = f (show tag) in (tag, (task, m)) valRB rb m = do let task prefix = cpuTask prefix cfg.leios.praos.blockValidationDelay rb @@ -866,6 +1104,16 @@ dispatchValidation tracer cfg leiosState req = completion [eb] adoptEB leiosState eb traceEnterState [eb] EventEB + valLinearEB :: InputBlock -> Bool -> ([(EndorseBlockId, InputBlock)] -> STM m ()) -> (LeiosNodeTask, (CPUTask, m ())) + valLinearEB x alreadyCertified completion = + let + decimate = if alreadyCertified then (/ 10) else id -- TODO better ratio + delay prefix = cpuTask prefix (decimate . cfg.leios.delays.linearEndorseBlockValidation) x + task = atomically $ do + completion [(convertLinearId x.id, x)] + adoptLinearEB cfg leiosState x + in + labelTask (ValEB, (delay, task >> traceEnterState [x] EventLinearEB)) valVote v deliveryTime completion = labelTask . (ValVote,) . (\p -> cpuTask p cfg.leios.delays.voteMsgValidation v,) $ do atomically $ do completion [v] @@ -876,18 +1124,31 @@ dispatchValidation tracer cfg leiosState req = go x = case x of ValidateRB rb completion -> do let task = valRB rb completion + let linearTask = valRB rb $ do + atomically $ modifyTVar' leiosState.ledgerStateVar (Map.insert (blockHash rb) LedgerState) + completion case blockPrevHash rb of - GenesisHash -> do - return [task] - BlockHash prev -> do - let var = - assert (rb.blockBody.payload >= 0) $ - if rb.blockBody.payload == 0 - then leiosState.waitingForRBVar - -- TODO: assumes payload can be validated without content of EB, check with spec. - else leiosState.waitingForLedgerStateVar - waitFor var [(prev, [queue [task]])] - return [] + GenesisHash + | Linear <- cfg.leios.variant -> do + return [linearTask] + | otherwise -> do + return [task] + BlockHash prev + | Linear <- cfg.leios.variant -> do + case rb.blockBody.endorseBlocks of + [(ebId, _cert)] -> waitFor leiosState.waitingForLinearLedgerStateVar [(ebId, [queue [linearTask]])] + [] -> waitFor leiosState.waitingForLedgerStateVar [(prev, [queue [linearTask]])] + o -> error $ "too many certs in an RB: " <> show (length o) + pure [] + | otherwise -> do + let var = + assert (rb.blockBody.payload >= 0) $ + if rb.blockBody.payload == 0 + then leiosState.waitingForRBVar + else -- TODO: assumes payload can be validated without content of EB, check with spec. + leiosState.waitingForLedgerStateVar + waitFor var [(prev, [queue [task]])] + return [] ValidateIBs ibs completion -> do -- NOTE: IBs with an RB reference have to wait for ledger state of that RB. -- However, if they get referenced by the chain they should be validated anyway. @@ -920,11 +1181,81 @@ dispatchValidation tracer cfg leiosState req = ValidateEBS ebs completion -> do -- NOTE: block references are only inspected during voting. return [valEB eb completion | eb <- ebs] + ValidateLinearEBs ibs completion -> do + let ifNoCert :: InputBlockId -> (Bool -> STM m a) -> STM m () + ifNoCert ibId k = do + votesForEB <- readTVar leiosState.votesForEBVar + void $ k $ case Map.lookup (convertLinearId ibId) votesForEB of + Just Certified{} -> True + _ -> False + waitFor + leiosState.waitingForTipVar + [ (rbHash, [ifNoCert ib.id $ \alreadyCertified -> queue [valLinearEB ib alreadyCertified (const (pure ()))]]) + | ib <- ibs + , BlockHash rbHash <- [ib.header.rankingBlock] + ] + -- @complete@ the Linear EBs immediately, ie "EB Diffusion Pipelining" + completion [(convertLinearId ib.id, ib) | ib <- ibs] + pure [] + ReapplyLinearEB ib completion -> pure [valLinearEB ib True (const completion)] ValidateVotes vs deliveryTime completion -> do return [valVote v deliveryTime completion | v <- vs] traceEnterState :: [a] -> (a -> LeiosEventBlock) -> m () traceEnterState xs f = forM_ xs $ traceWith tracer . LeiosNodeEvent EnterState . f +generatorSubmitter :: + forall m. + (MonadMVar m, MonadFork m, MonadAsync m, MonadSTM m, MonadTime m, MonadDelay m) => + Tracer m LeiosNodeEvent -> + LeiosNodeConfig -> + LeiosNodeState m -> + (DiffTime, SomeAction) -> + m () +generatorSubmitter tracer cfg st = + submitOne + where + withDelay d (lbl, m) = do + -- cannot print id of generated RB until after it's generated, + -- the id of the generated block can be found in the generated event emitted at the time the task ends. + let !c = CPUTask d (T.pack $ show lbl) + atomically $ writeTMQueue st.taskQueue lbl (c, m) + + submitOne :: (DiffTime, SomeAction) -> m () + submitOne (delay, x) = withDelay delay $ + case x of + SomeAction Generate.Base (Left (chain, rb)) -> (GenRB,) $ do + atomically $ do + addProducedBlock st.praosState.blockFetchControllerState rb + modifyTVar' st.ledgerStateVar $ Map.insert (blockHash rb) LedgerState + traceWith tracer (PraosNodeEvent (PraosNodeEventGenerate rb)) + traceWith tracer (PraosNodeEvent (PraosNodeEventNewTip $ chain :> rb)) -- TODO don't assume the new block is the best block? + SomeAction Generate.Base (Right ib) -> (GenEB,) $ do + let ebId = convertLinearId ib.id + atomically $ do + modifyTVar' st.relayLinearEBState.relayBufferVar (RB.snocIfNew ebId (RelayHeader ebId ib.slot, ib)) + unblockRb tracer cfg st ib + adoptLinearEB cfg st ib + traceWith tracer (LeiosNodeEvent Generate (EventLinearEB ib)) + SomeAction Generate.Propose{} ib -> (GenIB,) $ do + atomically $ do + -- TODO should not be added to 'relayIBState' before it's validated + modifyTVar' st.relayIBState.relayBufferVar (RB.snocIfNew ib.id (ib.header, ib.body)) + adoptIB cfg.leios st ib IbDuringProposeOrDeliver1 + traceWith tracer (LeiosNodeEvent Generate (EventIB ib)) + SomeAction Generate.Endorse eb -> (GenEB,) $ do + atomically $ do + modifyTVar' st.relayEBState.relayBufferVar (RB.snocIfNew eb.id (RelayHeader eb.id eb.slot, eb)) + adoptEB st eb + traceWith tracer (LeiosNodeEvent Generate (EventEB eb)) + SomeAction Generate.Vote v -> (GenVote,) $ do + now <- getCurrentTime + atomically $ do + modifyTVar' + st.relayVoteState.relayBufferVar + (RB.snocIfNew v.id (RelayHeader v.id v.slot, v)) + adoptVote cfg.leios st v now + traceWith tracer (LeiosNodeEvent Generate (EventVote v)) + generator :: forall m. (MonadMVar m, MonadFork m, MonadAsync m, MonadSTM m, MonadTime m, MonadDelay m) => @@ -935,93 +1266,154 @@ generator :: generator tracer cfg st = do schedule <- mkSchedule tracer cfg let buffers = mkBuffersView cfg st - let - withDelay d (lbl, m) = do - -- cannot print id of generated RB until after it's generated, - -- the id of the generated block can be found in the generated event emitted at the time the task ends. - let !c = CPUTask d (T.pack $ show lbl) - atomically $ writeTMQueue st.taskQueue lbl (c, m) - let - submitOne :: (DiffTime, SomeAction) -> m () - submitOne (delay, x) = withDelay delay $ - case x of - SomeAction Generate.Base rb0 -> (GenRB,) $ do - (rb, newChain) <- atomically $ do - chain <- PraosNode.preferredChain st.praosState - let rb = fixSize cfg.leios $ fixupBlock (Chain.headAnchor chain) rb0 - addProducedBlock st.praosState.blockFetchControllerState rb - return (rb, chain :> rb) - traceWith tracer (PraosNodeEvent (PraosNodeEventGenerate rb)) - traceWith tracer (PraosNodeEvent (PraosNodeEventNewTip newChain)) - SomeAction Generate.Propose{} ib -> (GenIB,) $ do - atomically $ do - -- TODO should not be added to 'relayIBState' before it's validated - modifyTVar' st.relayIBState.relayBufferVar (RB.snocIfNew ib.header.id (ib.header, ib.body)) - adoptIB cfg.leios st ib IbDuringProposeOrDeliver1 - traceWith tracer (LeiosNodeEvent Generate (EventIB ib)) - SomeAction Generate.Endorse eb -> (GenEB,) $ do - atomically $ do - modifyTVar' st.relayEBState.relayBufferVar (RB.snocIfNew eb.id (RelayHeader eb.id eb.slot, eb)) - adoptEB st eb - traceWith tracer (LeiosNodeEvent Generate (EventEB eb)) - SomeAction Generate.Vote v -> (GenVote,) $ do - now <- getCurrentTime - atomically $ do - modifyTVar' - st.relayVoteState.relayBufferVar - (RB.snocIfNew v.id (RelayHeader v.id v.slot, v)) - adoptVote cfg.leios st v now - traceWith tracer (LeiosNodeEvent Generate (EventVote v)) let LeiosNodeConfig{..} = cfg + let submitOne = generatorSubmitter tracer cfg st leiosBlockGenerator $ LeiosGeneratorConfig{submit = mapM_ submitOne, ..} +mkLinearVoteGenerator :: + forall m. + (MonadMVar m, MonadFork m, MonadAsync m, MonadSTM m, MonadTime m, MonadDelay m) => + Tracer m LeiosNodeEvent -> + LeiosNodeConfig -> + LeiosNodeState m -> + m [m ()] +mkLinearVoteGenerator tracer cfg leiosState = do + currSlotVar <- newTVarIO $ SlotNo 0 + let ticker = + blockGenerator $ + BlockGeneratorConfig + { execute = \slot -> lift $ atomically $ writeTVar currSlotVar slot + , slotConfig + , initial = () + } + let go !prng !i = do + io <- atomically $ do + linearEbsToVote <- readTVar leiosState.linearEbsToVoteVar + check $ not $ Map.null linearEbsToVote + -- If there are no EBs to consider, we won't wake up on clock ticks. + currSlot <- readTVar currSlotVar + let (old, mbNow, tooYoung) = Map.splitLookup currSlot linearEbsToVote + check $ Map.size tooYoung /= Map.size linearEbsToVote + -- If we've reached this point, there will be actual progress. + writeTVar leiosState.linearEbsToVoteVar $! tooYoung + pure $ do + -- TODO do not vote for equivocated blocks + -- + -- TODO don't vote if it's not announced by the /current/ tip of + -- our chain? That was true at some point, or else we wouldn't + -- have validated it, and so it wouldn't have ended up in + -- 'linearEbsToVoteVar'. + mapM_ (mapM_ (each currSlot)) old + mapM_ (mapM_ (each currSlot)) mbNow + (prng', i') <- execStateT io (prng, i) + go prng' i' + pure [ticker, go cfg.rng 1] + where + submitOne = generatorSubmitter tracer cfg leiosState + + LeiosNodeConfig{..} = cfg + + checkElection :: StateT (StdGen, Int) m (Maybe (VoteId, Word64)) + checkElection = do + (prng, i) <- get + let (sample, prng') = uniformR (0, 1) prng + let wins = votingRatePerPipeline cfg.leios cfg.stake sample + if 0 == wins + then Nothing <$ put (prng', i) + else do + let !i' = i + 1 + put (prng', i') + pure $ Just (VoteId nodeId (negate i), wins) + + each :: SlotNo -> InputBlock -> StateT (StdGen, Int) m () + each currSlot ib = + unless (tooLate currSlot ib.slot) $ + checkElection >>= \case + Nothing -> pure () + Just (vbId, wins) -> do + let voteMsg = mkVoteMsg leios vbId ib.slot nodeId wins [convertLinearId ib.id] + let !task = leios.delays.linearVoteMsgGeneration voteMsg [ib] + lift $ submitOne (task, SomeAction Generate.Vote voteMsg) + + tooLate currSlot ebSlot = + unSlotNo ebSlot + toEnum cfg.leios.linearVoteStageLengthSlots < unSlotNo currSlot + mkBuffersView :: forall m. MonadSTM m => LeiosNodeConfig -> LeiosNodeState m -> BuffersView m mkBuffersView cfg st = BuffersView{..} where - newRBData = do - -- This gets called pretty rarely, so doesn't seem worth caching, - -- though it's getting more expensive as we go. - chain <- PraosNode.preferredChain st.praosState - bufferEB <- readTVar st.relayEBState.relayBufferVar - votesForEB <- readTVar st.votesForEBVar - -- RBs in the same chain should not contain certificates for the same pipeline. - let pipelinesInChain = - Set.fromList $ - [ endorseBlockPipeline cfg.leios eb - | rb <- Chain.chainToList chain - , (ebId, _) <- rb.blockBody.endorseBlocks - , Just (_, eb) <- [RB.lookup bufferEB ebId] - ] - let tryCertify eb = do - Certified{cert} <- Map.lookup eb.id votesForEB - guard (not $ Set.member (endorseBlockPipeline cfg.leios eb) pipelinesInChain) - return $! (eb.id,) $! cert - - -- TODO: cache index of EBs ordered by .slot? - let orderEBs = case cfg.leios.variant of - Short -> sortOn (\eb -> (eb.slot, Down $ length eb.inputBlocks)) - Full -> sortOn (\eb -> (Down eb.slot, Down $ length eb.inputBlocks)) - let certifiedEBforRBAt rbSlot = - listToMaybe - . mapMaybe tryCertify - . orderEBs - . filter (\eb -> not $ fromEnum eb.slot < fromEnum rbSlot - cfg.leios.maxEndorseBlockAgeSlots) - . map snd - . RB.values - -- TODO: start from votesForEB, would allow to drop EBs from relayBuffer as soon as Endorse ends. - $ bufferEB - return $ - NewRankingBlockData - { certifiedEBforRBAt - , txsPayload = cfg.leios.sizes.rankingBlockLegacyPraosPayloadAvgSize - } - newIBData = do - ledgerState <- readTVar st.ledgerStateVar - referenceRankingBlock <- - Chain.headHash . Chain.dropUntil (flip Map.member ledgerState . blockHash) - <$> PraosNode.preferredChain st.praosState - let txsPayload = cfg.leios.sizes.inputBlockBodyAvgSize - return $ NewInputBlockData{referenceRankingBlock, txsPayload} + newRBData + | Linear <- cfg.leios.variant = do + -- This gets called pretty rarely, so doesn't seem worth caching, + -- though it's getting more expensive as we go. + chain <- PraosNode.preferredChain st.praosState + votesForEB <- readTVar st.votesForEBVar + linearEbOfRb <- readTVar st.linearEbOfRb + return $ \rbSlot -> + let prev = Chain.dropUntil (\rb -> blockSlot rb < rbSlot) $ chain + mbEbCert = do + -- INVARIANT the genesis block has no Linear EB, and so the first actual block has nothing to certify + Anchor prevSlot prevRbId _prevBlockNo <- pure $ Chain.headAnchor prev + -- Must be old enough. + guard $ unSlotNo prevSlot + toEnum (cfg.leios.linearVoteStageLengthSlots + cfg.leios.linearDiffuseStageLengthSlots) <= unSlotNo rbSlot + -- Must have already been validated (eg so that it has affected the mempool already) + ebId <- Map.lookup prevRbId linearEbOfRb + -- Must have already met quorum. + Certified{cert} <- Map.lookup ebId votesForEB + cert `seq` return (ebId, cert) + txsPayload = + cfg.leios.sizes.rankingBlockLegacyPraosPayloadAvgSize - case mbEbCert of + Nothing -> 0 + Just (_ebId, cert) -> cfg.leios.sizes.certificate cert + in NewRankingBlockData{prevChain = prev, txsPayload, mbEbCert} + | otherwise = do + -- This gets called pretty rarely, so doesn't seem worth caching, + -- though it's getting more expensive as we go. + chain <- PraosNode.preferredChain st.praosState + bufferEB <- readTVar st.relayEBState.relayBufferVar + votesForEB <- readTVar st.votesForEBVar + -- RBs in the same chain should not contain certificates for the same pipeline. + let pipelinesInChain = + Set.fromList $ + [ endorseBlockPipeline cfg.leios eb + | rb <- Chain.chainToList chain + , (ebId, _) <- rb.blockBody.endorseBlocks + , Just (_, eb) <- [RB.lookup bufferEB ebId] + ] + let tryCertify eb = do + Certified{cert} <- Map.lookup eb.id votesForEB + guard (not $ Set.member (endorseBlockPipeline cfg.leios eb) pipelinesInChain) + return $! (eb.id,) $! cert + + -- TODO: cache index of EBs ordered by .slot? + let orderEBs = case cfg.leios.variant of + Short -> sortOn (\eb -> (eb.slot, Down $ length eb.inputBlocks)) + Full -> sortOn (\eb -> (Down eb.slot, Down $ length eb.inputBlocks)) + -- GHC sees that @Linear ->@ pattern would be redundant here. + return $ \rbSlot -> + NewRankingBlockData + { prevChain = Chain.dropUntil (\rb -> blockSlot rb < rbSlot) $ chain + , txsPayload = cfg.leios.sizes.rankingBlockLegacyPraosPayloadAvgSize + , mbEbCert = + listToMaybe + . mapMaybe tryCertify + . orderEBs + . filter (\eb -> not $ fromEnum eb.slot < fromEnum rbSlot - cfg.leios.maxEndorseBlockAgeSlots) + . map snd + . RB.values + -- TODO: start from votesForEB, would allow to drop EBs from relayBuffer as soon as Endorse ends. + $ bufferEB + } + newIBData + | Linear <- cfg.leios.variant = do + let txsPayload = cfg.leios.sizes.endorseBlockBodyAvgSize + return $ NewInputBlockData{referenceRankingBlock = GenesisHash {- dummy value, ignored -}, txsPayload} + | otherwise = do + ledgerState <- readTVar st.ledgerStateVar + referenceRankingBlock <- + Chain.headHash . Chain.dropUntil (flip Map.member ledgerState . blockHash) + <$> PraosNode.preferredChain st.praosState + let txsPayload = cfg.leios.sizes.inputBlockBodyAvgSize + return $ NewInputBlockData{referenceRankingBlock, txsPayload} ibs = do let splitLE k m = let (lt, mbEq, _gt) = Map.splitLookup k m @@ -1082,21 +1474,28 @@ mkSchedule tracer cfg = do [ (SomeRole Generate.Endorse, endorseBlockRate cfg.leios cfg.stake) , (SomeRole Generate.Base, const $ calcWins (NetworkRate cfg.leios.praos.blockFrequencyPerSlot)) ] - rates votingSlots slot = do - when (cfg.conformanceEvents && (slot > 0)) $ traceWith tracer $ LeiosNodeEventConformance Slot{slot = slot - 1} - vote <- atomically $ do - vs <- readTVar votingSlots - case vs of - (sl : sls) - | sl == slot -> do - writeTVar votingSlots sls - pure (Just voteRate) - _ -> pure Nothing - pure $ - [ (SomeRole Generate.Vote, vote) - , ibRate cfg.blockGeneration slot - ] - ++ map (fmap ($ slot)) pureRates + rates votingSlots slot + | Linear <- cfg.leios.variant = do + -- Linear Leios has only RB and voting election, and the voting election + -- happens elsewhere, as an eventual consequence of the RB election. + pure $ + [ (SomeRole Generate.Base, calcWins (NetworkRate cfg.leios.praos.blockFrequencyPerSlot)) + ] + | otherwise = do + when (cfg.conformanceEvents && (slot > 0)) $ traceWith tracer $ LeiosNodeEventConformance Slot{slot = slot - 1} + vote <- atomically $ do + vs <- readTVar votingSlots + case vs of + (sl : sls) + | sl == slot -> do + writeTVar votingSlots sls + pure (Just voteRate) + _ -> pure Nothing + pure $ + [ (SomeRole Generate.Vote, vote) + , ibRate cfg.blockGeneration slot + ] + ++ map (fmap ($ slot)) pureRates pickFromRanges :: StdGen -> [(SlotNo, SlotNo)] -> [SlotNo] pickFromRanges rng0 rs = snd $ mapAccumL f rng0 rs where @@ -1125,9 +1524,9 @@ partitionRBVar :: partitionRBVar var f = fmap RB.values . stateTVar' var $ RB.partition f waitFor :: - MonadSTM m => - TVar m (Map RankingBlockId [STM m ()]) -> - [(RankingBlockId, [STM m ()])] -> + (Ord k, MonadSTM m) => + TVar m (Map k [STM m ()]) -> + [(k, [STM m ()])] -> STM m () waitFor var xs = do modifyTVar' diff --git a/simulation/src/LeiosProtocol/Short/Sim.hs b/simulation/src/LeiosProtocol/Short/Sim.hs index 0d3f4f884..d45489699 100644 --- a/simulation/src/LeiosProtocol/Short/Sim.hs +++ b/simulation/src/LeiosProtocol/Short/Sim.hs @@ -86,18 +86,26 @@ logLeiosEvent nodeNames loudness e = case e of ps <- logMsg msg pure $ pairs $ - "tag" .= asString "Sent" - <> "sender" .= from - <> "receipient" .= to + "tag" + .= asString "Sent" + <> "sender" + .= from + <> "receipient" + .= to <> mconcat - [ "fragments" .= length fcs - <> "forecast" .= forecast + [ "fragments" + .= length fcs + <> "forecast" + .= forecast | emitDebug ] <> mconcat ["forecasts" .= fcs | emitControl] - <> "msg_size_bytes" .= fromBytes (messageSizeBytes msg) - <> "time_to_received_s" .= (coerce forecast.msgRecvTrailingEdge - coerce forecast.msgSendLeadingEdge :: DiffTime) - <> "sending_s" .= (coerce forecast.msgSendTrailingEdge - coerce forecast.msgSendLeadingEdge :: DiffTime) + <> "msg_size_bytes" + .= fromBytes (messageSizeBytes msg) + <> "time_to_received_s" + .= (coerce forecast.msgRecvTrailingEdge - coerce forecast.msgSendLeadingEdge :: DiffTime) + <> "sending_s" + .= (coerce forecast.msgSendTrailingEdge - coerce forecast.msgSendLeadingEdge :: DiffTime) <> ps where emitControl = loudness >= 3 @@ -136,7 +144,7 @@ logLeiosEvent nodeNames loudness e = case e of | Generate <- blkE = case blk of EventIB ib -> mconcat - [ "slot" .= ib.header.slot + [ "slot" .= ib.slot , "payload_bytes" .= fromBytes ib.body.size , "size_bytes" .= fromBytes (messageSizeBytes ib) , "rb_ref" .= rbRef (ib.header.rankingBlock) @@ -151,6 +159,12 @@ logLeiosEvent nodeNames loudness e = case e of , ebRefs , "size_bytes" .= fromBytes (messageSizeBytes eb) ] + EventLinearEB eb -> + mconcat + [ "slot" .= eb.slot + , "size_bytes" .= fromBytes (messageSizeBytes eb) + , "rb_ref" .= rbRef (eb.header.rankingBlock) + ] EventVote vt -> mconcat [ "slot" .= vt.slot @@ -167,6 +181,7 @@ logLeiosEvent nodeNames loudness e = case e of kindAndId = case blk of EventIB ib -> mconcat [ibKind, "id" .= ib.stringId] EventEB eb -> mconcat [ebKind, "id" .= eb.stringId] + EventLinearEB eb -> mconcat [ebKind, "id" .= eb.stringId] EventVote vt -> mconcat [vtKind, "id" .= vt.stringId] logNode _nid LeiosNodeEventConformance{} = Nothing logPraos nid (PraosNodeEventGenerate blk@(Block h b)) = @@ -204,6 +219,7 @@ logLeiosEvent nodeNames loudness e = case e of logMsg :: LeiosMessage -> Maybe Series logMsg (RelayIB msg) = (ibKind <>) <$> logRelay (.id) msg logMsg (RelayEB msg) = (ebKind <>) <$> logRelay (.id) msg + logMsg (RelayLinearEB msg) = (ebKind <>) <$> logRelay (.id) msg logMsg (RelayVote msg) = (vtKind <>) <$> logRelay (.id) msg logMsg (PraosMsg (PraosMessage (Right (ProtocolMessage (SomeMessage (MsgBlock hash _body)))))) = Just $ rbKind <> "id" .= show (coerce @_ @Int hash) @@ -213,29 +229,40 @@ logLeiosEvent nodeNames loudness e = case e of logRelay :: (HasField "node" id NodeId, HasField "num" id Int) => (h -> id) -> RelayMessage id h b -> Maybe Series logRelay _getId (ProtocolMessage (SomeMessage msg@(MsgRespondBodies xs))) = Just $ - "ids" .= map (mkStringId . fst) xs - <> "msg_label" .= relayMessageLabel msg + "ids" + .= map (mkStringId . fst) xs + <> "msg_label" + .= relayMessageLabel msg logRelay _getId (ProtocolMessage (SomeMessage msg@(MsgRequestBodies xs))) | emitDebug = Just $ - "ids" .= map mkStringId xs - <> "msg_label" .= relayMessageLabel msg + "ids" + .= map mkStringId xs + <> "msg_label" + .= relayMessageLabel msg logRelay getId (ProtocolMessage (SomeMessage msg@(MsgRespondHeaders xs))) | emitDebug = Just $ - "ids" .= map (mkStringId . getId) (toList xs) - <> "msg_label" .= relayMessageLabel msg + "ids" + .= map (mkStringId . getId) (toList xs) + <> "msg_label" + .= relayMessageLabel msg logRelay _getId (ProtocolMessage (SomeMessage msg@(MsgRequestHeaders _ ws we))) | emitDebug = Just $ - "shrink" .= ws.value - <> "expand" .= we.value - <> "msg_label" .= relayMessageLabel msg + "shrink" + .= ws.value + <> "expand" + .= we.value + <> "msg_label" + .= relayMessageLabel msg logRelay _ (ProtocolMessage (SomeMessage msg)) | emitControl = Just $ - "id" .= asString "control" - <> "msg_label" .= relayMessageLabel msg + "id" + .= asString "control" + <> "msg_label" + .= relayMessageLabel msg | otherwise = Nothing asString x = x :: String @@ -253,9 +280,11 @@ sharedEvent leios nodeNames e = case e of nodeName nid = fromMaybe undefined $ Map.lookup nid nodeNames blkId (EventIB ib) = mkStringId ib.id blkId (EventEB eb) = mkStringId eb.id + blkId (EventLinearEB eb) = mkStringId eb.id blkId (EventVote vt) = mkStringId vt.id - blkSlot (EventIB ib) = fromIntegral . fromEnum $ ib.header.slot + blkSlot (EventIB ib) = fromIntegral . fromEnum $ ib.slot blkSlot (EventEB eb) = fromIntegral . fromEnum $ eb.slot + blkSlot (EventLinearEB eb) = fromIntegral . fromEnum $ eb.slot blkSlot (EventVote vt) = fromIntegral . fromEnum $ vt.slot splitTaskLabel lbl = case T.break (== ':') lbl of (tag, blkid) -> (tag, T.drop 2 blkid) @@ -359,11 +388,19 @@ sharedEvent leios nodeNames e = case e of , pipeline = coerce $ endorseBlockPipeline leios eb , .. } + EventLinearEB eb -> + Shared.EBGenerated + { bytes = fromIntegral (messageSizeBytes eb) + , input_blocks = [] + , endorser_blocks = [] + , pipeline = 0 + , .. + } EventVote vt -> Shared.VTBundleGenerated { bytes = fromIntegral (messageSizeBytes vt) , votes = Map.fromList $ map ((,vt.votes) . T.pack . mkStringId) vt.endorseBlocks - , pipeline = coerce $ voteMsgPipeline leios vt + , pipeline = if Linear == leios.variant then 0 else coerce $ voteMsgPipeline leios vt , .. } sharedEnterState :: T.Text -> String -> Word64 -> LeiosEventBlock -> Shared.Event @@ -371,6 +408,7 @@ sharedEvent leios nodeNames e = case e of case blk of EventIB _ -> Shared.IBEnteredState{..} EventEB _ -> Shared.EBEnteredState{..} + EventLinearEB _ -> Shared.EBEnteredState{..} EventVote _ -> Shared.VTBundleEnteredState{..} sharedReceived :: T.Text -> String -> LeiosEventBlock -> Shared.Event @@ -378,6 +416,7 @@ sharedEvent leios nodeNames e = case e of case blk of EventIB _ -> Shared.IBReceived{..} EventEB _ -> Shared.EBReceived{..} + EventLinearEB _ -> Shared.EBReceived{..} EventVote _ -> Shared.VTBundleReceived{..} where sender = Nothing @@ -430,6 +469,8 @@ traceRelayLink1 connectionOptions = , lateIbInclusion = False , pipelinesToReferenceFromEB = 0 , activeVotingStageLength = 1 + , linearVoteStageLengthSlots = 8 + , linearDiffuseStageLengthSlots = 5 , pipeline = SingSingleVote , voteSendStage = Vote , votingFrequencyPerStage = 4 @@ -439,9 +480,10 @@ traceRelayLink1 connectionOptions = , sizes -- TODO: realistic sizes = SizesConfig - { inputBlockHeader = kilobytes 1 - , inputBlockBodyAvgSize = kilobytes 95 - , inputBlockBodyMaxSize = kilobytes 100 + { inputBlockHeader = kibibytes 1 + , inputBlockBodyAvgSize = kibibytes 95 + , inputBlockBodyMaxSize = kibibytes 100 + , endorseBlockBodyAvgSize = megabytes 5 , endorseBlock = \eb -> coerce (length eb.inputBlocks) * 32 + 32 + 128 , voteMsg = \v -> fromIntegral v.votes * 32 + 32 + 128 , certificate = const (50 * 1024) @@ -454,11 +496,15 @@ traceRelayLink1 connectionOptions = inputBlockValidation = const 0.1 , -- \^ hash matching and payload validation (incl. tx scripts) endorseBlockValidation = const 0.005 - , voteMsgValidation = const 0.005 + , linearEndorseBlockValidation = const 1 + , -- \^ hash matching and payload validation (incl. tx scripts) + voteMsgValidation = const 0.005 , certificateGeneration = const 0.050 , inputBlockGeneration = const 0 , endorseBlockGeneration = const 0 + , linearEndorseBlockGeneration = const 0 , voteMsgGeneration = const (const 0) + , linearVoteMsgGeneration = const (const 0) , certificateValidation = const 0 } , ibDiffusion = RelayDiffusionConfig FreshestFirst 100 100 1 diff --git a/simulation/src/LeiosProtocol/Short/VizSim.hs b/simulation/src/LeiosProtocol/Short/VizSim.hs index da149deae..c2994114a 100644 --- a/simulation/src/LeiosProtocol/Short/VizSim.hs +++ b/simulation/src/LeiosProtocol/Short/VizSim.hs @@ -31,7 +31,7 @@ import GHC.Records import qualified Graphics.Rendering.Cairo as Cairo import LeiosProtocol.Common hiding (Point) import LeiosProtocol.Relay (Message (MsgRespondBodies, MsgRespondHeaders), RelayMessage, RelayState, relayMessageLabel) -import LeiosProtocol.Short.Node (BlockEvent (..), LeiosEventBlock (..), LeiosMessage (..), LeiosNodeEvent (..), RelayEBMessage, RelayIBMessage, RelayVoteMessage) +import LeiosProtocol.Short.Node (BlockEvent (..), LeiosEventBlock (..), LeiosMessage (..), LeiosNodeEvent (..), RelayEBMessage, RelayIBMessage, RelayLinearEBMessage, RelayVoteMessage) import LeiosProtocol.Short.Sim (LeiosEvent (..), LeiosTrace, exampleTrace1) import ModelTCP import Network.TypedProtocol @@ -72,12 +72,14 @@ examplesLeiosSimVizConfig = LeiosVizConfig{..} relayIBMessageColor = relayMessageColor $ \(InputBlockId x y) -> (x, y) relayEBMessageColor :: RelayEBMessage -> (Double, Double, Double) relayEBMessageColor = relayMessageColor $ \(EndorseBlockId x y) -> (x, y) + relayLinearEBMessageColor = relayMessageColor $ \(EndorseBlockId x y) -> (x, y) relayVoteMessageColor :: RelayVoteMessage -> (Double, Double, Double) relayVoteMessageColor = relayMessageColor $ \(VoteId x y) -> (x, y) relayIBMessageText :: RelayIBMessage -> Maybe String relayIBMessageText = relayMessageText "IB:" relayEBMessageText :: RelayEBMessage -> Maybe String relayEBMessageText = relayMessageText "EB:" + relayLinearEBMessageText = relayMessageText "EB:" relayVoteMessageText :: RelayVoteMessage -> Maybe String relayVoteMessageText = relayMessageText "Vote:" relayMessageText prefix (ProtocolMessage (SomeMessage msg)) = Just $ prefix ++ relayMessageLabel msg @@ -97,8 +99,7 @@ type LeiosSimVizModel = LeiosSimVizState -- | The vizualisation state within the data model for the relay simulation -data LeiosSimVizState - = LeiosSimVizState +data LeiosSimVizState = LeiosSimVizState { vizWorld :: !World , vizNodePos :: !(Map NodeId Point) , vizNodeStakes :: !(Map NodeId StakeFraction) @@ -349,6 +350,7 @@ leiosSimVizModel LeiosModelConfig{recentSpan} = _ -> vs.ibsInRBs , ebDiffusionLatency = accumDiffusionLatency' now nid event x.id x vs.ebDiffusionLatency } + EventLinearEB _x -> vs EventVote x -> vs { voteMsgs = adjustNumVotes event x $ accumLeiosMsgs now nid event x vs.voteMsgs @@ -517,6 +519,7 @@ accumDataTransmitted msg TcpMsgForecast{..} DataTransmitted{..} = (payload, block) = case msg of RelayIB ibmsg -> (payloadIB ibmsg, blockRelay (Just . sum . map (.size)) ibmsg) RelayEB ebmsg -> (Nothing, blockRelay (const Nothing) ebmsg) + RelayLinearEB ebmsg -> (Nothing, blockRelay (const Nothing) ebmsg) RelayVote votemsg -> (Nothing, blockRelay (const Nothing) votemsg) PraosMsg (PraosMessage pmsg) -> case pmsg of (Left (ProtocolMessage (SomeMessage csmsg))) -> @@ -664,14 +667,15 @@ recentPrune now (RecentRate pq) = -- The vizualisation rendering -- -data LeiosVizConfig - = LeiosVizConfig +data LeiosVizConfig = LeiosVizConfig { praosMessageColor :: PraosMessage RankingBlockBody -> (Double, Double, Double) , praosMessageText :: PraosMessage RankingBlockBody -> Maybe String , relayIBMessageColor :: RelayIBMessage -> (Double, Double, Double) , relayIBMessageText :: RelayIBMessage -> Maybe String , relayEBMessageColor :: RelayEBMessage -> (Double, Double, Double) , relayEBMessageText :: RelayEBMessage -> Maybe String + , relayLinearEBMessageColor :: RelayLinearEBMessage -> (Double, Double, Double) + , relayLinearEBMessageText :: RelayLinearEBMessage -> Maybe String , relayVoteMessageColor :: RelayVoteMessage -> (Double, Double, Double) , relayVoteMessageText :: RelayVoteMessage -> Maybe String } @@ -681,6 +685,7 @@ leiosMessageColor LeiosVizConfig{..} msg = case msg of RelayIB x -> relayIBMessageColor x RelayEB x -> relayEBMessageColor x + RelayLinearEB x -> relayLinearEBMessageColor x RelayVote x -> relayVoteMessageColor x PraosMsg x -> praosMessageColor x @@ -689,6 +694,7 @@ leiosMessageText LeiosVizConfig{..} msg = case msg of RelayIB x -> relayIBMessageText x RelayEB x -> relayEBMessageText x + RelayLinearEB x -> relayLinearEBMessageText x RelayVote x -> relayVoteMessageText x PraosMsg x -> praosMessageText x @@ -759,8 +765,7 @@ leiosSimVizRenderModel Cairo.newPath -- draw all the messages within the clipping region of the link renderMessagesInFlight - ( TcpSimVizConfig $ leiosMessageColor cfg - ) + (TcpSimVizConfig $ leiosMessageColor cfg) now fromPos toPos diff --git a/simulation/src/LeiosProtocol/Short/VizSimP2P.hs b/simulation/src/LeiosProtocol/Short/VizSimP2P.hs index 5fc51a8b1..f374340e9 100644 --- a/simulation/src/LeiosProtocol/Short/VizSimP2P.hs +++ b/simulation/src/LeiosProtocol/Short/VizSimP2P.hs @@ -119,8 +119,7 @@ messageLegend = data MsgTag = RB | IB | EB | VT deriving (Show, Enum, Bounded) -data LeiosP2PSimVizConfig - = LeiosP2PSimVizConfig +data LeiosP2PSimVizConfig = LeiosP2PSimVizConfig { nodeMessageColor :: RankingBlockHeader -> (Double, Double, Double) , ibColor :: InputBlockHeader -> (Double, Double, Double) , ebColor :: EndorseBlock -> (Double, Double, Double) @@ -668,6 +667,7 @@ isLeiosMessageControl msg0 = _ -> True RelayIB msg -> isRelayMessageControl msg RelayEB msg -> isRelayMessageControl msg + RelayLinearEB msg -> isRelayMessageControl msg RelayVote msg -> isRelayMessageControl msg isRelayMessageControl :: RelayMessage id header body -> Bool @@ -700,9 +700,11 @@ defaultVizConfig voteSendStage stageLength numCores maxBandwidthPerNode = _ -> Nothing RelayIB msg -> (IB,) <$> relayMessageColor ibColor msg RelayEB msg -> (EB,) <$> relayMessageColor ebColor msg + RelayLinearEB msg -> (EB,) <$> relayMessageColor linearEbColor msg RelayVote msg -> (VT,) <$> relayMessageColor voteColor msg ibColor = pipelineColor Propose . (hash . (.id) &&& (.slot)) ebColor = pipelineColor Endorse . (hash . (.id) &&& (.slot)) + linearEbColor = pipelineColor Endorse . (hash . (.id) &&& (.slot)) voteColor = pipelineColor voteSendStage . (hash . (.id) &&& (.slot)) relayMessageColor :: (body -> Dia.Colour Double) -> RelayMessage id header body -> Maybe (Dia.Colour Double) relayMessageColor f (ProtocolMessage (SomeMessage msg)) = case msg of @@ -783,6 +785,6 @@ example2 ] where processingCores = maximum $ Map.elems p2pNodeCores - config = defaultVizConfig voteSendStage 5 processingCores (10 * kilobytes 1000) -- TODO: calculate from p2pLinks + config = defaultVizConfig voteSendStage 5 processingCores (10 * kibibytes 1000) -- TODO: calculate from p2pLinks modelConfig = config.model model = leiosSimVizModel modelConfig (exampleTrace2' rng leiosConfig p2pNetwork False) diff --git a/simulation/src/LeiosProtocol/VizSimTestRelay.hs b/simulation/src/LeiosProtocol/VizSimTestRelay.hs index d21f35820..950997e00 100644 --- a/simulation/src/LeiosProtocol/VizSimTestRelay.hs +++ b/simulation/src/LeiosProtocol/VizSimTestRelay.hs @@ -47,8 +47,8 @@ example1 = where trace = traceRelayLink1 - (mkTcpConnProps 0.3 (kilobytes 1000)) - (UniformGenerationPattern (kilobytes 100) 0.2 5.0) + (mkTcpConnProps 0.3 (kibibytes 1000)) + (UniformGenerationPattern (kibibytes 100) 0.2 5.0) example2 :: Visualization example2 = @@ -62,8 +62,8 @@ example2 = where trace = traceRelayLink4 - (mkTcpConnProps 0.3 (kilobytes 1000)) - (UniformGenerationPattern (kilobytes 100) 0.2 5.0) + (mkTcpConnProps 0.3 (kibibytes 1000)) + (UniformGenerationPattern (kibibytes 100) 0.2 5.0) example3 :: Visualization example3 = @@ -77,9 +77,9 @@ example3 = where trace = traceRelayLink4Asymmetric - (mkTcpConnProps 0.2 (kilobytes 1000)) - (mkTcpConnProps 0.3 (kilobytes 1000)) - (UniformGenerationPattern (kilobytes 100) 0.2 5.0) + (mkTcpConnProps 0.2 (kibibytes 1000)) + (mkTcpConnProps 0.3 (kibibytes 1000)) + (UniformGenerationPattern (kibibytes 100) 0.2 5.0) examplesRelaySimVizConfig :: RelaySimVizConfig examplesRelaySimVizConfig = diff --git a/simulation/src/Main.hs b/simulation/src/Main.hs index 617e3e0d2..4db660e63 100644 --- a/simulation/src/Main.hs +++ b/simulation/src/Main.hs @@ -24,7 +24,7 @@ import qualified LeiosProtocol.Short.DataSimP2P as DataShortLeiosP2P import qualified LeiosProtocol.Short.VizSim as VizShortLeios import qualified LeiosProtocol.Short.VizSimP2P as VizShortLeiosP2P import qualified LeiosProtocol.VizSimTestRelay as VizSimTestRelay -import ModelTCP (kilobytes) +import ModelTCP (kibibytes) import Options.Applicative ( Alternative ((<|>)), HasValue, @@ -523,7 +523,7 @@ parserOverrideUnlimited = ( long "override-unlimited-bandwidth" <> metavar "BYTESPERSEC" <> help "Values to use for link bandwidth instead of unlimited (which is not supported yet)." - <> shownDefValue (fromBytes $ kilobytes 1000) + <> shownDefValue (fromBytes $ kibibytes 1000) ) -------------------------------------------------------------------------------- diff --git a/simulation/src/ModelTCP.hs b/simulation/src/ModelTCP.hs index 39ff81d39..b413f9649 100644 --- a/simulation/src/ModelTCP.hs +++ b/simulation/src/ModelTCP.hs @@ -16,9 +16,11 @@ module ModelTCP ( TcpMsgForecast (..), forecastTcpMsgSend, TcpEvent (..), + lensTcpEvent, traceTcpSend, mkTcpConnProps, - kilobytes, + kibibytes, + megabytes, segments, bytesToKb, ) where @@ -45,7 +47,7 @@ data TcpConnProps = TcpConnProps -- links. , tcpBandwidth :: !Bytes -- ^ The sender serialisation bandwidth in bytes per sec. Typical values - -- would be a few hundred kilobytes per second, e.g. 100 kb\/s is + -- would be a few hundred kibibytes per second, e.g. 100 kb\/s is -- 0.8 MBit\/s, which is close to 1 MBit\/s once overheads are included. , tcpReceiverWindow :: !Bytes -- ^ The size of the receiver's window, which is an upper bound on the @@ -75,8 +77,11 @@ mkTcpConnProps latency bandwidth = -- set it big enough to not constrain the bandwidth recvwnd = Bytes (ceiling (fromIntegral (fromBytes bandwidth) * latency * 2)) -kilobytes :: Int -> Bytes -kilobytes kb = Bytes kb * 1024 +kibibytes :: Int -> Bytes +kibibytes kb = Bytes kb * 1024 + +megabytes :: Int -> Bytes +megabytes mb = Bytes mb * 1000000 segments :: Int -> Bytes segments s = Bytes s * segmentSize @@ -362,6 +367,9 @@ data TcpEvent msg [TcpMsgForecast] -- tcp internal activity deriving (Show, Functor) +lensTcpEvent :: Functor f => (a -> f b) -> TcpEvent a -> f (TcpEvent b) +lensTcpEvent f (TcpSendMsg x y z) = (\x' -> TcpSendMsg x' y z) <$> f x + traceTcpSend :: TcpConnProps -> -- | message sizes to send eagerly, back-to-back diff --git a/simulation/src/PraosProtocol/BlockFetch.hs b/simulation/src/PraosProtocol/BlockFetch.hs index d4b90fe1c..df5a27bf0 100644 --- a/simulation/src/PraosProtocol/BlockFetch.hs +++ b/simulation/src/PraosProtocol/BlockFetch.hs @@ -231,8 +231,7 @@ blockFetchProducer st = idle --- BlockFetch Client -------------------------------- -newtype BlockRequest - = BlockRequest {blockRequestFragments :: [AnchoredFragment BlockHeader]} +newtype BlockRequest = BlockRequest {blockRequestFragments :: [AnchoredFragment BlockHeader]} deriving (Show) deriving newtype (Semigroup) -- TODO: we could merge the fragments. @@ -636,7 +635,7 @@ setupValidatorThreads :: m ([m ()], Block BlockBody -> m () -> m ()) setupValidatorThreads cfg st queue = do waitingVar <- newTVarIO Map.empty - let processWaitingThread = processWaiting' st.blocksVar waitingVar + let processWaitingThread = processWaiting' (readTVar st.blocksVar) waitingVar let waitForPrev block task = atomically $ case blockPrevHash block of GenesisHash -> queue task @@ -650,17 +649,17 @@ setupValidatorThreads cfg st queue = do return ([processWaitingThread], add) processWaiting' :: - forall m a b. - (MonadSTM m, MonadDelay m) => - TVar m (Map ConcreteHeaderHash a) -> - TVar m (Map ConcreteHeaderHash [STM m b]) -> + forall m k a b. + (Ord k, MonadSTM m, MonadDelay m) => + STM m (Map k a) -> + TVar m (Map k [STM m b]) -> m () -processWaiting' blocksVar waitingVar = go +processWaiting' getBlocks waitingVar = go where go = forever $ join $ atomically $ do waiting <- readTVar waitingVar when (Map.null waiting) retry - blocks <- readTVar blocksVar + blocks <- getBlocks let toValidate = Map.intersection waiting blocks when (Map.null toValidate) retry writeTVar waitingVar $! waiting Map.\\ toValidate diff --git a/simulation/src/PraosProtocol/BlockGeneration.hs b/simulation/src/PraosProtocol/BlockGeneration.hs index 24471431a..02c8bed44 100644 --- a/simulation/src/PraosProtocol/BlockGeneration.hs +++ b/simulation/src/PraosProtocol/BlockGeneration.hs @@ -46,7 +46,7 @@ praosBlockGenerator :: praosBlockGenerator rng tracer praosConfig slotConfig prefix cpsVar addBlockSt queue = do sched <- mkScheduler rng (const $ pure [((), Just $ \p -> if p <= praosConfig.blockFrequencyPerSlot then 1 else 0)]) blockGenerator - BlockGeneratorConfig{slotConfig, execute = execute sched} + BlockGeneratorConfig{slotConfig, execute = execute sched, initial = 0 :: Int} where execute sched sl = lift $ do wins <- sched sl diff --git a/simulation/src/PraosProtocol/Common.hs b/simulation/src/PraosProtocol/Common.hs index 85d82a60c..9cba77103 100644 --- a/simulation/src/PraosProtocol/Common.hs +++ b/simulation/src/PraosProtocol/Common.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE RecordWildCards #-} @@ -31,7 +32,7 @@ module PraosProtocol.Common ( PraosNodeEvent (..), PraosConfig (..), MessageSize (..), - kilobytes, + kibibytes, module TimeCompat, defaultPraosConfig, CPUTask (..), @@ -54,7 +55,7 @@ import qualified Data.Map.Strict as Map import Data.Word (Word8) import GHC.Word (Word64) import LeiosProtocol.Config (RelayStrategy (RequestFromFirst)) -import ModelTCP (kilobytes) +import ModelTCP (kibibytes) import Ouroboros.Network.Mock.ProducerState as ProducerState import PraosProtocol.Common.AnchoredFragment (Anchor (..), AnchoredFragment) import PraosProtocol.Common.Chain (Chain (..), foldChain, pointOnChain) @@ -179,9 +180,9 @@ defaultPraosConfig = , blockValidationDelay = const 0.1 , headerValidationDelay = const 0.005 , blockGenerationDelay = const 0 - , headerSize = kilobytes 1 - , bodySize = const $ kilobytes 95 - , bodyMaxSize = kilobytes 96 + , headerSize = kibibytes 1 + , bodySize = const $ kibibytes 95 + , bodyMaxSize = kibibytes 96 , configureConnection = mkConnectionConfig True True , relayStrategy = RequestFromFirst } @@ -189,9 +190,12 @@ defaultPraosConfig = instance Default (PraosConfig body) where def = defaultPraosConfig -data BlockGeneratorConfig m = BlockGeneratorConfig +data BlockGeneratorConfig m + = forall s. + BlockGeneratorConfig { slotConfig :: SlotConfig - , execute :: SlotNo -> StateT Int m () + , execute :: SlotNo -> StateT s m () + , initial :: s } blockGenerator :: @@ -199,12 +203,12 @@ blockGenerator :: (MonadSTM m, MonadDelay m, MonadTime m) => BlockGeneratorConfig m -> m () -blockGenerator BlockGeneratorConfig{..} = go (0, 0) +blockGenerator BlockGeneratorConfig{..} = go initial 0 where - go (!blkId, !tgtSlot) = do + go !x !tgtSlot = do slot <- waitNextSlot slotConfig tgtSlot - blkId' <- execStateT (execute slot) blkId - go (blkId', slot + 1) + x' <- execStateT (execute slot) x + go x' (slot + 1) -- | @waitNextSlot cfg targetSlot@ waits until the beginning of -- @targetSlot@ if that's now or in the future, otherwise the closest slot. diff --git a/simulation/src/PraosProtocol/ExamplesPraosP2P.hs b/simulation/src/PraosProtocol/ExamplesPraosP2P.hs index f8f8c3d19..7a13a05c0 100644 --- a/simulation/src/PraosProtocol/ExamplesPraosP2P.hs +++ b/simulation/src/PraosProtocol/ExamplesPraosP2P.hs @@ -171,8 +171,7 @@ diffusionSampleModel p2pTopography fp = SampleModel initState accum render timesDiff _ _ = undefined let durations = Map.intersectionWith - ( Map.intersectionWith timesDiff - ) + (Map.intersectionWith timesDiff) fetchRequests receivedBodies let average_block_fetch_duration = diff --git a/simulation/src/PraosProtocol/SimBlockFetch.hs b/simulation/src/PraosProtocol/SimBlockFetch.hs index bda39994d..d39b4a4f2 100644 --- a/simulation/src/PraosProtocol/SimBlockFetch.hs +++ b/simulation/src/PraosProtocol/SimBlockFetch.hs @@ -78,7 +78,7 @@ traceRelayLink1 tcpprops = return () where -- Soon-To-Be-Shared Chain - bchain = mkChainSimple (kilobytes 1) $ [BlockBody (BS.pack [i]) (kilobytes 95) | i <- [0 .. 10]] + bchain = mkChainSimple (kibibytes 1) $ [BlockBody (BS.pack [i]) (kibibytes 95) | i <- [0 .. 10]] -- Block-Fetch Controller & Consumer nodeA :: (MonadAsync m, MonadDelay m, MonadSTM m) => PraosConfig BlockBody -> Chan m (ProtocolMessage (BlockFetchState BlockBody)) -> m () @@ -93,8 +93,7 @@ traceRelayLink1 tcpprops = concurrently_ processingThread $ concurrently_ (mapConcurrently_ id ts) $ concurrently_ - ( blockFetchController nullTracer praosConfig st - ) + (blockFetchController nullTracer praosConfig st) ( runBlockFetchConsumer nullTracer praosConfig chan $ initBlockFetchConsumerStateForPeerId nullTracer peerId st submitFetchedBlock ) diff --git a/simulation/src/PraosProtocol/SimChainSync.hs b/simulation/src/PraosProtocol/SimChainSync.hs index 31103bf16..ae16d95e2 100644 --- a/simulation/src/PraosProtocol/SimChainSync.hs +++ b/simulation/src/PraosProtocol/SimChainSync.hs @@ -94,7 +94,7 @@ traceRelayLink1 tcpprops = let nullTracer = Tracer $ const $ return () runChainConsumer nullTracer cfg chan st producerNode chan = do - let chain = mkChainSimple (kilobytes 1) $ [BlockBody (BS.pack [i]) (kilobytes 95) | i <- [0 .. 10]] + let chain = mkChainSimple (kibibytes 1) $ [BlockBody (BS.pack [i]) (kibibytes 95) | i <- [0 .. 10]] let (cps, fId) = initFollower GenesisPoint $ initChainProducerState chain st <- newTVarIO cps runChainProducer chan fId st diff --git a/simulation/src/PraosProtocol/VizSimBlockFetch.hs b/simulation/src/PraosProtocol/VizSimBlockFetch.hs index c3831aa09..1dfd7a80c 100644 --- a/simulation/src/PraosProtocol/VizSimBlockFetch.hs +++ b/simulation/src/PraosProtocol/VizSimBlockFetch.hs @@ -77,8 +77,7 @@ type BlockFetchVizModel = BlockFetchVizState -- | The vizualisation state within the data model for the relay simulation -data BlockFetchVizState - = BlockFetchVizState +data BlockFetchVizState = BlockFetchVizState { vizWorld :: !World , vizNodePos :: !(Map NodeId Point) , vizNodeLinks :: !(Map Link LinkPoints) @@ -262,8 +261,7 @@ recentPrune now (RecentRate pq) = -- The vizualisation rendering -- -data BlockFetchVizConfig - = BlockFetchVizConfig +data BlockFetchVizConfig = BlockFetchVizConfig { ptclMessageColor :: BlockFetchMessage BlockBody -> (Double, Double, Double) , ptclMessageText :: BlockFetchMessage BlockBody -> Maybe String } diff --git a/simulation/src/PraosProtocol/VizSimChainSync.hs b/simulation/src/PraosProtocol/VizSimChainSync.hs index e116bf4f6..b8351fa8f 100644 --- a/simulation/src/PraosProtocol/VizSimChainSync.hs +++ b/simulation/src/PraosProtocol/VizSimChainSync.hs @@ -83,8 +83,7 @@ type ChainSyncVizModel = ChainSyncVizState -- | The vizualisation state within the data model for the relay simulation -data ChainSyncVizState - = ChainSyncVizState +data ChainSyncVizState = ChainSyncVizState { vizWorld :: !World , vizNodePos :: !(Map NodeId Point) , vizNodeLinks :: !(Map Link LinkPoints) @@ -336,8 +335,7 @@ recentPrune now (RecentRate pq) = -- The vizualisation rendering -- -data ChainSyncVizConfig - = ChainSyncVizConfig +data ChainSyncVizConfig = ChainSyncVizConfig { nodeMessageColor :: BlockHeader -> (Double, Double, Double) , ptclMessageColor :: ChainSyncMessage -> (Double, Double, Double) , nodeMessageText :: BlockHeader -> Maybe String diff --git a/simulation/src/PraosProtocol/VizSimPraos.hs b/simulation/src/PraosProtocol/VizSimPraos.hs index 7e0280a13..41bd26cf6 100644 --- a/simulation/src/PraosProtocol/VizSimPraos.hs +++ b/simulation/src/PraosProtocol/VizSimPraos.hs @@ -84,8 +84,7 @@ type PraosSimVizModel = PraosSimVizState -- | The vizualisation state within the data model for the relay simulation -data PraosSimVizState - = PraosSimVizState +data PraosSimVizState = PraosSimVizState { vizWorld :: !World , vizNodePos :: !(Map NodeId Point) , vizNodeLinks :: !(Map Link LinkPoints) @@ -357,8 +356,7 @@ recentPrune now (RecentRate pq) = -- The vizualisation rendering -- type PraosVizConfig = PraosVizConfig' BlockBody -data PraosVizConfig' body - = PraosVizConfig +data PraosVizConfig' body = PraosVizConfig { chainSyncMessageColor :: ChainSyncMessage -> (Double, Double, Double) , chainSyncMessageText :: ChainSyncMessage -> Maybe String , blockFetchMessageColor :: BlockFetchMessage body -> (Double, Double, Double) diff --git a/simulation/src/PraosProtocol/VizSimPraosP2P.hs b/simulation/src/PraosProtocol/VizSimPraosP2P.hs index d40170ae6..54af30ac0 100644 --- a/simulation/src/PraosProtocol/VizSimPraosP2P.hs +++ b/simulation/src/PraosProtocol/VizSimPraosP2P.hs @@ -38,8 +38,7 @@ import VizUtils -- The vizualisation rendering -- -data PraosP2PSimVizConfig - = PraosP2PSimVizConfig +data PraosP2PSimVizConfig = PraosP2PSimVizConfig { nodeMessageColor :: BlockHeader -> (Double, Double, Double) , ptclMessageColor :: PraosMessage BlockBody -> Maybe (Double, Double, Double) } diff --git a/simulation/src/Topology.hs b/simulation/src/Topology.hs index 89d84b875..8be6ec4cd 100644 --- a/simulation/src/Topology.hs +++ b/simulation/src/Topology.hs @@ -66,7 +66,7 @@ import qualified Database.SQLite.Simple.ToField as SQLite (ToField) import GHC.Generics (Generic) import GHC.Records (HasField (..)) import LeiosTopology -import ModelTCP (Bytes, kilobytes) +import ModelTCP (Bytes, kibibytes) import P2P (Latency, Link, Link' (..), P2PTopography (..), P2PTopographyCharacteristics (..), genArbitraryP2PTopography, pattern (:<-)) import SimTypes (NodeId (..), NumCores (..), Path (..), Point (..), StakeFraction (StakeFraction), World (..), WorldDimensions) import System.Exit (exitFailure) @@ -423,7 +423,7 @@ topologyToNetwork P2PTopography{..} = P2PNetwork{p2pLinks = fmap (,defaultBandwi p2pNodeStakes = Map.map (const $ StakeFraction $ 1 / numNodes) p2pNodes numNodes = fromIntegral $ Map.size p2pNodes -- TODO: unrestricted bandwidth is unsupported - defaultBandwidthBps = Just (kilobytes 1000) + defaultBandwidthBps = Just (kibibytes 1000) p2pAdversaries = Nothing overrideUnlimitedBandwidth :: Bytes -> P2PNetwork -> P2PNetwork @@ -480,8 +480,7 @@ newtype RegionName = RegionName {unRegionName :: Text} deriving stock (Show, Eq, Ord) deriving newtype (FromJSON, ToJSON) -data BenchTopologyNode - = BenchTopologyNode +data BenchTopologyNode = BenchTopologyNode { name :: !NodeName , nodeId :: !NodeId , org :: !(Maybe OrgName)