simulation: first stab at full leios support (#264)

Author: Saizan

data/simulation/config.d.ts

@@ -38,10 +38,17 @@ export interface Config {
   /**
    * The expected time it takes a header to fully diffuse across the network.
    * This is Δhdr from the Leios paper.
-   * 
-   * Only supported by Rust simulation. */
+   * */
   "leios-header-diffusion-time-ms": number;
-
+  /**
+   * Praos blockchain quality parameter.
+   * This is η from the Leios paper.
+   * Controls the pipelines EBs should reference in Full leios:
+   *   i - ⌈3η/L⌉, …, i-3
+   * where i is the index of the current pipeline.
+   *
+   * Only supported by Haskell simulation */
+  "praos-chain-quality": number;
   // Transaction Configuration
   /** Only supported by Rust simulation. */
   "tx-generation-distribution": Distribution;

data/simulation/config.default.yaml

@@ -27,6 +27,8 @@ leios-stage-length-slots: 20
 leios-stage-active-voting-slots: 1
 leios-vote-send-recv-stages: false
 leios-header-diffusion-time-ms: 1000.0
+# TODO: revise default
+praos-chain-quality: 20
 
 ################################################################################
 # Transaction Configuration

data/simulation/config.schema.json

@@ -249,7 +249,7 @@
       "type": "number"
     },
     "leios-header-diffusion-time-ms": {
-      "description": "The expected time it takes a header to fully diffuse across the network.\nThis is Δhdr from the Leios paper.\n\nOnly supported by Rust simulation.",
+      "description": "The expected time it takes a header to fully diffuse across the network.\nThis is Δhdr from the Leios paper.",
       "type": "number"
     },
     "leios-stage-active-voting-slots": {
@@ -274,6 +274,10 @@
       "description": "Only supported by Haskell simulation.",
       "type": "boolean"
     },
+    "praos-chain-quality": {
+      "description": "Praos blockchain quality parameter.\nThis is η from the Leios paper.\nControls the pipelines EBs should reference in Full leios:\n  i - ⌈3η/L⌉, …, i-3\nwhere i is the index of the current pipeline.\n\nOnly supported by Haskell simulation",
+      "type": "number"
+    },
     "rb-body-legacy-praos-payload-avg-size-bytes": {
       "additionalProperties": false,
       "properties": {},

simulation/src/LeiosProtocol/Common.hs

@@ -40,6 +40,7 @@ module LeiosProtocol.Common (
 where
 
 import Chan.TCP
+import Control.DeepSeq
 import Control.Exception (assert)
 import Control.Monad (guard)
 import Data.Aeson
@@ -103,6 +104,9 @@ data InputBlockId = InputBlockId
   deriving stock (Eq, Ord, Show, Generic)
   deriving anyclass (Hashable)
 
+instance NFData InputBlockId where
+  rnf InputBlockId{} = ()
+
 newtype SubSlotNo = SubSlotNo Word8
   deriving stock (Show)
   deriving newtype (Eq, Ord, Num, Enum, Bounded)
@@ -150,6 +154,9 @@ data EndorseBlockId = EndorseBlockId
   deriving stock (Eq, Ord, Show, Generic)
   deriving anyclass (Hashable)
 
+instance NFData EndorseBlockId where
+  rnf EndorseBlockId{} = ()
+
 data EndorseBlock = EndorseBlock
   { id :: !EndorseBlockId
   , slot :: !SlotNo

simulation/src/LeiosProtocol/Config.hs

@@ -85,6 +85,9 @@ instance Default CleanupPolicies where
 allCleanupPolicies :: CleanupPolicies
 allCleanupPolicies = CleanupPolicies $ Set.fromList [minBound .. maxBound]
 
+data LeiosVariant = Short | Full
+  deriving (Show, Eq, Generic)
+
 data Config = Config
   { relayStrategy :: RelayStrategy
   , tcpCongestionControl :: Bool
@@ -95,6 +98,9 @@ data Config = Config
   , leiosStageLengthSlots :: Word
   , leiosStageActiveVotingSlots :: Word
   , leiosVoteSendRecvStages :: Bool
+  , leiosVariant :: LeiosVariant
+  , leiosHeaderDiffusionTimeMs :: DurationMs
+  , praosChainQuality :: Double
   , txGenerationDistribution :: Distribution
   , txSizeBytesDistribution :: Distribution
   , txValidationCpuTimeMs :: DurationMs
@@ -164,6 +170,9 @@ instance Default Config where
       , leiosStageLengthSlots = 20
       , leiosStageActiveVotingSlots = 1
       , leiosVoteSendRecvStages = False
+      , leiosVariant = Short
+      , leiosHeaderDiffusionTimeMs = 1000
+      , praosChainQuality = 20
       , txGenerationDistribution = Exp{lambda = 0.85, scale = Just 1000}
       , txSizeBytesDistribution = LogNormal{mu = 6.833, sigma = 1.127}
       , txValidationCpuTimeMs = 1.5
@@ -233,6 +242,9 @@ configToKVsWith getter cfg =
     , get @"multiplexMiniProtocols" getter cfg
     , get @"treatBlocksAsFull" getter cfg
     , get @"cleanupPolicies" getter cfg
+    , get @"leiosVariant" getter cfg
+    , get @"leiosHeaderDiffusionTimeMs" getter cfg
+    , get @"praosChainQuality" getter cfg
     , get @"simulateTransactions" getter cfg
     , get @"leiosStageLengthSlots" getter cfg
     , get @"leiosStageActiveVotingSlots" getter cfg
@@ -316,6 +328,9 @@ instance FromJSON Config where
     multiplexMiniProtocols <- parseFieldOrDefault @Config @"multiplexMiniProtocols" obj
     treatBlocksAsFull <- parseFieldOrDefault @Config @"treatBlocksAsFull" obj
     cleanupPolicies <- parseFieldOrDefault @Config @"cleanupPolicies" obj
+    leiosVariant <- parseFieldOrDefault @Config @"leiosVariant" obj
+    leiosHeaderDiffusionTimeMs <- parseFieldOrDefault @Config @"leiosHeaderDiffusionTimeMs" obj
+    praosChainQuality <- parseFieldOrDefault @Config @"praosChainQuality" obj
     simulateTransactions <- parseFieldOrDefault @Config @"simulateTransactions" obj
     leiosStageLengthSlots <- parseFieldOrDefault @Config @"leiosStageLengthSlots" obj
     leiosStageActiveVotingSlots <- parseFieldOrDefault @Config @"leiosStageActiveVotingSlots" obj
@@ -465,6 +480,13 @@ instance ToJSON RelayStrategy where
   toJSON = genericToJSON defaultEnumOptions
   toEncoding = genericToEncoding defaultEnumOptions
 
+instance FromJSON LeiosVariant where
+  parseJSON = genericParseJSON defaultEnumOptions
+
+instance ToJSON LeiosVariant where
+  toJSON = genericToJSON defaultEnumOptions
+  toEncoding = genericToEncoding defaultEnumOptions
+
 -- | Create a 'Config' from a file.
 readConfigEither :: FilePath -> IO (Either ParseException Config)
 readConfigEither = Yaml.decodeFileEither

simulation/src/LeiosProtocol/Short.hs

@@ -17,6 +17,7 @@
 module LeiosProtocol.Short (module LeiosProtocol.Short, DiffusionStrategy (..)) where
 
 import Chan (mkConnectionConfig)
+import Control.DeepSeq
 import Control.Exception (assert)
 import Control.Monad (guard)
 import Data.Kind
@@ -105,6 +106,11 @@ data LeiosConfig = forall p. IsPipeline p => LeiosConfig
   -- ^ maximum age of an uncertified endorsement block before it expires
   , cleanupPolicies :: CleanupPolicies
   -- ^ active cleanup policies
+  , variant :: LeiosVariant
+  , headerDiffusionTime :: NominalDiffTime
+  -- ^ Δ_{hdr}.
+  , pipelinesToReferenceFromEB :: Int
+  -- ^ how many older pipelines to reference from an EB when `variant = Full`.
   , votingFrequencyPerStage :: Double
   , voteSendStage :: Stage p
   , votesForCertificate :: Int
@@ -125,17 +131,25 @@ convertConfig disk =
       else (\x -> x)
   )
     $ case voting of
-      SomeStage pipeline voteSendStage ->
+      SomeStage pipeline voteSendStage -> do
+        let sliceLength = fromIntegral disk.leiosStageLengthSlots
         LeiosConfig
           { praos
           , pipeline
           , voteSendStage
-          , sliceLength = fromIntegral disk.leiosStageLengthSlots
+          , sliceLength
           , inputBlockFrequencyPerSlot = disk.ibGenerationProbability
           , endorseBlockFrequencyPerStage = disk.ebGenerationProbability
           , maxEndorseBlockAgeSlots = fromIntegral disk.ebMaxAgeSlots
           , maxEndorseBlockAgeForRelaySlots = fromIntegral disk.ebMaxAgeForRelaySlots
           , cleanupPolicies = disk.cleanupPolicies
+          , variant = disk.leiosVariant
+          , headerDiffusionTime = realToFrac $ durationMsToDiffTime disk.leiosHeaderDiffusionTimeMs
+          , pipelinesToReferenceFromEB =
+              if disk.leiosVariant == Full
+                then
+                  ceiling ((3 * disk.praosChainQuality) / fromIntegral sliceLength) - 2
+                else 0
           , activeVotingStageLength = fromIntegral disk.leiosStageActiveVotingSlots
           , votingFrequencyPerStage = disk.voteGenerationProbability
           , votesForCertificate = fromIntegral disk.voteThreshold
@@ -210,6 +224,8 @@ convertConfig disk =
           fromIntegral $
             disk.ebSizeBytesConstant
               + disk.ebSizeBytesPerIb `forEach` eb.inputBlocks
+              -- TODO: make it a per-ref field.
+              + disk.ebSizeBytesPerIb `forEach` eb.endorseBlocksEarlierPipeline
       , voteMsg = \vt ->
           fromIntegral $
             disk.voteBundleSizeBytesConstant
@@ -265,6 +281,9 @@ delaysAndSizesAsFull cfg@LeiosConfig{pipeline, voteSendStage} =
     , maxEndorseBlockAgeSlots = cfg.maxEndorseBlockAgeSlots
     , maxEndorseBlockAgeForRelaySlots = fromIntegral cfg.maxEndorseBlockAgeForRelaySlots
     , cleanupPolicies = cfg.cleanupPolicies
+    , variant = cfg.variant
+    , headerDiffusionTime = cfg.headerDiffusionTime
+    , pipelinesToReferenceFromEB = cfg.pipelinesToReferenceFromEB
     , activeVotingStageLength = cfg.activeVotingStageLength
     , votingFrequencyPerStage = cfg.votingFrequencyPerStage
     , voteSendStage = voteSendStage
@@ -395,7 +414,7 @@ instance IsPipeline a => Bounded (Stage a) where
     [] -> undefined
   maxBound = last allStages
 
-inRange :: SlotNo -> (SlotNo, SlotNo) -> Bool
+inRange :: Ord a => a -> (a, a) -> Bool
 inRange s (a, b) = a <= s && s <= b
 
 rangePrefix :: Int -> (SlotNo, SlotNo) -> (SlotNo, SlotNo)
@@ -473,10 +492,16 @@ proposeRange :: LeiosConfig -> PipelineNo -> (SlotNo, SlotNo)
 proposeRange cfg@LeiosConfig{pipeline = (_ :: SingPipeline p)} p =
   stageRangeOf @p cfg p Propose
 
+pipelineRange :: LeiosConfig -> PipelineNo -> (SlotNo, SlotNo)
+pipelineRange cfg p = (fst $ proposeRange cfg p, lastVoteRecv cfg p)
+
 lastUnadoptedEB :: LeiosConfig -> PipelineNo -> SlotNo
 lastUnadoptedEB leios@LeiosConfig{pipeline = (_ :: SingPipeline p), maxEndorseBlockAgeSlots} pipelineNo =
   lastVoteRecv leios pipelineNo + toEnum maxEndorseBlockAgeSlots
 
+endorseBlockPipeline :: LeiosConfig -> EndorseBlock -> PipelineNo
+endorseBlockPipeline cfg@LeiosConfig{pipeline = _ :: SingPipeline p} eb = pipelineOf @p cfg Endorse eb.slot
+
 ----------------------------------------------------------------------------------------------
 ---- Smart constructors
 ----------------------------------------------------------------------------------------------
@@ -510,21 +535,27 @@ mkInputBlock _cfg header bodySize = assert (messageSizeBytes ib >= segmentSize)
   ib = InputBlock{header, body = InputBlockBody{id = header.id, size = bodySize, slot = header.slot}}
 
 mkEndorseBlock ::
-  LeiosConfig -> EndorseBlockId -> SlotNo -> NodeId -> [InputBlockId] -> EndorseBlock
-mkEndorseBlock cfg@LeiosConfig{pipeline = _ :: SingPipeline p} id slot producer inputBlocks =
-  -- Endorse blocks are produced at the beginning of the stage.
-  assert (stageStart @p cfg Endorse slot Endorse == Just slot) $
-    fixSize cfg $
-      EndorseBlock{endorseBlocksEarlierStage = [], endorseBlocksEarlierPipeline = [], size = 0, ..}
+  LeiosConfig -> EndorseBlockId -> SlotNo -> NodeId -> [EndorseBlockId] -> [InputBlockId] -> EndorseBlock
+mkEndorseBlock cfg@LeiosConfig{pipeline = _ :: SingPipeline p} id slot producer endorseBlocksEarlierPipeline inputBlocks =
+  assert (cfg.variant == Full || null endorseBlocksEarlierPipeline) $
+    -- Endorse blocks are produced at the beginning of the stage.
+    assert (stageStart @p cfg Endorse slot Endorse == Just slot) $
+      rnf endorseBlocksEarlierPipeline `seq`
+        rnf inputBlocks `seq`
+          fixSize
+            cfg
+            EndorseBlock{endorseBlocksEarlierStage = [], size = 0, ..}
 
 mockEndorseBlock :: LeiosConfig -> Int -> EndorseBlock
 mockEndorseBlock cfg n =
-  mkEndorseBlock
-    cfg
-    (EndorseBlockId (NodeId 0) 0)
-    0
-    (NodeId 0)
-    [InputBlockId (NodeId 0) i | i <- [0 .. n - 1]]
+  assert (cfg.variant /= Full) $
+    mkEndorseBlock
+      cfg
+      (EndorseBlockId (NodeId 0) 0)
+      0
+      (NodeId 0)
+      []
+      [InputBlockId (NodeId 0) i | i <- [0 .. n - 1]]
 
 mockFullEndorseBlock :: LeiosConfig -> EndorseBlock
 mockFullEndorseBlock cfg = mockEndorseBlock cfg $ cfg.sliceLength * (ceiling cfg.inputBlockFrequencyPerSlot)
@@ -613,8 +644,10 @@ newtype InputBlocksSnapshot = InputBlocksSnapshot
   { validInputBlocks :: InputBlocksQuery -> [InputBlockId]
   }
 
-newtype EndorseBlocksSnapshot = EndorseBlocksSnapshot
+data EndorseBlocksSnapshot = EndorseBlocksSnapshot
   { validEndorseBlocks :: (SlotNo, SlotNo) -> [EndorseBlock]
+  , --  , endorseBlocksInChain :: (SlotNo, SlotNo) -> [EndorseBlock]
+    certifiedEndorseBlocks :: (PipelineNo, PipelineNo) -> [(PipelineNo, [(EndorseBlock, Certificate, UTCTime)])]
   }
 
 -- | Both constraints are inclusive.
@@ -640,16 +673,37 @@ inputBlocksToEndorse cfg@LeiosConfig{pipeline = _ :: SingPipeline p} current buf
         , receivedBy
         }
 
+-- | Returns possible EBs to reference from current pipeline EB.
+endorseBlocksToReference ::
+  LeiosConfig ->
+  PipelineNo ->
+  EndorseBlocksSnapshot ->
+  (PipelineNo -> UTCTime -> Bool) ->
+  [(PipelineNo, [EndorseBlock])]
+endorseBlocksToReference LeiosConfig{variant = Short} _ _ _ = []
+endorseBlocksToReference cfg@LeiosConfig{variant = Full} pl EndorseBlocksSnapshot{..} checkDeliveryTime =
+  [ (p, [eb | (eb, _, _) <- es])
+  | (p, es) <- ebs
+  , or [checkDeliveryTime p t | (_, _, t) <- es]
+  ]
+ where
+  newestPL = toEnum $ max 0 $ fromEnum pl - 2
+  oldestPL = toEnum $ max 0 $ fromEnum newestPL - cfg.pipelinesToReferenceFromEB
+  ebs = certifiedEndorseBlocks (oldestPL, newestPL)
+
 shouldVoteOnEB ::
   LeiosConfig ->
+  SlotConfig ->
   -- | current slot
   SlotNo ->
   InputBlocksSnapshot ->
+  EndorseBlocksSnapshot ->
   EndorseBlock ->
   Bool
-shouldVoteOnEB cfg@LeiosConfig{voteSendStage} slot _buffers
+shouldVoteOnEB cfg@LeiosConfig{voteSendStage} _ slot _buffers _
+  -- checks whether a pipeline has been started before.
   | Nothing <- stageRange cfg voteSendStage slot Propose = const False
-shouldVoteOnEB cfg@LeiosConfig{voteSendStage} slot buffers = cond
+shouldVoteOnEB cfg@LeiosConfig{voteSendStage} slotConfig slot buffers ebuffers = cond
  where
   generatedBetween = fromMaybe (error "impossible") $ stageRange cfg voteSendStage slot Propose
   receivedByEndorse =
@@ -669,35 +723,50 @@ shouldVoteOnEB cfg@LeiosConfig{voteSendStage} slot buffers = cond
   -- Note: maybe order on (slot, subSlot, vrf proof) should be used instead?
   subset xs ys = all (`elem` ys) xs
 
+  endOfPipelineTime p = slotTime slotConfig (snd (pipelineRange cfg p))
+
   cond :: EndorseBlock -> Bool
-  cond eb = assert assumptions $ acd && b
+  cond eb = assert assumptions $ acd && b && full
    where
     assumptions =
       null eb.endorseBlocksEarlierStage
-        && null eb.endorseBlocksEarlierPipeline
+        && (null eb.endorseBlocksEarlierPipeline || cfg.variant == Full)
         && eb.slot `inRange` fromMaybe (error "impossible") (stageRange cfg voteSendStage slot Endorse)
     -- A. all referenced IBs have been received by the end of the Endorse stage,
     -- C. all referenced IBs validate (wrt. script execution), and,
     -- D. only IBs from this pipeline’s Propose stage are referenced (and not from other pipelines).
     acd = eb.inputBlocks `subset` receivedByEndorse
     -- B. all IBs seen by the end of the Deliver 1 stage are referenced,
     b = receivedByDeliver1 `subset` eb.inputBlocks
+    -- assumes eb.endorseBlocksEarlierPipeline are in pipeline order.
+    full =
+      and $
+        zipWith elem eb.endorseBlocksEarlierPipeline $
+          [ map (.id) es
+          | (_, es) <-
+              endorseBlocksToReference
+                cfg
+                (endorseBlockPipeline cfg eb)
+                ebuffers
+                ( \p t ->
+                    addUTCTime cfg.headerDiffusionTime t < endOfPipelineTime p
+                )
+          , not (null es)
+          ]
 
 endorseBlocksToVoteFor ::
   LeiosConfig ->
+  SlotConfig ->
   -- | current slot
   SlotNo ->
   InputBlocksSnapshot ->
   EndorseBlocksSnapshot ->
   [EndorseBlock]
-endorseBlocksToVoteFor cfg@LeiosConfig{voteSendStage} slot ibs ebs =
-  let cond = shouldVoteOnEB cfg slot ibs
+endorseBlocksToVoteFor cfg@LeiosConfig{voteSendStage} slotConfig slot ibs ebs =
+  let cond = shouldVoteOnEB cfg slotConfig slot ibs ebs
    in filter cond $
         maybe [] ebs.validEndorseBlocks (stageRange cfg voteSendStage slot Endorse)
 
-endorseBlockPipeline :: LeiosConfig -> EndorseBlock -> PipelineNo
-endorseBlockPipeline cfg@LeiosConfig{pipeline = _ :: SingPipeline p} eb = pipelineOf @p cfg Endorse eb.slot
-
 -----------------------------------------------------------------
 ---- Expected generation rates in each slot.
 -----------------------------------------------------------------