feat(config,simulation): add cleanup-policies configuration

Author: Wen Kokke

data/simulation/config.d.ts

@@ -20,6 +20,8 @@ export interface Config {
    *   - EBs reference `ceil (ib-generation-probability * leios-stage-length-slots)` IBs.
    * Only supported by Haskell simulation. */
   "treat-blocks-as-full": boolean;
+  /** Only supported by Haskell simulation. */
+  "cleanup-policies": CleanupPolicies;
 
   // Leios Protocol Configuration
   "leios-stage-length-slots": bigint;
@@ -118,6 +120,15 @@ export interface Config {
   "cert-size-bytes-per-node": bigint;
 }
 
+export type CleanupPolicies = "all" | CleanupPolicy[];
+
+export type CleanupPolicy =
+  | "cleanup-expired-ib"
+  | "cleanup-expired-uncertified-eb"
+  | "cleanup-expired-unadopted-eb"
+  | "cleanup-expired-vote"
+  | "cleanup-expired-certificate";
+
 export type Distribution =
   | NormalDistribution
   | ExpDistribution

data/simulation/config.default.yaml

@@ -16,6 +16,7 @@ tcp-congestion-control: true
 multiplex-mini-protocols: true
 simulate-transactions: true
 treat-blocks-as-full: false
+cleanup-policies: ["cleanup-expired-vote"]
 
 ################################################################################
 # Leios Protocol Configuration

data/simulation/config.schema.json

@@ -1,6 +1,30 @@
 {
   "$schema": "http://json-schema.org/draft-07/schema#",
   "definitions": {
+    "CleanupPolicies": {
+      "anyOf": [
+        {
+          "items": {
+            "$ref": "#/definitions/CleanupPolicy"
+          },
+          "type": "array"
+        },
+        {
+          "const": "all",
+          "type": "string"
+        }
+      ]
+    },
+    "CleanupPolicy": {
+      "enum": [
+        "cleanup-expired-certificate",
+        "cleanup-expired-ib",
+        "cleanup-expired-unadopted-eb",
+        "cleanup-expired-uncertified-eb",
+        "cleanup-expired-vote"
+      ],
+      "type": "string"
+    },
     "ConstantDistribution": {
       "properties": {
         "distribution": {
@@ -107,6 +131,10 @@
     "cert-validation-cpu-time-ms-per-node": {
       "type": "number"
     },
+    "cleanup-policies": {
+      "$ref": "#/definitions/CleanupPolicies",
+      "description": "Only supported by Haskell simulation."
+    },
     "eb-diffusion-max-bodies-to-request": {
       "additionalProperties": false,
       "description": "Only supported by Haskell simulation.",

simulation/src/LeiosProtocol/Config.hs

@@ -21,6 +21,8 @@ import Data.Aeson.Encoding (pairs)
 import Data.Aeson.Types (Encoding, FromJSON (..), KeyValue ((.=)), Options (constructorTagModifier), Parser, ToJSON (..), Value (..), genericParseJSON, object, typeMismatch, withObject, (.:))
 import Data.Default (Default (..))
 import Data.Maybe (catMaybes)
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Data.Text (Text)
 import Data.Word
 import Data.Yaml (ParseException)
@@ -59,11 +61,36 @@ data RelayStrategy
   | RequestFromAll
   deriving (Show, Eq, Generic)
 
+-- | Data expiration.
+newtype CleanupPolicies = CleanupPolicies (Set CleanupPolicy)
+  deriving (Show, Eq, Ord, Monoid, Semigroup)
+
+-- | Data types for expiration policy.
+data CleanupPolicy
+  = CleanupExpiredIb
+  | CleanupExpiredUncertifiedEb
+  | CleanupExpiredUnadoptedEb
+  | CleanupExpiredVote
+  | CleanupExpiredCertificate
+  deriving (Show, Eq, Ord, Generic, Bounded, Enum)
+
+isEnabledIn :: CleanupPolicy -> CleanupPolicies -> Bool
+isEnabledIn cleanupPolicy (CleanupPolicies cleanupPolicies) =
+  cleanupPolicy `Set.member` cleanupPolicies
+
+instance Default CleanupPolicies where
+  def :: CleanupPolicies
+  def = CleanupPolicies $ Set.fromList [CleanupExpiredVote]
+
+allCleanupPolicies :: CleanupPolicies
+allCleanupPolicies = CleanupPolicies $ Set.fromList [minBound .. maxBound]
+
 data Config = Config
   { relayStrategy :: RelayStrategy
   , tcpCongestionControl :: Bool
   , multiplexMiniProtocols :: Bool
   , treatBlocksAsFull :: Bool
+  , cleanupPolicies :: CleanupPolicies
   , leiosStageLengthSlots :: Word
   , leiosStageActiveVotingSlots :: Word
   , leiosVoteSendRecvStages :: Bool
@@ -129,6 +156,7 @@ instance Default Config where
       , tcpCongestionControl = True
       , multiplexMiniProtocols = True
       , treatBlocksAsFull = False
+      , cleanupPolicies = def
       , leiosStageLengthSlots = 20
       , leiosStageActiveVotingSlots = 1
       , leiosVoteSendRecvStages = False
@@ -198,6 +226,7 @@ configToKVsWith getter cfg =
     , get @"tcpCongestionControl" getter cfg
     , get @"multiplexMiniProtocols" getter cfg
     , get @"treatBlocksAsFull" getter cfg
+    , get @"cleanupPolicies" getter cfg
     , get @"leiosStageLengthSlots" getter cfg
     , get @"leiosStageActiveVotingSlots" getter cfg
     , get @"leiosVoteSendRecvStages" getter cfg
@@ -277,6 +306,7 @@ instance FromJSON Config where
     tcpCongestionControl <- parseFieldOrDefault @Config @"tcpCongestionControl" obj
     multiplexMiniProtocols <- parseFieldOrDefault @Config @"multiplexMiniProtocols" obj
     treatBlocksAsFull <- parseFieldOrDefault @Config @"treatBlocksAsFull" obj
+    cleanupPolicies <- parseFieldOrDefault @Config @"cleanupPolicies" obj
     leiosStageLengthSlots <- parseFieldOrDefault @Config @"leiosStageLengthSlots" obj
     leiosStageActiveVotingSlots <- parseFieldOrDefault @Config @"leiosStageActiveVotingSlots" obj
     leiosVoteSendRecvStages <- parseFieldOrDefault @Config @"leiosVoteSendRecvStages" obj
@@ -383,13 +413,32 @@ instance FromJSON Distribution where
    where
     orUnknown k v = k v <|> pure (Unknown v)
 
+instance FromJSON CleanupPolicies where
+  parseJSON cleanupPolicies@(Array _) =
+    CleanupPolicies . Set.fromList <$> parseJSONList cleanupPolicies
+  parseJSON (String cleanupPolicies)
+    | cleanupPolicies == "all" = pure allCleanupPolicies
+  parseJSON v = typeMismatch "CleanupPolicies" v
+
+instance ToJSON CleanupPolicies where
+  toJSON cleanupPolicies@(CleanupPolicies cleanupPolicySet)
+    | cleanupPolicies == allCleanupPolicies = String "all"
+    | otherwise = toJSONList $ Set.toAscList cleanupPolicySet
+
 defaultEnumOptions :: Options
 defaultEnumOptions =
   defaultOptions
     { constructorTagModifier = camelToKebab
     , allNullaryToStringTag = True
     }
 
+instance FromJSON CleanupPolicy where
+  parseJSON = genericParseJSON defaultEnumOptions
+
+instance ToJSON CleanupPolicy where
+  toJSON = genericToJSON defaultEnumOptions
+  toEncoding = genericToEncoding defaultEnumOptions
+
 instance FromJSON DiffusionStrategy where
   parseJSON = genericParseJSON defaultEnumOptions
 

simulation/src/LeiosProtocol/Short.hs

@@ -101,6 +101,8 @@ data LeiosConfig = forall p. IsPipeline p => LeiosConfig
   -- ^ prefix of the voting stage where new votes are generated, <= sliceLength.
   , maxEndorseBlockAgeSlots :: Int
   -- ^ maximum age of a certified endorsement block before it expires
+  , cleanupPolicies :: CleanupPolicies
+  -- ^ active cleanup policies
   , votingFrequencyPerStage :: Double
   , voteSendStage :: Stage p
   , votesForCertificate :: Int
@@ -130,6 +132,7 @@ convertConfig disk =
           , inputBlockFrequencyPerSlot = disk.ibGenerationProbability
           , endorseBlockFrequencyPerStage = disk.ebGenerationProbability
           , maxEndorseBlockAgeSlots = fromIntegral disk.ebMaxAgeSlots
+          , cleanupPolicies = disk.cleanupPolicies
           , activeVotingStageLength = fromIntegral disk.leiosStageActiveVotingSlots
           , votingFrequencyPerStage = disk.voteGenerationProbability
           , votesForCertificate = fromIntegral disk.voteThreshold
@@ -257,6 +260,7 @@ delaysAndSizesAsFull cfg@LeiosConfig{pipeline, voteSendStage} =
     , inputBlockFrequencyPerSlot = cfg.inputBlockFrequencyPerSlot
     , endorseBlockFrequencyPerStage = cfg.endorseBlockFrequencyPerStage
     , maxEndorseBlockAgeSlots = cfg.maxEndorseBlockAgeSlots
+    , cleanupPolicies = cfg.cleanupPolicies
     , activeVotingStageLength = cfg.activeVotingStageLength
     , votingFrequencyPerStage = cfg.votingFrequencyPerStage
     , voteSendStage = voteSendStage

simulation/src/LeiosProtocol/Short/Node.hs

@@ -54,7 +54,7 @@ import PraosProtocol.BlockFetch (
 import qualified PraosProtocol.Common.Chain as Chain
 import qualified PraosProtocol.PraosNode as PraosNode
 import STMCompat
-import SimTypes (NodeId (..), cpuTask)
+import SimTypes (cpuTask)
 import System.Random
 import Text.Printf (printf)
 
@@ -441,10 +441,17 @@ leiosNode tracer cfg followers peers = do
   -- TODO: expiration times to be decided. At least need EB/IBs to be
   -- around long enough to compute ledger state if they end in RB.
   let pruningThreads =
-        [ pruneExpiredVotes tracer cfg leiosState
-        , pruneExpiredUnadoptedEBs tracer cfg leiosState
-        , pruneExpiredUncertifiedEBs tracer cfg leiosState
-        ]
+        concat
+          [ [ pruneExpiredVotes tracer cfg leiosState
+            | CleanupExpiredVote `isEnabledIn` cfg.leios.cleanupPolicies
+            ]
+          , [ pruneExpiredUncertifiedEBs tracer cfg leiosState
+            | CleanupExpiredUncertifiedEb `isEnabledIn` cfg.leios.cleanupPolicies
+            ]
+          , [ pruneExpiredUnadoptedEBs tracer cfg leiosState
+            | CleanupExpiredUnadoptedEb `isEnabledIn` cfg.leios.cleanupPolicies
+            ]
+          ]
 
   return $
     concat

simulation/src/LeiosProtocol/Short/Sim.hs

@@ -29,6 +29,7 @@ import Control.Tracer as Tracer (
 import Data.Aeson
 import Data.Aeson.Encoding (pair)
 import Data.Coerce
+import Data.Default (Default (..))
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -331,13 +332,14 @@ traceRelayLink1 connectionOptions =
       let leiosConfig =
             LeiosConfig
               { praos = praosConfig
-              , sliceLength = 5 -- matching the interval between RBs
-              , -- \^ measured in slots, also stage length in Short leios.
-                inputBlockFrequencyPerSlot = 5
-              , -- \^ expected InputBlock generation rate per slot.
+              , -- measured in slots, also stage length in Short leios.
+                sliceLength = 5 -- matching the interval between RBs
+                -- expected InputBlock generation rate per slot.
+              , inputBlockFrequencyPerSlot = 5
+              , -- expected EndorseBlock generation rate per stage, at most one per _node_ in each (pipeline, stage).
                 endorseBlockFrequencyPerStage = 4
-              , -- \^ expected EndorseBlock generation rate per stage, at most one per _node_ in each (pipeline, stage).
-                activeVotingStageLength = 1
+              , cleanupPolicies = def
+              , activeVotingStageLength = 1
               , pipeline = SingSingleVote
               , voteSendStage = Vote
               , votingFrequencyPerStage = 4