simulation: added adversarial behaviour field to nodes in topology

Only behaviour supported is `UnboundedIbs`.

Author: Saizan

data/simulation/Makefile

@@ -17,7 +17,7 @@ trace.rust.schema.json: trace.rust.d.ts
 	npx prettier -w trace.rust.schema.json
 
 .PHONY: validate
-validate:
+validate: all
 	@echo "Validating config..."
 	@npx pajv -m schema.schema.json -s config.schema.json -d config.default.yaml > /dev/null && echo "config.default.yaml valid" || exit 1
 	@echo "Validating topology..."

data/simulation/topology.d.ts

@@ -23,6 +23,11 @@ export interface Node<Location> {
   "cpu-core-count"?: bigint | null;
   location: Location;
   producers: { [producer: NodeName]: LinkInfo };
+  /** If not null, the node will behave according to the given Behaviour.
+  *
+  * Only supported by Haskell simulation.
+  */
+  adversarial?: Behaviour | null;
 }
 
 /** Link information. */
@@ -38,3 +43,20 @@ export interface Cluster {
 }
 
 export type Coord2D = [number, number];
+
+export type Behaviour =
+  | UnboundedIbs
+  ;
+
+/** A node that after some time stops respecting IB sortition and
+instead starts generating old IBs every slot.
+
+Only supported by Haskell simulation.
+*/
+export interface UnboundedIbs {
+  behaviour: "unbounded-ibs";
+  /* When to start the adversarial generation. */
+  "starting-at-slot": number;
+  "slot-of-generated-ibs": number;
+  "ibs-per-slot": number;
+}

data/simulation/topology.schema.json

