From 163f7ed99c0cb8099d838631c3093ce38fac7927 Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Thu, 31 Oct 2024 15:38:58 +0100 Subject: [PATCH] Sampling block diffusion from 1000 nodes praos sim (#58) Co-authored-by: Wen Kokke --- .github/workflows/ci.yaml | 10 + cabal.project | 7 + hooks/pre-commit | 34 ++ simulation/ouroboros-leios-sim.cabal | 15 +- simulation/src/ChanDriver.hs | 1 + simulation/src/PraosProtocol/BlockFetch.hs | 86 +++-- .../src/PraosProtocol/BlockGeneration.hs | 42 +-- simulation/src/PraosProtocol/Common.hs | 56 +++- .../PraosProtocol/Common/AnchoredFragment.hs | 2 +- .../src/PraosProtocol/ExamplesPraosP2P.hs | 316 ++++++++++++------ simulation/src/PraosProtocol/PraosNode.hs | 47 +-- simulation/src/PraosProtocol/SimBlockFetch.hs | 23 +- simulation/src/PraosProtocol/SimPraos.hs | 15 +- simulation/src/PraosProtocol/SimPraosP2P.hs | 6 +- simulation/src/PraosProtocol/VizSimPraos.hs | 122 +++++-- .../src/PraosProtocol/VizSimPraosP2P.hs | 50 +-- simulation/src/Sample.hs | 30 ++ simulation/src/SampleMain.hs | 85 +++++ simulation/src/TimeCompat.hs | 1 + simulation/src/VizUtils.hs | 8 + 20 files changed, 705 insertions(+), 251 deletions(-) create mode 100755 hooks/pre-commit create mode 100644 simulation/src/Sample.hs create mode 100644 simulation/src/SampleMain.hs diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 3736d12f..a8fc2bd6 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -102,6 +102,16 @@ jobs: - name: Run tests run: cabal test all + fourmolu-check: + name: Check Haskell sources with fourmolu + runs-on: ubuntu-22.04 + steps: + # Note that you must checkout your code before running haskell-actions/run-fourmolu + - uses: actions/checkout@v4 + - uses: haskell-actions/run-fourmolu@v11 + with: + version: "0.15.0.0" + build-docusaurus: runs-on: ubuntu-22.04 steps: diff --git a/cabal.project b/cabal.project index 75943ad8..f35a3b6a 100644 --- a/cabal.project +++ b/cabal.project @@ -36,3 +36,10 @@ source-repository-package ntp-client cardano-client +source-repository-package + type: git + location: https://github.com/Saizan/io-sim.git + tag: 2ea49cd65ae82ec11826e2c966d77ffb877bca8c + subdir: + io-sim + io-classes \ No newline at end of file diff --git a/hooks/pre-commit b/hooks/pre-commit new file mode 100755 index 00000000..f3c3f40f --- /dev/null +++ b/hooks/pre-commit @@ -0,0 +1,34 @@ +#!/bin/sh + +# To install as a Git pre-commit hook, run: +# +# > ln hooks/pre-commit .git/hooks/pre-commit +# + +# Check for fourmolu +fourmolu_required_version="0.15.0.0" +fourmolu="$(which fourmolu)" +if [ "${fourmolu}" = "" ]; then + echo "pre-commit: Requires fourmolu version ${fourmolu_required_version}; no version found" + exit 1 +fi +fourmolu_installed_version="$($fourmolu --version | head -n 1 | cut -d' ' -f2)" +if [ ! "${fourmolu_installed_version}" = "${fourmolu_required_version}" ]; then + echo "pre-commit: Requires fourmolu version ${fourmolu_required_version}; found version ${fourmolu_installed_version}" + exit 1 +fi + +# Check for unstaged Haskell files +unstaged_haskell_files="$(git ls-files --exclude-standard --no-deleted --deduplicate --modified '*.hs')" +if [ ! "${unstaged_haskell_files}" = "" ]; then + echo "pre-commit: Found unstaged Haskell files" + echo "${unstaged_haskell_files}" + exit 1 +fi + +# Check Haskell files with fourmolu +echo "Formatting Haskell source files with fourmolu version ${fourmolu_required_version}" +if ! git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 fourmolu --mode=check --quiet; then + git ls-files --exclude-standard --no-deleted --deduplicate '*.hs' | xargs -L 1 fourmolu --mode=inplace --quiet + exit 1 +fi diff --git a/simulation/ouroboros-leios-sim.cabal b/simulation/ouroboros-leios-sim.cabal index cebfaa06..455afaad 100644 --- a/simulation/ouroboros-leios-sim.cabal +++ b/simulation/ouroboros-leios-sim.cabal @@ -40,17 +40,18 @@ library PraosProtocol.Common PraosProtocol.Common.AnchoredFragment PraosProtocol.Common.Chain + PraosProtocol.ExamplesPraosP2P PraosProtocol.PraosNode PraosProtocol.SimBlockFetch PraosProtocol.SimChainSync PraosProtocol.SimPraos PraosProtocol.SimPraosP2P - PraosProtocol.ExamplesPraosP2P PraosProtocol.VizSimBlockFetch PraosProtocol.VizSimChainSync PraosProtocol.VizSimPraos PraosProtocol.VizSimPraosP2P RelayProtocol + Sample SimRelay SimRelayP2P SimTCPLinks @@ -66,6 +67,7 @@ library -- other-extensions: build-depends: + , aeson , array , base , bytestring @@ -106,3 +108,14 @@ executable viz default-language: Haskell2010 ghc-options: -Wall + +executable sample + main-is: src/SampleMain.hs + build-depends: + , base + , filepath + , optparse-applicative + , ouroboros-leios-sim + + default-language: Haskell2010 + ghc-options: -Wall diff --git a/simulation/src/ChanDriver.hs b/simulation/src/ChanDriver.hs index 28df86c5..7c70d942 100644 --- a/simulation/src/ChanDriver.hs +++ b/simulation/src/ChanDriver.hs @@ -6,6 +6,7 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/simulation/src/PraosProtocol/BlockFetch.hs b/simulation/src/PraosProtocol/BlockFetch.hs index c1b062e3..9798dbf8 100644 --- a/simulation/src/PraosProtocol/BlockFetch.hs +++ b/simulation/src/PraosProtocol/BlockFetch.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} @@ -13,6 +14,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -36,6 +38,7 @@ import Control.Concurrent.Class.MonadSTM ( ) import Control.Exception (assert) import Control.Monad (forM, forever, guard, unless, void, when, (<=<)) +import Control.Tracer (Tracer, traceWith) import Data.Bifunctor (second) import qualified Data.List as List import Data.Map.Strict (Map) @@ -239,16 +242,24 @@ data BlockFetchConsumerState m = BlockFetchConsumerState , removeInFlight :: [Point Block] -> m () } -runBlockFetchConsumer :: MonadSTM m => Chan m BlockFetchMessage -> BlockFetchConsumerState m -> m () -runBlockFetchConsumer chan blockFetchConsumerState = - void $ runPeerWithDriver (chanDriver decideBlockFetchState chan) (blockFetchConsumer blockFetchConsumerState) +runBlockFetchConsumer :: + (MonadSTM m, MonadDelay m) => + Tracer m PraosNodeEvent -> + PraosConfig -> + Chan m BlockFetchMessage -> + BlockFetchConsumerState m -> + m () +runBlockFetchConsumer tracer cfg chan blockFetchConsumerState = + void $ runPeerWithDriver (chanDriver decideBlockFetchState chan) (blockFetchConsumer tracer cfg blockFetchConsumerState) blockFetchConsumer :: forall m. - MonadSTM m => + (MonadSTM m, MonadDelay m) => + Tracer m PraosNodeEvent -> + PraosConfig -> BlockFetchConsumerState m -> TC.Client BlockFetchState NonPipelined StIdle m () -blockFetchConsumer st = idle +blockFetchConsumer tracer cfg st = idle where -- does not support preemption of in-flight requests. blockRequest :: STM m (AnchoredFragment BlockHeader) @@ -278,22 +289,18 @@ blockFetchConsumer st = idle streaming range headers = TC.Await $ \msg -> case (msg, headers) of (MsgBatchDone, []) -> idle - (MsgBlock block, header : headers') -> TC.Effect $ do - ifValidBlockBody - header - block - ( do - st.addFetchedBlock (Block header block) - return (streaming range headers') - ) - (error $ "blockFetchConsumer: invalid block\n" ++ show (Block header block)) -- TODO + (MsgBlock body, header : headers') -> TC.Effect $ do + let block = Block header body + traceWith tracer $ PraosNodeEventReceived block + threadDelaySI (cfg.blockValidationDelay block) + if blockInvariant block + then do + st.addFetchedBlock block + traceWith tracer (PraosNodeEventEnterState block) + return (streaming range headers') + else error $ "blockFetchConsumer: invalid block\n" ++ show block -- TODO (MsgBatchDone, _ : _) -> TC.Effect $ error "TooFewBlocks" -- TODO? (MsgBlock _, []) -> TC.Effect $ error "TooManyBlocks" -- TODO? - ifValidBlockBody hdr bdy t f = do - -- TODO: threadDelay - if blockInvariant $ Block hdr bdy - then t - else f -------------------------------------------- ---- BlockFetch controller @@ -377,11 +384,11 @@ newBlockFetchControllerState chain = atomically $ do cpsVar <- newTVar $ initChainProducerState chain return BlockFetchControllerState{..} -blockFetchController :: forall m. MonadSTM m => BlockFetchControllerState m -> m () -blockFetchController st@BlockFetchControllerState{..} = forever (atomically makeRequests) +blockFetchController :: forall m. MonadSTM m => Tracer m PraosNodeEvent -> BlockFetchControllerState m -> m () +blockFetchController tracer st@BlockFetchControllerState{..} = forever makeRequests where - makeRequests :: STM m () - makeRequests = do + makeRequests :: m () + makeRequests = (traceNewTip tracer =<<) . atomically $ do let peerChainVars = (map . second) (.peerChainVar) $ Map.toList peers mchainSwitch <- longestChainSelection peerChainVars (asReadOnly cpsVar) blockHeader case mchainSwitch of @@ -390,13 +397,14 @@ blockFetchController st@BlockFetchControllerState{..} = forever (atomically make blocks <- readTVar blocksVar chain <- chainState <$> readTVar cpsVar let chainUpdate = initMissingBlocksChain blocks chain fragment - useful <- updateChains st chainUpdate + (useful, mtip) <- updateChains st chainUpdate whenMissing chainUpdate $ \_missingChain -> do -- TODO: filterFetched could be reusing the missingChain suffix. br <- filterInFlight <=< filterFetched $ fragment if null br.blockRequestFragments then unless useful retry else addRequest peerId br + return mtip filterFetched :: AnchoredFragment BlockHeader -> STM m BlockRequest filterFetched fr = do @@ -504,24 +512,26 @@ updateChains :: MonadSTM m => BlockFetchControllerState m -> ChainsUpdate -> - STM m Bool + STM m (Bool, Maybe FullTip) updateChains BlockFetchControllerState{..} e = case e of FullChain fullChain -> do writeTVar targetChainVar Nothing + let !newTip = fullTip fullChain modifyTVar' cpsVar (switchFork fullChain) - return True + return (True, Just newTip) ImprovedPrefix missingChain -> do writeTVar targetChainVar (Just missingChain) let improvedChain = fromMaybe (error "prefix not from Genesis") $ Chain.fromAnchoredFragment missingChain.prefix + !newTip = fullTip improvedChain modifyTVar' cpsVar (switchFork improvedChain) - return True + return (True, Just $ newTip) SamePrefix missingChain -> do target <- readTVar targetChainVar let useful = Just (headPointMChain missingChain) /= fmap headPointMChain target when useful $ do writeTVar targetChainVar (Just missingChain) - return useful + return (useful, Nothing) ----------------------------------------------------------- ---- Methods for blockFetchConsumer and blockFetchProducer @@ -536,16 +546,22 @@ removeInFlight BlockFetchControllerState{..} pId points = do -- * removes block from PeerId's in-flight set -- * adds block to blocksVar -- * @fillInBlocks@ on @selectedChain@, and @updateChains@ -addFetchedBlock :: MonadSTM m => BlockFetchControllerState m -> PeerId -> Block -> STM m () -addFetchedBlock st pId blk = do +addFetchedBlock :: MonadSTM m => Tracer m PraosNodeEvent -> BlockFetchControllerState m -> PeerId -> Block -> m () +addFetchedBlock tracer st pId blk = (traceNewTip tracer =<<) . atomically $ do removeInFlight st pId [blockPoint blk] modifyTVar' st.blocksVar (Map.insert (blockHash blk) blk) selected <- readTVar st.targetChainVar case selected of - Nothing -> return () -- I suppose we do not need this block anymore. + Nothing -> return Nothing -- I suppose we do not need this block anymore. Just missingChain -> do - void $ updateChains st =<< fillInBlocks <$> readTVar st.blocksVar <*> pure missingChain + fmap snd $ updateChains st =<< fillInBlocks <$> readTVar st.blocksVar <*> pure missingChain + +traceNewTip :: Monad m => Tracer m PraosNodeEvent -> Maybe FullTip -> m () +traceNewTip tracer x = + case x of + Nothing -> return () + (Just tip) -> traceWith tracer (PraosNodeEventNewTip tip) addProducedBlock :: MonadSTM m => BlockFetchControllerState m -> Block -> STM m () addProducedBlock BlockFetchControllerState{..} blk = do @@ -565,9 +581,9 @@ blockRequestVarForPeerId peerId blockFetchControllerState = Nothing -> error $ "blockRequestVarForPeerId: no peer with id " <> show peerId Just peerStatus -> peerStatus.blockRequestVar -initBlockFetchConsumerStateForPeerId :: MonadSTM m => PeerId -> BlockFetchControllerState m -> BlockFetchConsumerState m -initBlockFetchConsumerStateForPeerId peerId blockFetchControllerState = +initBlockFetchConsumerStateForPeerId :: MonadSTM m => Tracer m PraosNodeEvent -> PeerId -> BlockFetchControllerState m -> BlockFetchConsumerState m +initBlockFetchConsumerStateForPeerId tracer peerId blockFetchControllerState = BlockFetchConsumerState (blockRequestVarForPeerId peerId blockFetchControllerState) - (atomically . addFetchedBlock blockFetchControllerState peerId) + (addFetchedBlock tracer blockFetchControllerState peerId) (atomically . removeInFlight blockFetchControllerState peerId) diff --git a/simulation/src/PraosProtocol/BlockGeneration.hs b/simulation/src/PraosProtocol/BlockGeneration.hs index c5c82333..43db893a 100644 --- a/simulation/src/PraosProtocol/BlockGeneration.hs +++ b/simulation/src/PraosProtocol/BlockGeneration.hs @@ -1,25 +1,23 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE ScopedTypeVariables #-} module PraosProtocol.BlockGeneration where +import Cardano.Slotting.Slot (WithOrigin (..)) +import ChanTCP (Bytes) import Control.Concurrent.Class.MonadSTM ( MonadSTM (..), ) -import Control.Monad (forever, when) -import Control.Monad.Class.MonadTimer.SI (MonadDelay) +import Control.Monad (forever) +import Control.Tracer import Data.ByteString as BS import Data.ByteString.Char8 as BS8 -import System.Random (StdGen, uniformR) - -import Cardano.Slotting.Slot (WithOrigin (..)) - -import ChanTCP (Bytes) import Data.Word (Word64) - import PraosProtocol.Common import qualified PraosProtocol.Common.Chain as Chain +import System.Random (StdGen, uniformR) -- | Returns a block that can extend the chain. -- PRECONDITION: the SlotNo is ahead of the chain tip. @@ -73,27 +71,31 @@ mkNextBlock (PoissonGenerationPattern sz rng0 lambda) prefix = do blockGenerator :: (MonadSTM m, MonadDelay m, MonadTime m) => - SlotConfig -> + Tracer m PraosNodeEvent -> + PraosConfig -> TVar m (ChainProducerState Block) -> (Block -> STM m ()) -> Maybe (m (SlotNo, BlockBody)) -> m () -blockGenerator _slotConfig _cpsVar _addBlockSt Nothing = return () -blockGenerator slotConfig cpsVar addBlockSt (Just nextBlock) = forever $ go +blockGenerator _tracer _praosConfig _cpsVar _addBlockSt Nothing = return () +blockGenerator tracer praosConfig cpsVar addBlockSt (Just nextBlock) = forever $ go where go = do (sl, body) <- nextBlock waitForSlot sl - atomically $ do + mblk <- atomically $ do chain <- chainState <$> readTVar cpsVar - when (Chain.headSlot chain <= At sl) $ - addBlockSt (mkBlock chain sl body) + let block = mkBlock chain sl body + if (Chain.headSlot chain <= At sl) + then + addBlockSt block >> return (Just block) + else return Nothing + case mblk of + Nothing -> return () + Just blk -> do + traceWith tracer (PraosNodeEventGenerate blk) + traceWith tracer (PraosNodeEventNewTip (FullTip (blockHeader blk))) waitForSlot sl = do - let tgt = slotTime slotConfig sl + let tgt = slotTime praosConfig.slotConfig sl now <- getCurrentTime threadDelayNDT (tgt `diffUTCTime` now) - -slotConfigFromNow :: MonadTime m => m SlotConfig -slotConfigFromNow = do - start <- getCurrentTime - return $ SlotConfig{start, duration = 1} diff --git a/simulation/src/PraosProtocol/Common.hs b/simulation/src/PraosProtocol/Common.hs index 8a354563..d9c252a2 100644 --- a/simulation/src/PraosProtocol/Common.hs +++ b/simulation/src/PraosProtocol/Common.hs @@ -6,11 +6,16 @@ module PraosProtocol.Common ( AnchoredFragment, Chain, + FullTip (..), + fullTip, Blocks, toBlocks, headerPoint, blockPrevPoint, setFollowerPoint, + blockBodyColor, + blockHeaderColor, + blockHeaderColorAsBody, module Block, module ConcreteBlock, module ProducerState, @@ -23,6 +28,9 @@ module PraosProtocol.Common ( tryTakeTakeOnlyTMVar, SlotConfig (..), slotTime, + slotConfigFromNow, + PraosNodeEvent (..), + PraosConfig (..), MessageSize (..), kilobytes, module TimeCompat, @@ -45,10 +53,13 @@ import Ouroboros.Network.Block as Block import Ouroboros.Network.Mock.ConcreteBlock as ConcreteBlock import Ouroboros.Network.Mock.ProducerState as ProducerState import PraosProtocol.Common.AnchoredFragment (AnchoredFragment) -import PraosProtocol.Common.Chain (Chain, foldChain, pointOnChain) +import PraosProtocol.Common.Chain (Chain (..), foldChain, pointOnChain) import ChanTCP (MessageSize (..)) +import Data.Coerce (coerce) +import Data.Word (Word8) import SimTCPLinks (kilobytes) +import System.Random (mkStdGen, uniform) import TimeCompat -------------------------------- @@ -69,6 +80,17 @@ instance MessageSize (Tip block) where instance MessageSize (Point block) where messageSizeBytes _ = {- hash -} 32 + {- slot no -} 8 +data FullTip + = -- | The tip is genesis + FullTipGenesis + | -- | The tip is not genesis + FullTip BlockHeader + deriving (Show) + +fullTip :: Chain Block -> FullTip +fullTip Genesis = FullTipGenesis +fullTip (_ :> blk) = FullTip (blockHeader blk) + type Blocks = Map (HeaderHash Block) Block toBlocks :: Chain Block -> Blocks @@ -95,6 +117,38 @@ data SlotConfig = SlotConfig {start :: UTCTime, duration :: NominalDiffTime} slotTime :: SlotConfig -> SlotNo -> UTCTime slotTime SlotConfig{start, duration} sl = (fromIntegral (unSlotNo sl) * duration) `addUTCTime` start +slotConfigFromNow :: MonadTime m => m SlotConfig +slotConfigFromNow = do + start <- getCurrentTime + return $ SlotConfig{start, duration = 1} + +blockBodyColor :: BlockBody -> (Double, Double, Double) +blockBodyColor = hashToColor . coerce . hashBody + +blockHeaderColor :: BlockHeader -> (Double, Double, Double) +blockHeaderColor = hashToColor . coerce . blockHash + +blockHeaderColorAsBody :: BlockHeader -> (Double, Double, Double) +blockHeaderColorAsBody = hashToColor . coerce . headerBodyHash + +hashToColor :: Int -> (Double, Double, Double) +hashToColor hash = (fromIntegral r / 256, fromIntegral g / 256, fromIntegral b / 256) + where + r, g, b :: Word8 + ((r, g, b), _) = uniform (mkStdGen hash) + +data PraosNodeEvent + = PraosNodeEventGenerate Block + | PraosNodeEventReceived Block + | PraosNodeEventEnterState Block + | PraosNodeEventNewTip FullTip + deriving (Show) + +data PraosConfig = PraosConfig + { slotConfig :: SlotConfig + , blockValidationDelay :: Block -> DiffTime + } + -------------------------------- ---- Common Utility Types -------------------------------- diff --git a/simulation/src/PraosProtocol/Common/AnchoredFragment.hs b/simulation/src/PraosProtocol/Common/AnchoredFragment.hs index 4b1ef40d..02a6826c 100644 --- a/simulation/src/PraosProtocol/Common/AnchoredFragment.hs +++ b/simulation/src/PraosProtocol/Common/AnchoredFragment.hs @@ -68,4 +68,4 @@ import Ouroboros.Network.AnchoredFragment as AnchoredFragment ( valid, validExtension, withinFragmentBounds, - ) \ No newline at end of file + ) diff --git a/simulation/src/PraosProtocol/ExamplesPraosP2P.hs b/simulation/src/PraosProtocol/ExamplesPraosP2P.hs index d30a7255..ab36ff23 100644 --- a/simulation/src/PraosProtocol/ExamplesPraosP2P.hs +++ b/simulation/src/PraosProtocol/ExamplesPraosP2P.hs @@ -1,87 +1,73 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoFieldSelectors #-} module PraosProtocol.ExamplesPraosP2P where +import Data.Aeson import qualified Data.ByteString.Char8 as BS8 import Data.Functor.Contravariant (Contravariant (contramap)) -import System.Random (mkStdGen) +import qualified Data.Map.Strict as Map +import System.Random (StdGen, mkStdGen) import ChanDriver +import Data.Coerce (coerce) +import GHC.Generics import Network.TypedProtocol -import P2P (P2PTopographyCharacteristics (..), genArbitraryP2PTopography) +import P2P (P2PTopography (p2pNodes), P2PTopographyCharacteristics (..), genArbitraryP2PTopography) import PraosProtocol.BlockFetch import PraosProtocol.BlockGeneration (PacketGenerationPattern (..)) -import PraosProtocol.Common (BlockHeader) +import PraosProtocol.Common import PraosProtocol.Common.Chain (Chain (Genesis)) import PraosProtocol.PraosNode +import PraosProtocol.SimPraos import PraosProtocol.SimPraosP2P -import PraosProtocol.VizSimPraos (PraosVizConfig (..), blockHeaderColor, examplesPraosSimVizConfig, praosSimVizModel) +import PraosProtocol.VizSimPraos (DiffusionLatencyMap, PraosVizConfig (..), accumDiffusionLatency, examplesPraosSimVizConfig, praosSimVizModel) import PraosProtocol.VizSimPraosP2P -import SimTCPLinks (kilobytes, mkTcpConnProps) +import Sample +import SimTCPLinks (mkTcpConnProps) import SimTypes import Viz example1 :: Vizualisation example1 = - slowmoVizualisation 0.1 $ - Viz model $ - LayoutAbove - [ layoutLabelTime - , LayoutBeside - [ LayoutReqSize 1200 1000 $ - Layout $ - praosP2PSimVizRender config - , LayoutBeside - [ LayoutAbove - [ LayoutReqSize 350 300 $ - Layout $ - chartDiffusionLatency config - , LayoutReqSize 350 300 $ - Layout $ - chartDiffusionImperfection - p2pTopography - 0.1 - (96 / 1000) - config - ] - , LayoutAbove - [ LayoutReqSize 350 300 $ - Layout chartBandwidth - , LayoutReqSize 350 300 $ - Layout chartLinkUtilisation - ] - ] - ] - ] + Viz model $ + LayoutAbove + [ layoutLabelTime + , LayoutBeside + [ LayoutReqSize 1200 1000 $ + Layout $ + praosP2PSimVizRender config + , LayoutBeside + [ LayoutAbove + [ LayoutReqSize 350 300 $ + Layout $ + chartDiffusionLatency config + , LayoutReqSize 350 300 $ + Layout $ + chartDiffusionImperfection + p2pTopography + 0.1 + (96 / 1000) + config + ] + , LayoutAbove + [ LayoutReqSize 350 300 $ + Layout chartBandwidth + , LayoutReqSize 350 300 $ + Layout chartLinkUtilisation + ] + ] + ] + ] where - model = praosSimVizModel trace - where - trace = - tracePraosP2P - rng0 - p2pTopography - (\latency -> mkTcpConnProps latency (kilobytes 1000)) - ( \slotConfig nid rng -> - PraosNodeConfig - { -- blockProcessingDelay = const 0.1 -- 100ms - blockGeneration = - PoissonGenerationPattern - (kilobytes 96) - rng - -- average seconds between blocks: - (0.2 * fromIntegral p2pNumNodes) - , slotConfig - , blockMarker = BS8.pack $ show nid ++ ": " - , chain = Genesis - } - ) - - p2pTopography = - genArbitraryP2PTopography p2pTopographyCharacteristics rng0 - - rng0 = mkStdGen 4 -- TODO: make a param - p2pNumNodes = 100 + model = praosSimVizModel $ example1Trace rng0 5 p2pTopography + p2pTopography = genArbitraryP2PTopography p2pTopographyCharacteristics rng0 p2pTopographyCharacteristics = P2PTopographyCharacteristics { p2pWorldShape = @@ -89,54 +75,163 @@ example1 = { worldDimensions = (0.600, 0.300) , worldIsCylinder = True } - , p2pNumNodes + , p2pNumNodes = 100 , p2pNodeLinksClose = 5 , p2pNodeLinksRandom = 5 } + rng0 = mkStdGen 4 -- TODO make a param. + +data DiffusionEntry = DiffusionEntry + { hash :: Int + , node_id :: Int + , created :: DiffTime + , arrivals :: [DiffTime] + } + deriving (Generic, ToJSON, FromJSON) + +data LatencyPerStake = LatencyPerStake + { hash :: Int + , latencies :: [(Maybe DiffTime, Double)] + } + deriving (Generic, ToJSON, FromJSON) + +data DiffusionData = DiffusionData + { topography :: String + , entries :: [DiffusionEntry] + , latency_per_stake :: [LatencyPerStake] + } + deriving (Generic, ToJSON, FromJSON) + +diffusionEntryToLatencyPerStake :: Int -> DiffusionEntry -> LatencyPerStake +diffusionEntryToLatencyPerStake nnodes DiffusionEntry{..} = + LatencyPerStake + { hash + , latencies = bin $ diffusionLatencyPerStakeFraction nnodes (Time created) (map Time arrivals) + } + where + bins = [0.5, 0.8, 0.9, 0.92, 0.94, 0.96, 0.98, 1] + bin xs = map (\b -> let ys = takeWhile (\(_, x) -> x <= b) xs in if null ys then (Nothing, b) else (Just $ fst $ last ys, b)) $ bins + +diffusionSampleModel :: P2PTopographyCharacteristics -> FilePath -> SampleModel PraosEvent DiffusionLatencyMap +diffusionSampleModel p2pTopographyCharacteristics fp = SampleModel Map.empty accumDiffusionLatency render + where + nnodes = p2pNumNodes p2pTopographyCharacteristics + render result = do + let entries = + [ DiffusionEntry + { hash = coerce hash' + , node_id = coerce i + , created = coerce t + , arrivals = coerce ts + } + | (hash', (_, i, t, ts)) <- Map.toList result + ] + + encodeFile fp $ + DiffusionData + { topography = show p2pTopographyCharacteristics + , entries + , latency_per_stake = map (diffusionEntryToLatencyPerStake nnodes) entries + } + +-- | Diffusion example with 1000 nodes. +example1000Diffusion :: + -- | number of close links + Int -> + -- | number of random links + Int -> + -- | when to stop simulation. + Time -> + -- | file to write data to. + FilePath -> + IO () +example1000Diffusion clinks rlinks stop fp = + runSampleModel (diffusionSampleModel p2pTopographyCharacteristics fp) stop $ + example1Trace rng 20 p2pTopography + where + rng = mkStdGen 42 + p2pTopography = genArbitraryP2PTopography p2pTopographyCharacteristics rng + p2pTopographyCharacteristics = + P2PTopographyCharacteristics + { p2pWorldShape = + WorldShape + { worldDimensions = (0.600, 0.300) + , worldIsCylinder = True + } + , p2pNumNodes = 1000 + , p2pNodeLinksClose = clinks + , p2pNodeLinksRandom = rlinks + } + +example1Trace :: StdGen -> DiffTime -> P2P.P2PTopography -> PraosTrace +example1Trace rng0 blockInterval p2pTopography = + tracePraosP2P + rng0 + p2pTopography + (\latency -> mkTcpConnProps latency (kilobytes 1000)) + ( \slotConfig nid rng -> + PraosNodeConfig + { blockGeneration = + PoissonGenerationPattern + (kilobytes 96) + rng + -- average seconds between blocks: + (realToFrac blockInterval * fromIntegral p2pNumNodes) + , praosConfig = + PraosConfig + { slotConfig + , blockValidationDelay = const 0.1 -- 100ms + } + , blockMarker = BS8.pack $ show nid ++ ": " + , chain = Genesis + } + ) + where + p2pNumNodes = Map.size $ p2pNodes p2pTopography example2 :: Vizualisation example2 = - slowmoVizualisation 0.2 $ - Viz (pairVizModel model1 model2) $ - LayoutAbove - [ layoutLabel 18 "Flat vs cylindrical world topology" - , LayoutReqSize 0 40 $ - layoutLabel 10 $ - "Left side is a flat rectangular world.\n" - ++ "Right is a cylindrical world, i.e. the east and " - ++ "west edges are connected." - , layoutLabelTime - , LayoutBeside - [ contramap fst - <$> LayoutAbove - [ LayoutReqSize 900 600 $ - Layout $ - praosP2PSimVizRender config - , LayoutBeside - [ LayoutReqSize 350 300 $ - Layout $ - chartDiffusionLatency config - , LayoutReqSize 350 300 $ - Layout - chartLinkUtilisation - ] - ] - , contramap snd - <$> LayoutAbove - [ LayoutReqSize 900 600 $ - Layout $ - praosP2PSimVizRender config - , LayoutBeside - [ LayoutReqSize 350 300 $ - Layout $ - chartDiffusionLatency config - , LayoutReqSize 350 300 $ - Layout - chartLinkUtilisation - ] - ] - ] - ] + -- slowmoVizualisation 0.2 $ + Viz (pairVizModel model1 model2) $ + LayoutAbove + [ layoutLabel 18 "Flat vs cylindrical world topology" + , LayoutReqSize 0 40 $ + layoutLabel 10 $ + "Left side is a flat rectangular world.\n" + ++ "Right is a cylindrical world, i.e. the east and " + ++ "west edges are connected." + , layoutLabelTime + , LayoutBeside + [ contramap fst + <$> LayoutAbove + [ LayoutReqSize 900 600 $ + Layout $ + praosP2PSimVizRender config + , LayoutBeside + [ LayoutReqSize 350 300 $ + Layout $ + chartDiffusionLatency config + , LayoutReqSize 350 300 $ + Layout + chartLinkUtilisation + ] + ] + , contramap snd + <$> LayoutAbove + [ LayoutReqSize 900 600 $ + Layout $ + praosP2PSimVizRender config + , LayoutBeside + [ LayoutReqSize 350 300 $ + Layout $ + chartDiffusionLatency config + , LayoutReqSize 350 300 $ + Layout + chartLinkUtilisation + ] + ] + ] + ] where model1 = model @@ -158,14 +253,17 @@ example2 = (\latency -> mkTcpConnProps latency (kilobytes 1000)) ( \slotConfig nid rng -> PraosNodeConfig - { -- blockProcessingDelay = const 0.1 -- 100ms - blockGeneration = + { blockGeneration = PoissonGenerationPattern (kilobytes 96) rng -- average seconds between blocks: - (0.5 * fromIntegral p2pNumNodes) - , slotConfig + (5 * fromIntegral p2pNumNodes) + , praosConfig = + PraosConfig + { slotConfig + , blockValidationDelay = const 0.1 -- 100ms + } , chain = Genesis , blockMarker = BS8.pack $ show nid ++ ": " } @@ -205,4 +303,4 @@ config = _ -> Nothing testNodeMessageColor :: BlockHeader -> (Double, Double, Double) - testNodeMessageColor = blockHeaderColor + testNodeMessageColor = blockHeaderColorAsBody diff --git a/simulation/src/PraosProtocol/PraosNode.hs b/simulation/src/PraosProtocol/PraosNode.hs index 491c0df9..25644a84 100644 --- a/simulation/src/PraosProtocol/PraosNode.hs +++ b/simulation/src/PraosProtocol/PraosNode.hs @@ -7,7 +7,6 @@ module PraosProtocol.PraosNode where import ChanMux import Control.Concurrent.Class.MonadSTM import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadTimer.SI (MonadDelay) import Control.Tracer import Data.ByteString (ByteString) import Data.Coerce (coerce) @@ -19,7 +18,7 @@ import PraosProtocol.BlockFetch (BlockFetchControllerState, BlockFetchMessage, B import qualified PraosProtocol.BlockFetch as BlockFetch import PraosProtocol.BlockGeneration import PraosProtocol.ChainSync (ChainConsumerState (..), ChainSyncMessage, runChainConsumer, runChainProducer) -import PraosProtocol.Common (Block, Chain, FollowerId, MessageSize (..), MonadTime, SlotConfig, asReadOnly, genesisPoint, initFollower) +import PraosProtocol.Common import qualified PraosProtocol.Common.Chain as Chain (Chain (..)) data Praos f = Praos @@ -49,7 +48,7 @@ data PraosNodeState m = PraosNodeState -- Peer requires ChainSyncConsumer and BlockFetchConsumer addPeer :: - MonadSTM m => + (MonadSTM m, MonadDelay m) => PraosNodeState m -> m (PraosNodeState m, PeerId) addPeer st = do @@ -59,17 +58,19 @@ addPeer st = do return (PraosNodeState{..}, peerId) runPeer :: - (MonadAsync m, MonadSTM m) => + (MonadAsync m, MonadSTM m, MonadDelay m) => + Tracer m PraosNodeEvent -> + PraosConfig -> PraosNodeState m -> PeerId -> Praos (Chan m) -> Concurrently m () -runPeer st peerId chan = do +runPeer tracer cfg st peerId chan = do let chainConsumerState = st.chainSyncConsumerStates Map.! peerId - let blockFetchConsumerState = initBlockFetchConsumerStateForPeerId peerId st.blockFetchControllerState + let blockFetchConsumerState = initBlockFetchConsumerStateForPeerId tracer peerId st.blockFetchControllerState sequenceA_ [ Concurrently $ runChainConsumer (protocolChainSync chan) chainConsumerState - , Concurrently $ runBlockFetchConsumer (protocolBlockFetch chan) blockFetchConsumerState + , Concurrently $ runBlockFetchConsumer tracer cfg (protocolBlockFetch chan) blockFetchConsumerState ] -- Follower requires ChainSyncProducer and BlockFetchProducer @@ -105,35 +106,36 @@ repeatM gen = go [] | otherwise = gen st >>= \(st', x) -> go (x : acc) (n - 1) st' runPraosNode :: - (MonadAsync m, MonadSTM m) => + (MonadAsync m, MonadSTM m, MonadDelay m) => + Tracer m PraosNodeEvent -> + PraosConfig -> Chain Block -> [Praos (Chan m)] -> [Praos (Chan m)] -> m () -runPraosNode chain followers peers = do +runPraosNode tracer cfg chain followers peers = do st0 <- PraosNodeState <$> newBlockFetchControllerState chain <*> pure Map.empty - runConcurrently =<< setupPraosThreads st0 followers peers + runConcurrently =<< setupPraosThreads tracer cfg st0 followers peers setupPraosThreads :: - (MonadAsync m, MonadSTM m) => + (MonadAsync m, MonadSTM m, MonadDelay m) => + Tracer m PraosNodeEvent -> + PraosConfig -> PraosNodeState m -> [Praos (Chan m)] -> [Praos (Chan m)] -> m (Concurrently m ()) -setupPraosThreads st0 followers peers = do +setupPraosThreads tracer cfg st0 followers peers = do (st1, followerIds) <- repeatM addFollower (length followers) st0 (st2, peerIds) <- repeatM addPeer (length peers) st1 - let controllerThread = Concurrently $ blockFetchController st2.blockFetchControllerState + let controllerThread = Concurrently $ blockFetchController tracer st2.blockFetchControllerState let followerThreads = zipWith (runFollower st2) followerIds followers - let peerThreads = zipWith (runPeer st2) peerIds peers + let peerThreads = zipWith (runPeer tracer cfg st2) peerIds peers return $ sequenceA_ (controllerThread : followerThreads <> peerThreads) -data PraosNodeEvent = PraosNodeEvent - deriving (Show) - data PraosNodeConfig = PraosNodeConfig - { blockGeneration :: PacketGenerationPattern - , slotConfig :: SlotConfig + { praosConfig :: PraosConfig + , blockGeneration :: PacketGenerationPattern , chain :: Chain Block , blockMarker :: ByteString -- ^ bytes to include in block bodies. @@ -146,13 +148,14 @@ praosNode :: [Praos (Chan m)] -> [Praos (Chan m)] -> m () -praosNode _tracer cfg followers peers = do +praosNode tracer cfg followers peers = do st0 <- PraosNodeState <$> newBlockFetchControllerState cfg.chain <*> pure Map.empty - praosThreads <- setupPraosThreads st0 followers peers + praosThreads <- setupPraosThreads tracer cfg.praosConfig st0 followers peers nextBlock <- mkNextBlock cfg.blockGeneration cfg.blockMarker let generationThread = blockGenerator - cfg.slotConfig + tracer + cfg.praosConfig st0.blockFetchControllerState.cpsVar (BlockFetch.addProducedBlock st0.blockFetchControllerState) nextBlock diff --git a/simulation/src/PraosProtocol/SimBlockFetch.hs b/simulation/src/PraosProtocol/SimBlockFetch.hs index 2f02ceb5..35681a83 100644 --- a/simulation/src/PraosProtocol/SimBlockFetch.hs +++ b/simulation/src/PraosProtocol/SimBlockFetch.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} module PraosProtocol.SimBlockFetch where @@ -12,11 +13,10 @@ import Control.Monad.Class.MonadAsync ( import Control.Monad.IOSim as IOSim (IOSim, runSimTrace) import Control.Tracer as Tracer ( Contravariant (contramap), - Tracer, + Tracer (Tracer), traceWith, ) import qualified Data.ByteString as BS -import Data.Functor ((<&>)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) @@ -69,8 +69,10 @@ traceRelayLink1 tcpprops = [(NodeId 0, NodeId 1), (NodeId 1, NodeId 0)] ) (inChan, outChan) <- newConnectionTCP (linkTracer na nb) tcpprops + slotConfig <- slotConfigFromNow + let praosConfig = PraosConfig{slotConfig, blockValidationDelay = const 0.1} concurrently_ - (nodeA outChan) + (nodeA praosConfig outChan) (nodeB inChan) return () where @@ -78,15 +80,15 @@ traceRelayLink1 tcpprops = bchain = mkChainSimple $ replicate 10 (BlockBody $ BS.replicate 100 0) -- Block-Fetch Controller & Consumer - nodeA :: (MonadAsync m, MonadSTM m) => Chan m (ProtocolMessage BlockFetchState) -> m () - nodeA chan = do + nodeA :: (MonadAsync m, MonadDelay m, MonadSTM m) => PraosConfig -> Chan m (ProtocolMessage BlockFetchState) -> m () + nodeA praosConfig chan = do peerChainVar <- newTVarIO (blockHeader <$> bchain) - st <- newBlockFetchControllerState Genesis >>= addPeer (asReadOnly peerChainVar) <&> fst + (st, peerId) <- newBlockFetchControllerState Genesis >>= addPeer (asReadOnly peerChainVar) concurrently_ - ( blockFetchController st + ( blockFetchController nullTracer st ) - ( runBlockFetchConsumer chan $ - initBlockFetchConsumerStateForPeerId 1 st + ( runBlockFetchConsumer nullTracer praosConfig chan $ + initBlockFetchConsumerStateForPeerId nullTracer peerId st ) -- Block-Fetch Producer nodeB chan = do @@ -95,6 +97,9 @@ traceRelayLink1 tcpprops = (na, nb) = (NodeId 0, NodeId 1) + nullTracer :: Monad m => Tracer m a + nullTracer = Tracer $ const $ return () + tracer :: Tracer (IOSim s) BlockFetchEvent tracer = simTracer diff --git a/simulation/src/PraosProtocol/SimPraos.hs b/simulation/src/PraosProtocol/SimPraos.hs index 11a6ce83..14dae493 100644 --- a/simulation/src/PraosProtocol/SimPraos.hs +++ b/simulation/src/PraosProtocol/SimPraos.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -26,7 +27,7 @@ import Data.Set (Set) import qualified Data.Set as Set import PraosProtocol.Common hiding (Point) import PraosProtocol.Common.Chain (Chain (..)) -import PraosProtocol.PraosNode (PraosMessage, PraosNodeEvent, runPraosNode) +import PraosProtocol.PraosNode (PraosMessage, runPraosNode) import SimTCPLinks import SimTypes @@ -67,13 +68,15 @@ traceRelayLink1 tcpprops = ( Set.fromList [(nodeA, nodeB), (nodeB, nodeA)] ) - let chainA = mkChainSimple $ replicate 10 (BlockBody $ BS.replicate 100 0) + slotConfig <- slotConfigFromNow + let praosConfig = PraosConfig{slotConfig, blockValidationDelay = const 0.1} + let chainA = mkChainSimple $ [BlockBody (BS.singleton word) | word <- [0 .. 9]] let chainB = Genesis (pA, cB) <- newConnectionBundleTCP (praosTracer nodeA nodeB) tcpprops (cA, pB) <- newConnectionBundleTCP (praosTracer nodeA nodeB) tcpprops concurrently_ - (runPraosNode chainA [pA] [cA]) - (runPraosNode chainB [pB] [cB]) + (runPraosNode (nodeTracer nodeA) praosConfig chainA [pA] [cA]) + (runPraosNode (nodeTracer nodeB) praosConfig chainB [pB] [cB]) return () where (nodeA, nodeB) = (NodeId 0, NodeId 1) @@ -81,6 +84,10 @@ traceRelayLink1 tcpprops = tracer :: Tracer (IOSim s) PraosEvent tracer = simTracer + nodeTracer :: NodeId -> Tracer (IOSim s) PraosNodeEvent + nodeTracer n = + contramap (PraosEventNode . LabelNode n) tracer + praosTracer :: NodeId -> NodeId -> diff --git a/simulation/src/PraosProtocol/SimPraosP2P.hs b/simulation/src/PraosProtocol/SimPraosP2P.hs index 65d15cfb..fe1fba65 100644 --- a/simulation/src/PraosProtocol/SimPraosP2P.hs +++ b/simulation/src/PraosProtocol/SimPraosP2P.hs @@ -8,11 +8,10 @@ module PraosProtocol.SimPraosP2P where import Control.Monad.Class.MonadAsync ( Concurrently (Concurrently, runConcurrently), ) -import Control.Monad.Class.MonadTime.SI (DiffTime) import Control.Monad.IOSim as IOSim (IOSim, runSimTrace) import Control.Tracer as Tracer ( Contravariant (contramap), - Tracer, + Tracer (Tracer), traceWith, ) import Data.Foldable (sequenceA_) @@ -23,8 +22,7 @@ import System.Random (StdGen, split) import ChanMux (newConnectionBundleTCP) import ChanTCP import P2P (P2PTopography (..)) -import PraosProtocol.BlockGeneration (slotConfigFromNow) -import PraosProtocol.Common (SlotConfig) +import PraosProtocol.Common import PraosProtocol.PraosNode import PraosProtocol.SimPraos import SimTCPLinks (labelDirToLabelLink, selectTimedEvents, simTracer) diff --git a/simulation/src/PraosProtocol/VizSimPraos.hs b/simulation/src/PraosProtocol/VizSimPraos.hs index 7443f2c1..d9eaf505 100644 --- a/simulation/src/PraosProtocol/VizSimPraos.hs +++ b/simulation/src/PraosProtocol/VizSimPraos.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} @@ -7,23 +8,23 @@ module PraosProtocol.VizSimPraos where import ChanDriver +import Control.Exception (assert) import Data.Coerce (coerce) import Data.Map (Map) import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) import Data.PQueue.Min (MinQueue) import qualified Data.PQueue.Min as PQ -import Data.Word (Word8) import qualified Graphics.Rendering.Cairo as Cairo import ModelTCP import Network.TypedProtocol import P2P (linkPathLatenciesSquared) -import PraosProtocol.BlockFetch (BlockFetchMessage, blockFetchMessageLabel) +import PraosProtocol.BlockFetch (BlockFetchMessage, Message (MsgBlock), blockFetchMessageLabel) import PraosProtocol.ChainSync (ChainSyncMessage, Message (..), chainSyncMessageLabel) import PraosProtocol.Common hiding (Point) import PraosProtocol.PraosNode (PraosMessage (..)) import PraosProtocol.SimPraos (PraosEvent (..), PraosTrace, exampleTrace1) import SimTypes -import System.Random (mkStdGen, uniform) import Viz import VizSim import VizSimTCP ( @@ -63,20 +64,15 @@ examplesPraosSimVizConfig = PraosVizConfig{..} blockFetchMessageColor :: BlockFetchMessage -> (Double, Double, Double) - blockFetchMessageColor _ = (1, 0, 0) + blockFetchMessageColor (ProtocolMessage (SomeMessage msg)) = case msg of + MsgBlock blk -> blockBodyColor blk + _otherwise -> (1, 0, 0) blockFetchMessageText :: BlockFetchMessage -> Maybe String blockFetchMessageText (ProtocolMessage (SomeMessage msg)) = Just $ blockFetchMessageLabel msg -blockHeaderColor :: BlockHeader -> (Double, Double, Double) -blockHeaderColor hdr = - (fromIntegral r / 256, fromIntegral g / 256, fromIntegral b / 256) - where - r, g, b :: Word8 - ((r, g, b), _) = uniform (mkStdGen $ coerce $ blockHash hdr) - ------------------------------------------------------------------------------ -- The vizualisation model -- @@ -102,14 +98,20 @@ data PraosSimVizState ) ] ) - , vizMsgsAtNodeQueue :: !(Map NodeId [BlockHeader]) + , vizNodeTip :: !(Map NodeId FullTip) + , -- the Buffer and Queue names are legacy from VizSimRelay. + -- In Praos we consider: + -- * Queue = seen by blockFetchConsumer and not yet in Buffer + -- * Buffer = added to blocksVar + vizMsgsAtNodeQueue :: !(Map NodeId [BlockHeader]) , vizMsgsAtNodeBuffer :: !(Map NodeId [BlockHeader]) , vizMsgsAtNodeRecentQueue :: !(Map NodeId RecentRate) , vizMsgsAtNodeRecentBuffer :: !(Map NodeId RecentRate) , vizMsgsAtNodeTotalQueue :: !(Map NodeId Int) , vizMsgsAtNodeTotalBuffer :: !(Map NodeId Int) - , vizNumMsgsGenerated :: !Int - , vizMsgsDiffusionLatency :: !(Map (HeaderHash BlockHeader) (BlockHeader, NodeId, Time, [Time])) + , -- these are `Block`s generated (globally). + vizNumMsgsGenerated :: !Int + , vizMsgsDiffusionLatency :: !DiffusionLatencyMap } -- | The end points where the each link, including the case where the link @@ -131,6 +133,27 @@ data LinkPoints {-# UNPACK #-} !Point deriving (Show) +type DiffusionLatencyMap = Map (HeaderHash BlockHeader) (BlockHeader, NodeId, Time, [Time]) + +accumDiffusionLatency :: Time -> PraosEvent -> DiffusionLatencyMap -> DiffusionLatencyMap +accumDiffusionLatency now (PraosEventNode e) = accumDiffusionLatency' now e +accumDiffusionLatency _ _ = id +accumDiffusionLatency' :: Time -> LabelNode PraosNodeEvent -> DiffusionLatencyMap -> DiffusionLatencyMap +accumDiffusionLatency' now (LabelNode nid (PraosNodeEventGenerate blk)) vs = + assert (not (blockHash blk `Map.member` vs)) $ + Map.insert + (blockHash blk) + (blockHeader blk, nid, now, [now]) + vs +accumDiffusionLatency' now (LabelNode _nid (PraosNodeEventEnterState blk)) vs = + Map.adjust + ( \(hdr, nid', created, arrivals) -> + (hdr, nid', created, now : arrivals) + ) + (blockHash blk) + vs +accumDiffusionLatency' _ _ vs = vs + -- | Make the vizualisation model for the relay simulation from a simulation -- trace. praosSimVizModel :: @@ -148,6 +171,7 @@ praosSimVizModel = , vizNodePos = Map.empty , vizNodeLinks = Map.empty , vizMsgsInTransit = Map.empty + , vizNodeTip = Map.empty , vizMsgsAtNodeQueue = Map.empty , vizMsgsAtNodeBuffer = Map.empty , vizMsgsAtNodeRecentQueue = Map.empty @@ -177,6 +201,63 @@ praosSimVizModel = ) links } + accumEventVizState _now (PraosEventNode (LabelNode nid (PraosNodeEventNewTip tip))) vs = + vs{vizNodeTip = Map.insert nid tip (vizNodeTip vs)} + accumEventVizState now (PraosEventNode (LabelNode nid (PraosNodeEventGenerate blk))) vs = + vs + { vizMsgsAtNodeBuffer = + Map.insertWith (flip (++)) nid [blockHeader blk] (vizMsgsAtNodeBuffer vs) + , vizMsgsAtNodeRecentBuffer = + Map.alter + (Just . recentAdd now . fromMaybe recentEmpty) + nid + (vizMsgsAtNodeRecentBuffer vs) + , vizMsgsAtNodeTotalBuffer = + Map.insertWith (+) nid 1 (vizMsgsAtNodeTotalBuffer vs) + , vizNumMsgsGenerated = vizNumMsgsGenerated vs + 1 + , vizMsgsDiffusionLatency = + assert (not (blockHash blk `Map.member` vizMsgsDiffusionLatency vs)) $ + Map.insert + (blockHash blk) + (blockHeader blk, nid, now, [now]) + (vizMsgsDiffusionLatency vs) + } + accumEventVizState now (PraosEventNode (LabelNode nid (PraosNodeEventReceived blk))) vs = + vs + { vizMsgsAtNodeQueue = + Map.insertWith (flip (++)) nid [blockHeader blk] (vizMsgsAtNodeQueue vs) + , vizMsgsAtNodeRecentQueue = + Map.alter + (Just . recentAdd now . fromMaybe recentEmpty) + nid + (vizMsgsAtNodeRecentQueue vs) + , vizMsgsAtNodeTotalQueue = + Map.insertWith (+) nid 1 (vizMsgsAtNodeTotalQueue vs) + } + accumEventVizState now (PraosEventNode (LabelNode nid (PraosNodeEventEnterState blk))) vs = + vs + { vizMsgsAtNodeBuffer = + Map.insertWith (flip (++)) nid [blockHeader blk] (vizMsgsAtNodeBuffer vs) + , vizMsgsAtNodeQueue = + Map.adjust + (filter (\blk' -> blockHash blk' /= blockHash blk)) + nid + (vizMsgsAtNodeQueue vs) + , vizMsgsAtNodeRecentBuffer = + Map.alter + (Just . recentAdd now . fromMaybe recentEmpty) + nid + (vizMsgsAtNodeRecentBuffer vs) + , vizMsgsAtNodeTotalBuffer = + Map.insertWith (+) nid 1 (vizMsgsAtNodeTotalBuffer vs) + , vizMsgsDiffusionLatency = + Map.adjust + ( \(hdr, nid', created, arrivals) -> + (hdr, nid', created, now : arrivals) + ) + (blockHash blk) + (vizMsgsDiffusionLatency vs) + } accumEventVizState _now ( PraosEventTcp @@ -211,18 +292,15 @@ praosSimVizModel = ) (vizMsgsInTransit vs) , vizMsgsAtNodeRecentQueue = - Map.map (recentPrune secondsAgo1) (vizMsgsAtNodeRecentQueue vs) + Map.map (recentPrune secondsAgo30) (vizMsgsAtNodeRecentQueue vs) , vizMsgsAtNodeRecentBuffer = - Map.map (recentPrune secondsAgo1) (vizMsgsAtNodeRecentBuffer vs) + Map.map (recentPrune secondsAgo30) (vizMsgsAtNodeRecentBuffer vs) , vizMsgsDiffusionLatency = - Map.filter (\(_, _, t, _) -> t >= secondsAgo15) (vizMsgsDiffusionLatency vs) + Map.filter (\(_, _, t, _) -> t >= secondsAgo30) (vizMsgsDiffusionLatency vs) } where - secondsAgo1 :: Time - secondsAgo1 = addTime (-1) now - - secondsAgo15 :: Time - secondsAgo15 = addTime (-15) now + secondsAgo30 :: Time + secondsAgo30 = addTime (-30) now -- | The shortest distance between two points, given that the world may be -- considered to be a cylinder. diff --git a/simulation/src/PraosProtocol/VizSimPraosP2P.hs b/simulation/src/PraosProtocol/VizSimPraosP2P.hs index 45a1a550..4ab770c2 100644 --- a/simulation/src/PraosProtocol/VizSimPraosP2P.hs +++ b/simulation/src/PraosProtocol/VizSimPraosP2P.hs @@ -11,13 +11,14 @@ import Control.Monad.Class.MonadTime.SI (DiffTime, Time, diffTime) import Data.Array.Unboxed (Ix, UArray, accumArray, (!)) import qualified Data.Colour.SRGB as Colour import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, maybeToList) +import Data.Maybe (catMaybes, maybeToList) import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Chart.Easy as Chart +import Data.Bifunctor (second) import ModelTCP (TcpMsgForecast (..), segmentSize) import P2P -import PraosProtocol.Common (BlockHeader) +import PraosProtocol.Common (BlockHeader, FullTip (FullTip), Time (..)) import PraosProtocol.PraosNode import PraosProtocol.VizSimPraos ( LinkPoints (..), @@ -26,6 +27,7 @@ import PraosProtocol.VizSimPraos ( recentRate, ) import SimTypes (Point (..), WorldShape (..)) +import Text.Printf (printf) import Viz import VizChart import VizSim @@ -64,21 +66,16 @@ praosP2PSimVizRenderModel { nodeMessageColor , ptclMessageColor } - now + now@(Time t) ( SimVizModel _events PraosSimVizState { vizWorldShape = WorldShape{worldDimensions} , vizNodePos , vizNodeLinks + , vizNodeTip , vizMsgsInTransit - , vizMsgsAtNodeQueue - , vizMsgsAtNodeBuffer - , -- vizMsgsAtNodeRecentQueue, - -- vizMsgsAtNodeRecentBuffer, - -- vizMsgsAtNodeTotalQueue, - -- vizMsgsAtNodeTotalBuffer, - vizNumMsgsGenerated + , vizNumMsgsGenerated } ) screenSize = do @@ -90,7 +87,10 @@ praosP2PSimVizRenderModel Cairo.moveTo 5 40 Cairo.setFontSize 20 Cairo.setSourceRGB 0 0 0 - Cairo.showText $ "Blocks generated: " ++ show vizNumMsgsGenerated + Cairo.showText $ + "Blocks generated: " + ++ show vizNumMsgsGenerated + ++ printf " (%.2f blk/s)" (fromIntegral vizNumMsgsGenerated / realToFrac t :: Double) renderNodes = do Cairo.save @@ -123,12 +123,12 @@ praosP2PSimVizRenderModel Cairo.newPath | (node, pos) <- Map.toList vizNodePos , let Point x y = toScreenPoint pos - qmsgs = fromMaybe [] (Map.lookup node vizMsgsAtNodeQueue) - bmsgs = fromMaybe [] (Map.lookup node vizMsgsAtNodeBuffer) + -- qmsgs = fromMaybe [] (Map.lookup node vizMsgsAtNodeQueue) + -- bmsgs = fromMaybe [] (Map.lookup node vizMsgsAtNodeBuffer) -- nqmsgs = length qmsgs -- nbmsgs = length bmsgs - (r, g, b) = case qmsgs ++ bmsgs of - msgs@(_ : _) -> nodeMessageColor (last msgs) + (r, g, b) = case Map.lookup node vizNodeTip of + Just (FullTip hdr) -> nodeMessageColor hdr _ -> (0.7, 0.7, 0.7) -- rqmsgs = maybe 0 recentRate (Map.lookup node vizMsgsAtNodeRecentQueue) -- rbmsgs = maybe 0 recentRate (Map.lookup node vizMsgsAtNodeRecentBuffer) @@ -264,6 +264,15 @@ classifyInFlightMsgs msgs -- The charts -- +diffusionLatencyPerStakeFraction :: Int -> Time -> [Time] -> [(DiffTime, Double)] +diffusionLatencyPerStakeFraction nnodes created arrivals = + [ (latency, percent) + | (arrival, n) <- zip (reverse arrivals) [1 :: Int ..] + , let !latency = arrival `diffTime` created + !percent = + (fromIntegral n / fromIntegral nnodes) + ] + chartDiffusionLatency :: PraosP2PSimVizConfig -> VizRender PraosSimVizModel @@ -304,13 +313,8 @@ chartDiffusionLatency PraosP2PSimVizConfig{nodeMessageColor} = | let nnodes = Map.size vizNodePos , (blk, _nid, created, arrivals) <- Map.elems vizMsgsDiffusionLatency , let timeseries = - [ (latency, percent) - | (arrival, n) <- zip (reverse arrivals) [1 :: Int ..] - , let !latency = arrival `diffTime` created - !percent = - Chart.Percent - (fromIntegral n / fromIntegral nnodes) - ] + map (second Chart.Percent) $ + diffusionLatencyPerStakeFraction nnodes created arrivals ] } @@ -395,7 +399,7 @@ chartBandwidth = Chart.def { Chart._laxis_generate = Chart.scaledAxis Chart.def{Chart._la_nLabels = maxX} (0, maxX) - , Chart._laxis_title = "Count of events within last second" + , Chart._laxis_title = "Count of events within last 30 seconds" } , Chart._layout_y_axis = Chart.def diff --git a/simulation/src/Sample.hs b/simulation/src/Sample.hs new file mode 100644 index 00000000..07f8bf8e --- /dev/null +++ b/simulation/src/Sample.hs @@ -0,0 +1,30 @@ +module Sample where + +import Data.List (foldl') +import System.IO +import TimeCompat +import VizSim + +data SampleModel event state = SampleModel + { initState :: state + , accumState :: Time -> event -> state -> state + , renderState :: state -> IO () + } + +runSampleModel :: + SampleModel event state -> + Time -> + [(Time, event)] -> + IO () +runSampleModel (SampleModel s0 accum render) stop = go . flip SimVizModel s0 . takeWhile (\(t, _) -> t <= stop) + where + go m = case stepSimViz 1000 m of + m'@(SimVizModel ((now, _) : _) _) -> do + putStrLn $ "time reached: " ++ show now + hFlush stdout + go m' + (SimVizModel [] s) -> do + putStrLn $ "done." + render s + stepSimViz n (SimVizModel es s) = case splitAt n es of + (before, after) -> SimVizModel after (foldl' (\x (t, e) -> accum t e x) s before) diff --git a/simulation/src/SampleMain.hs b/simulation/src/SampleMain.hs new file mode 100644 index 00000000..52ec5900 --- /dev/null +++ b/simulation/src/SampleMain.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Main where + +import Control.Applicative (optional) +import Data.Maybe (fromMaybe) +import Data.String (IsString (fromString)) +import qualified Options.Applicative as Opts +import Options.Applicative.Help (line) +import qualified PraosProtocol.ExamplesPraosP2P as VizPraosP2P +import System.FilePath +import TimeCompat + +main :: IO () +main = do + CliCmd + { cliSim = (name, (defaultS, sim)) + , cliOutputSeconds + , cliOutputFile + } <- + Opts.execParser cli + let seconds = fromMaybe defaultS $ Time . fromIntegral <$> cliOutputSeconds + let filename = fromMaybe (name <.> "json") $ cliOutputFile + sim seconds filename + +cli :: Opts.ParserInfo CliCmd +cli = + Opts.info + (Opts.helper <*> options) + ( Opts.fullDesc + <> Opts.header "Sampling of Ouroboros-related network simulations" + <> Opts.progDescDoc (Just desc) + ) + where + desc = + fromString + "Gather data from a simulation." + <> line + <> fromString vizNamesHelp + +type Sim = (Time, Time -> FilePath -> IO ()) +data CliCmd = CliCmd + { cliSim :: (String, Sim) + , cliOutputSeconds :: Maybe Int + , cliOutputFile :: Maybe FilePath + } + +vizNamesHelp :: String +vizNamesHelp = "SIMNAME is one of: " ++ unwords (map fst simulations) + +options :: Opts.Parser CliCmd +options = + CliCmd + <$> Opts.argument + (Opts.eitherReader readViz) + ( Opts.metavar "SIMNAME" + <> Opts.help vizNamesHelp + ) + <*> optional + ( Opts.option + Opts.auto + ( Opts.long "seconds" + <> Opts.metavar "SEC" + <> Opts.help "Run N seconds of simulated time." + ) + ) + <*> optional + ( Opts.option + Opts.auto + ( Opts.long "output" + <> Opts.metavar "FILENAME" + <> Opts.help "output filename, (default SIMNAME.json)" + ) + ) + +simulations :: [(String, Sim)] +simulations = + [ ("praos-diffusion-10-links", (Time 40, VizPraosP2P.example1000Diffusion 5 5)) + , ("praos-diffusion-20-links", (Time 40, VizPraosP2P.example1000Diffusion 10 10)) + ] + +readViz :: String -> Either String (String, Sim) +readViz s = case lookup s simulations of + Just viz -> Right (s, viz) + Nothing -> Left "unknown sim" diff --git a/simulation/src/TimeCompat.hs b/simulation/src/TimeCompat.hs index 96d306c8..71b1e79a 100644 --- a/simulation/src/TimeCompat.hs +++ b/simulation/src/TimeCompat.hs @@ -4,6 +4,7 @@ module TimeCompat ( module Control.Monad.Class.MonadTime.SI, threadDelayNDT, threadDelaySI, + MonadDelay, ) where import Control.Monad.Class.MonadTime.SI diff --git a/simulation/src/VizUtils.hs b/simulation/src/VizUtils.hs index db7aa44a..3ac9ea7f 100644 --- a/simulation/src/VizUtils.hs +++ b/simulation/src/VizUtils.hs @@ -4,7 +4,9 @@ module VizUtils where import qualified Graphics.Rendering.Cairo as Cairo +import Data.Word (Word8) import SimTypes (Point (..)) +import System.Random (StdGen, uniform) data Vector = Vector !Double !Double @@ -96,3 +98,9 @@ simPointToPixel (!ww, !wh) (!sw, !sh) (Point wx wy) = Point sx sy where !sx = wx / ww * sw !sy = wy / wh * sh + +rngColor :: StdGen -> (Double, Double, Double) +rngColor rng = (fromIntegral r / 256, fromIntegral g / 256, fromIntegral b / 256) + where + r, g, b :: Word8 + ((r, g, b), _) = uniform rng