WIP implementing state-machine tests for PerasVoteDB

Author: agustinmista

ouroboros-consensus/ouroboros-consensus.cabal

@@ -804,6 +804,9 @@ test-suite storage-test
     Test.Ouroboros.Storage.PerasCertDB
     Test.Ouroboros.Storage.PerasCertDB.Model
     Test.Ouroboros.Storage.PerasCertDB.StateMachine
+    Test.Ouroboros.Storage.PerasVoteDB
+    Test.Ouroboros.Storage.PerasVoteDB.Model
+    Test.Ouroboros.Storage.PerasVoteDB.StateMachine
     Test.Ouroboros.Storage.VolatileDB
     Test.Ouroboros.Storage.VolatileDB.Mock
     Test.Ouroboros.Storage.VolatileDB.Model
@@ -816,6 +819,7 @@ test-suite storage-test
     bifunctors,
     bytestring,
     cardano-binary,
+    cardano-crypto-class,
     cardano-ledger-binary:testlib,
     cardano-ledger-core:{cardano-ledger-core, testlib},
     cardano-slotting:{cardano-slotting, testlib},

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Vote/Aggregation.hs

@@ -50,6 +50,7 @@ data PerasRoundVoteState blk
       }
   | PerasRoundVoteStateQuorumReachedAlready
       { prvsRoundNo :: !PerasRoundNo
+      , prvsExcessVotes :: !Word64
       , prvsLoserStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Loser))
       , prvsWinnerState :: !(PerasTargetVoteState blk 'Winner)
       }
@@ -64,8 +65,8 @@ prvsMaybeCert :: PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
 prvsMaybeCert = \case
   PerasRoundVoteStateQuorumNotReached{} ->
     Nothing
-  PerasRoundVoteStateQuorumReachedAlready _ _ winner ->
-    let (PerasTargetVoteWinner _ _ cert) = winner
+  PerasRoundVoteStateQuorumReachedAlready _ _ _ winner ->
+    let (PerasTargetVoteWinner _ cert) = winner
      in Just cert
 
 -- | Create a fresh round vote state for the given round number
@@ -138,31 +139,43 @@ updatePerasRoundVoteState vote cfg roundState = do
           pure $
             PerasRoundVoteStateQuorumReachedAlready
               { prvsRoundNo = prvsRoundNo roundState
+              , prvsExcessVotes = 0
               , prvsLoserStates = loserStates
               , prvsWinnerState = winnerState
               }
 
     -- Quorum already reached
     state@PerasRoundVoteStateQuorumReachedAlready{prvsLoserStates, prvsWinnerState} -> do
-      let votePoint = getPerasVoteBlock vote
-          winnerPoint = getPerasVoteBlock prvsWinnerState
-          existingOrFreshLoserVoteState =
-            fromMaybe (freshLoserVoteState (getPerasVoteTarget vote))
-
-          updateMaybeLoser mState =
-            updateLoserVoteState cfg vote (existingOrFreshLoserVoteState mState)
-              `onErr` \err ->
-                RoundVoteStateLoserAboveQuorum prvsWinnerState err
+      let votePoint =
+            getPerasVoteBlock vote
+          winnerPoint =
+            getPerasVoteBlock prvsWinnerState
 
       if votePoint == winnerPoint
-        then
+        -- The vote ratifies the winner => update winner state
+        then do
+          let winnerState' = updateWinnerVoteState vote prvsWinnerState
           pure $
-            state{prvsWinnerState = updateWinnerVoteState vote prvsWinnerState}
+            state
+              { prvsExcessVotes = prvsExcessVotes state + 1
+              , prvsWinnerState = winnerState'
+              }
+
+        -- The vote is for a loser => update loser state
         else do
-          prvsLoserStates' <-
-            Map.alterF (fmap Just . updateMaybeLoser) votePoint prvsLoserStates
+          let existingOrFreshLoserVoteState =
+                fromMaybe (freshLoserVoteState (getPerasVoteTarget vote))
+              updateMaybeLoserVoteState mState =
+                fmap Just $
+                  updateLoserVoteState cfg vote (existingOrFreshLoserVoteState mState)
+                    `onErr` \err ->
+                      RoundVoteStateLoserAboveQuorum prvsWinnerState err
+          prvsLoserStates' <- Map.alterF updateMaybeLoserVoteState votePoint prvsLoserStates
           pure $