@@ -26,6 +26,10 @@
     "Node<Cluster>": {
       "description": "A node.",
       "properties": {
+        "adversarial": {
+          "$ref": "#/definitions/UnboundedIbs",
+          "description": "If not null, the node will behave according to the given Behaviour.\n\nOnly supported by Haskell simulation."
+        },
         "cpu-core-count": {
           "additionalProperties": false,
           "properties": {},
@@ -51,6 +55,10 @@
     "Node<Coord2D>": {
       "description": "A node.",
       "properties": {
+        "adversarial": {
+          "$ref": "#/definitions/UnboundedIbs",
+          "description": "If not null, the node will behave according to the given Behaviour.\n\nOnly supported by Haskell simulation."
+        },
         "cpu-core-count": {
           "additionalProperties": false,
           "properties": {},
@@ -82,6 +90,25 @@
         }
       },
       "type": "object"
+    },
+    "UnboundedIbs": {
+      "description": "A node that after some time stops respecting IB sortition and\ninstead starts generating old IBs every slot.\n\nOnly supported by Haskell simulation.",
+      "properties": {
+        "behaviour": {
+          "const": "unbounded-ibs",
+          "type": "string"
+        },
+        "ibs-per-slot": {
+          "type": "number"
+        },
+        "slot-of-generated-ibs": {
+          "type": "number"
+        },
+        "starting-at-slot": {
+          "type": "number"
+        }
+      },
+      "type": "object"
     }
   },
   "description": "The topology for a Leios simulation.\n\nThe nodes in a topology may either specify their location as cluster names,\nwhich may be omitted, or as coordinates, but all nodes in the topology must\nuse the same kind of location.",

leios-trace-hs/src/LeiosTopology.hs

@@ -21,6 +21,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
 module LeiosTopology where
 
@@ -37,7 +38,7 @@ import Data.Text (Text)
 import qualified Data.Vector as V
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
-import JSONCompat (Getter, always, get, omitDefault, parseField, parseFieldOrDefault)
+import JSONCompat (Getter, always, camelToKebab, get, omitDefault, parseField, parseFieldOrDefault)
 import LeiosTypes (Point (..))
 import Text.Printf (PrintfArg)
 
@@ -202,6 +203,10 @@ instance HasField "coord2D" (Node 'COORD2D) Point where
   getField :: Node 'COORD2D -> Point
   getField node = node.nodeInfo.location.coord2D
 
+instance HasField "adversarial" (Node lk) (Maybe Behaviour) where
+  getField :: Node lk -> Maybe Behaviour
+  getField node = node.nodeInfo.adversarial
+
 instance Default (Node 'CLUSTER) where
   def :: Node 'CLUSTER
   def = Node{nodeInfo = def, producers = mempty}
@@ -210,9 +215,13 @@ data NodeInfo (lk :: LocationKind) = NodeInfo
   { stake :: {-# UNPACK #-} !Word
   , cpuCoreCount :: {-# UNPACK #-} !CpuCoreCount
   , location :: !(Location lk)
+  , adversarial :: !(Maybe Behaviour)
   }
   deriving stock (Show, Eq, Generic)
 
+data Behaviour = UnboundedIbs {startingAtSlot :: Word, slotOfGeneratedIbs :: Word, ibsPerSlot :: Word}
+  deriving (Show, Eq, Generic)
+
 instance HasField "coord2D" (NodeInfo 'COORD2D) Point where
   getField :: NodeInfo 'COORD2D -> Point
   getField nodeInfo = nodeInfo.location.coord2D
@@ -224,6 +233,7 @@ instance Default (NodeInfo 'CLUSTER) where
       { stake = 0
       , cpuCoreCount = Unbounded
       , location = LocCluster Nothing
+      , adversarial = Nothing
       }
 
 data LinkInfo = LinkInfo
@@ -250,6 +260,7 @@ nodeToKVs getter node =
     , get @"cpuCoreCount" getter node
     , get @"location" getter node
     , get @"producers" getter node
+    , get @"adversarial" getter node
     ]
 
 instance ToJSON (Node 'CLUSTER) where
@@ -273,6 +284,7 @@ instance FromJSON (Node 'CLUSTER) where
     cpuCoreCount <- parseFieldOrDefault @(Node 'CLUSTER) @"cpuCoreCount" obj
     location <- parseFieldOrDefault @(Node 'CLUSTER) @"location" obj
     producers <- parseFieldOrDefault @(Node 'CLUSTER) @"producers" obj
+    adversarial <- parseFieldOrDefault @(Node 'CLUSTER) @"adversarial" obj
     pure Node{nodeInfo = NodeInfo{..}, ..}
 
 instance FromJSON (Node 'COORD2D) where
@@ -285,8 +297,25 @@ instance FromJSON (Node 'COORD2D) where
     cpuCoreCount <- parseFieldOrDefault @(Node 'CLUSTER) @"cpuCoreCount" obj
     location <- parseField @(Node 'COORD2D) @"location" obj
     producers <- parseFieldOrDefault @(Node 'CLUSTER) @"producers" obj
+    adversarial <- parseFieldOrDefault @(Node 'CLUSTER) @"adversarial" obj
     pure Node{nodeInfo = NodeInfo{..}, ..}
 
+behaviourJSONOptions :: Options
+behaviourJSONOptions =
+  defaultOptions
+    { sumEncoding = Json.defaultTaggedObject{Json.tagFieldName = "behaviour"}
+    , fieldLabelModifier = camelToKebab
+    , constructorTagModifier = camelToKebab
+    , tagSingleConstructors = True
+    }
+
+instance FromJSON Behaviour where
+  parseJSON = genericParseJSON behaviourJSONOptions
+
+instance ToJSON Behaviour where
+  toJSON = Json.genericToJSON behaviourJSONOptions
+  toEncoding = Json.genericToEncoding behaviourJSONOptions
+
 linkInfoToKVs :: KeyValue e kv => Getter LinkInfo -> LinkInfo -> [kv]
 linkInfoToKVs getter link =
   catMaybes

simulation/src/LeiosProtocol/Short/Generate.hs

@@ -38,7 +38,7 @@ data BuffersView m = BuffersView
 
 data Role :: Type -> Type where
   Base :: Role RankingBlock
-  Propose :: Role InputBlock
+  Propose :: {ibSlot :: Maybe SlotNo, delay :: Maybe DiffTime} -> Role InputBlock
   Endorse :: Role EndorseBlock
   Vote :: Role VoteMsg
 
@@ -81,13 +81,13 @@ leiosBlockGenerator LeiosGeneratorConfig{..} =
     let !rb = mkPartialBlock slot body
     let !task = leios.praos.blockGenerationDelay rb
     return [(task, rb)]
-  execute' slot Propose wins = do
+  execute' slot Propose{ibSlot, delay} wins = do
     ibData <- lift $ atomically buffers.newIBData
     forM [toEnum $ fromIntegral sub | sub <- [0 .. wins - 1]] $ \sub -> do
       i <- nextBlkId InputBlockId
-      let header = mkInputBlockHeader leios i slot sub nodeId ibData.referenceRankingBlock
+      let header = mkInputBlockHeader leios i (fromMaybe slot ibSlot) sub nodeId ibData.referenceRankingBlock
       let !ib = mkInputBlock leios header ibData.txsPayload
-      let !task = leios.delays.inputBlockGeneration ib
+      let !task = fromMaybe (leios.delays.inputBlockGeneration ib) delay
       return (task, ib)
   execute' slot Endorse _wins = do
     i <- nextBlkId EndorseBlockId

simulation/src/LeiosProtocol/Short/Node.hs

@@ -84,6 +84,14 @@ data LeiosNodeEvent
 ---- Node Config
 --------------------------------------------------------------
 
+data BlockGeneration
+  = Honest
+  | UnboundedIbs
+      { startingAtSlot :: SlotNo
+      , slotOfGeneratedIbs :: SlotNo
+      , ibsPerSlot :: Word64
+      }
+
 data LeiosNodeConfig = LeiosNodeConfig
   { leios :: !LeiosConfig
   , slotConfig :: !SlotConfig
@@ -93,7 +101,8 @@ data LeiosNodeConfig = LeiosNodeConfig
   -- ^ for block generation
   , baseChain :: !(Chain RankingBlock)
   , processingQueueBound :: !Natural
-  , processingCores :: NumCores
+  , processingCores :: !NumCores
+  , blockGeneration :: !BlockGeneration
   }
 
 --------------------------------------------------------------
@@ -812,7 +821,7 @@ generator tracer cfg st = do
             return (rb, chain :> rb)
           traceWith tracer (PraosNodeEvent (PraosNodeEventGenerate rb))
           traceWith tracer (PraosNodeEvent (PraosNodeEventNewTip newChain))
-        SomeAction Generate.Propose ib -> (GenIB,) $ do
+        SomeAction Generate.Propose{} ib -> (GenIB,) $ do
           now <- getCurrentTime
           atomically $ do
             modifyTVar' st.relayIBState.relayBufferVar (RB.snocIfNew ib.header.id (ib.header, ib.body))
@@ -929,9 +938,14 @@ mkSchedule cfg = do
   calcWins rate = Just $ \sample ->
     if sample <= coerce (nodeRate cfg.stake rate) then 1 else 0
   voteRate = votingRatePerPipeline cfg.leios cfg.stake
+  honestIBRate = inputBlockRate cfg.leios cfg.stake
+  ibRate Honest slot = (SomeRole (Generate.Propose Nothing Nothing), honestIBRate slot)
+  ibRate (UnboundedIbs{..}) slot =
+    if slot < startingAtSlot
+      then (SomeRole (Generate.Propose Nothing Nothing), honestIBRate slot)
+      else (SomeRole (Generate.Propose (Just slotOfGeneratedIbs) (Just 0)), Just (const $ ibsPerSlot))
   pureRates =
-    [ (SomeRole Generate.Propose, inputBlockRate cfg.leios cfg.stake)
-    , (SomeRole Generate.Endorse, endorseBlockRate cfg.leios cfg.stake)
+    [ (SomeRole Generate.Endorse, endorseBlockRate cfg.leios cfg.stake)
     , (SomeRole Generate.Base, const $ calcWins (NetworkRate cfg.leios.praos.blockFrequencyPerSlot))
     ]
   rates votingSlots slot = do
@@ -943,7 +957,11 @@ mkSchedule cfg = do
               writeTVar votingSlots sls
               pure (Just voteRate)
         _ -> pure Nothing
-    pure $ (SomeRole Generate.Vote, vote) : map (fmap ($ slot)) pureRates
+    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

simulation/src/LeiosProtocol/Short/Sim.hs

@@ -449,6 +449,7 @@ traceRelayLink1 connectionOptions =
               , -- \^ overall size of txs to include in IBs
                 processingQueueBound = 100
               , processingCores = Infinite
+              , blockGeneration = Honest
               , ..
               }
       (pA, cB) <- newConnectionBundle (leiosTracer nodeA nodeB) (uncurry configureConnection connectionOptions)

simulation/src/LeiosProtocol/Short/SimP2P.hs

@@ -25,6 +25,7 @@ import SimTCPLinks (labelDirToLabelLink, selectTimedEvents, simTracer)
 import SimTypes
 import System.Random (StdGen, split)
 import Topology (P2PNetwork (..))
+import qualified Topology
 
 traceLeiosP2P ::
   StdGen ->
@@ -109,6 +110,14 @@ exampleTrace2' rng0 leios@LeiosConfig{praos = PraosConfig{configureConnection}}
       , processingCores
       , nodeId
       , rng
+      , blockGeneration = case Map.lookup nodeId =<< p2pAdversaries of
+          Nothing -> Honest
+          Just Topology.UnboundedIbs{..} ->
+            UnboundedIbs
+              { startingAtSlot = SlotNo $ fromIntegral startingAtSlot
+              , slotOfGeneratedIbs = SlotNo $ fromIntegral slotOfGeneratedIbs
+              , ibsPerSlot = fromIntegral ibsPerSlot
+              }
       }
    where
     processingCores = fromMaybe undefined $ Map.lookup nodeId p2pNodeCores

simulation/src/Topology.hs

@@ -106,6 +106,7 @@ benchTopologyToTopology benchTopology latencies stakeShareSize =
             { stake = maybe 0 (stakeShareSize *) benchTopologyNode.pools
             , cpuCoreCount = Unbounded
             , location = LocCluster (regionNameToClusterName <$> benchTopologyNode.region)
+            , adversarial = Nothing
             }
       , producers =
           M.fromList
@@ -336,6 +337,7 @@ data P2PNetwork = P2PNetwork
   , p2pNodeNames :: !(Map NodeId Text)
   , p2pNodeCores :: !(Map NodeId NumCores)
   , p2pNodeStakes :: !(Map NodeId StakeFraction)
+  , p2pAdversaries :: !(Maybe (Map NodeId Behaviour))
   , p2pLinks :: !(Map Link (Latency, Maybe BandwidthBytesPerSecond))
   , p2pWorld :: !World
   }
@@ -381,6 +383,7 @@ grToP2PNetwork p2pWorld gr = P2PNetwork{..}
   totalStake = fromIntegral . sum $ map (fromIntegral @_ @Integer . (.stake) . snd) $ Map.elems nodeInfoMap
   p2pLinks = flip Map.map edgeInfoMap $ \link ->
     (link.latencyS, fromIntegral <$> unBandwidthBps link.bandwidthBytesPerSecond)
+  p2pAdversaries = Just $ Map.fromList [(nid, b) | (nid, (_, NodeInfo{adversarial = Just b})) <- Map.toList nodeInfoMap]
 
 p2pNetworkToGr :: Word -> P2PNetwork -> Gr (NodeName, NodeInfo COORD2D) LinkInfo
 p2pNetworkToGr totalStake P2PNetwork{..} = G.mkGraph grNodes grLinks
@@ -394,6 +397,7 @@ p2pNetworkToGr totalStake P2PNetwork{..} = G.mkGraph grNodes grLinks
             Infinite -> Nothing
             Finite n -> Just $ fromIntegral n
     , let location = LocCoord2D point
+    , let adversarial = Map.lookup nId =<< p2pAdversaries
     ]
   grLinks =
     [ linkToEdge link linkInfo
@@ -420,6 +424,7 @@ topologyToNetwork P2PTopography{..} = P2PNetwork{p2pLinks = fmap (,defaultBandwi
   numNodes = fromIntegral $ Map.size p2pNodes
   -- TODO: unrestricted bandwidth is unsupported
   defaultBandwidthBps = Just (kilobytes 1000)
+  p2pAdversaries = Nothing
 
 overrideUnlimitedBandwidth :: Bytes -> P2PNetwork -> P2PNetwork
 overrideUnlimitedBandwidth x P2PNetwork{..} =