-            state{prvsLoserStates = prvsLoserStates'}
+            state
+              { prvsExcessVotes = prvsExcessVotes state + 1
+              , prvsLoserStates = prvsLoserStates'
+              }
 
 -- | Updates the round vote states map with the given vote.
 --
@@ -243,9 +256,11 @@ pattern VoteDidntGenerateNewCert <-
 voteGeneratedCert :: PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
 voteGeneratedCert = \case
   PerasRoundVoteStateQuorumReachedAlready
-    { prvsWinnerState = PerasTargetVoteWinner _ 0 cert
+    { prvsExcessVotes = 0
+    , prvsWinnerState = PerasTargetVoteWinner _ cert
     } -> Just cert
-  _ -> Nothing
+  _ ->
+    Nothing
 
 {-------------------------------------------------------------------------------
   Peras target vote tally
@@ -340,9 +355,6 @@ data PerasTargetVoteState blk (status :: PerasTargetVoteStatus) where
     PerasTargetVoteState blk 'Loser
   PerasTargetVoteWinner ::
     !(PerasTargetVoteTally blk) ->
-    -- | Number of extra votes received since the target was elected winner and
-    -- the cert was forged.
-    !Word64 ->
     !(ValidatedPerasCert blk) ->
     PerasTargetVoteState blk 'Winner
 
@@ -380,8 +392,8 @@ instance
     noThunks ctx tally
   noThunks ctx (PerasTargetVoteLoser tally) =
     noThunks ctx tally
-  noThunks ctx (PerasTargetVoteWinner tally w cert) =
-    noThunks ctx (tally, w, cert)
+  noThunks ctx (PerasTargetVoteWinner tally cert) =
+    noThunks ctx (tally, cert)
 
 instance HasPerasVoteTarget (PerasTargetVoteState blk status) blk where
   getPerasVoteTarget = getPerasVoteTarget . ptvsVoteTally
@@ -397,7 +409,7 @@ ptvsVoteTally :: PerasTargetVoteState blk status -> PerasTargetVoteTally blk
 ptvsVoteTally = \case
   PerasTargetVoteCandidate tally -> tally
   PerasTargetVoteLoser tally -> tally
-  PerasTargetVoteWinner tally _ _ -> tally
+  PerasTargetVoteWinner tally _ -> tally
 
 freshCandidateVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate
 freshCandidateVoteState target =
@@ -443,7 +455,7 @@ updateCandidateVoteState cfg vote oldState = do
    in if stakeAboveThreshold cfg (ptvtTotalStake newVoteTally)
         then do
           cert <- forgePerasCert cfg (ptvtTarget newVoteTally) voteList
-          pure $ BecameWinner (PerasTargetVoteWinner newVoteTally 0 cert)
+          pure $ BecameWinner (PerasTargetVoteWinner newVoteTally cert)
         else
           pure $ RemainedCandidate (PerasTargetVoteCandidate newVoteTally)
 
@@ -475,8 +487,8 @@ updateWinnerVoteState ::
   PerasTargetVoteState blk 'Winner
 updateWinnerVoteState vote oldState =
   let newVoteTally = updateTargetVoteTally vote (ptvsVoteTally oldState)
-      (PerasTargetVoteWinner _ extraCertCount cert) = oldState
-   in PerasTargetVoteWinner newVoteTally (extraCertCount + 1) cert
+      (PerasTargetVoteWinner _ cert) = oldState
+   in PerasTargetVoteWinner newVoteTally cert
 
 {-------------------------------------------------------------------------------
   Helpers

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/API.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Ouroboros.Consensus.Storage.PerasVoteDB.API
   ( PerasVoteDB (..)
@@ -55,7 +56,7 @@ data PerasVoteSnapshot blk = PerasVoteSnapshot
 
 -- | A sequence number, incremented every time we receive a new vote.
 newtype PerasVoteTicketNo = PerasVoteTicketNo Word64
-  deriving stock Show
+  deriving stock (Generic, Show)
   deriving newtype (Eq, Ord, Enum, NoThunks)
 
 zeroPerasVoteTicketNo :: PerasVoteTicketNo

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage.hs

@@ -6,6 +6,7 @@ import qualified Test.Ouroboros.Storage.ChainDB as ChainDB
 import qualified Test.Ouroboros.Storage.ImmutableDB as ImmutableDB
 import qualified Test.Ouroboros.Storage.LedgerDB as LedgerDB
 import qualified Test.Ouroboros.Storage.PerasCertDB as PerasCertDB
+import qualified Test.Ouroboros.Storage.PerasVoteDB as PerasVoteDB
 import qualified Test.Ouroboros.Storage.VolatileDB as VolatileDB
 import Test.Tasty (TestTree, testGroup)
 
@@ -22,4 +23,5 @@ tests =
     , LedgerDB.tests
     , ChainDB.tests
     , PerasCertDB.tests
+    , PerasVoteDB.tests
     ]

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/Orphans.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -19,6 +20,7 @@ import Ouroboros.Consensus.Util.CallStack
 import System.FS.API.Types (FsError, sameFsError)
 import Test.QuickCheck.StateModel (HasVariables)
 import Test.QuickCheck.StateModel.Variables (HasVariables (..))
+import Cardano.Crypto.Hash.Class (PackedBytes)
 
 {-------------------------------------------------------------------------------
   PrettyCallStack
@@ -76,3 +78,17 @@ deriving instance StandardHash blk => Eq (ChainDbError blk)
 
 instance HasVariables NominalDiffTime where
   getAllVariables _ = mempty
+
+{-------------------------------------------------------------------------------
+  Rational
+-------------------------------------------------------------------------------}
+
+instance HasVariables Rational where
+  getAllVariables _ = mempty
+
+{-------------------------------------------------------------------------------
+  PackedBytes
+-------------------------------------------------------------------------------}
+
+instance HasVariables (PackedBytes a) where
+  getAllVariables _ = mempty

ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/PerasVoteDB.hs

@@ -0,0 +1,15 @@
+module Test.Ouroboros.Storage.PerasVoteDB (tests) where
+
+import qualified Test.Ouroboros.Storage.PerasVoteDB.StateMachine as StateMachine
+import Test.Tasty (TestTree, testGroup)
+
+--
+-- The list of all PerasVoteDB tests
+--
+
+tests :: TestTree
+tests =
+  testGroup
+    "PerasVoteDB"
+    [ StateMachine.tests
+    ]