Merge pull request #230 from input-output-hk/bwbush/refactor-conformance

Added equivocated blocks to conformance tests

peras-simulation/example-test-results.log

@@ -0,0 +1,161 @@
+Peras.Conformance.Test
+  Prototype node
+    Simulation respects model [✔]
+      +++ OK, passed 5000 tests.
+
+      Action polarity (374648 in total):
+      100.0000% +
+
+      Actions (374648 in total):
+      71.9200% +Tick
+      20.1760% +NewChain
+       3.9928% +BadChain
+       1.6362% +BadVote
+       1.2911% +Initial
+       0.9839% +NewVote
+
+      Actions rejected by precondition (119122 in total):
+      100.0000% NewChain
+
+      Certs created (cumulative, rounded down) (369811 in total):
+      68.4401% 1
+      20.6097% 2
+       8.0711% 3
+       1.8501% 4
+       0.6852% 5
+       0.2250% 6
+       0.1128% 7
+       0.0059% 8
+
+      Certs found or created during fetching (max one per round) (369811 in total):
+      99.5465% 0
+       0.4535% 1
+
+      Certs on preferred chain (cumulative) (369811 in total):
+      71.1788% 0
+      22.3714% 1
+       4.8019% 2
+       1.1771% 3
+       0.3077% 4
+       0.1057% 5
+       0.0573% 6
+
+      Committee member (9722 in total):
+      95.08% True
+       4.92% False
+
+      Does vote (9722 in total):
+      66.27% 1
+      33.73% 0
+
+      New quora (369811 in total):
+      99.5465% 0
+       0.4535% 1
+
+      NewVote during voting (12641 in total):
+      70.841% False
+      29.159% True
+
+      Preferred chain length (cumulative, rounded down) (369811 in total):
+      46.3750% 0
+      23.4942% 25
+      12.4972% 50
+       6.9909% 75
+       4.3133% 100
+       2.5892% 125
+       1.5822% 150
+       0.9180% 175
+       0.5649% 200
+       0.3353% 225
+       0.1501% 250
+       0.1090% 275
+       0.0576% 300
+       0.0216% 325
+       0.0016% 350
+
+      Preferred chain lengthens (369811 in total):
+      57.6686% False
+      42.3314% True
+
+      Rounds (cumulative, rounded down) (9722 in total):
+      33.97% 0
+      21.42% 1
+      14.15% 2
+       9.23% 3
+       5.97% 4
+       4.13% 5
+       2.82% 6
+       1.97% 7
+       1.54% 8
+       1.27% 9
+       0.92% 10
+       0.59% 11
+       0.55% 12
+       0.34% 13
+       0.32% 14
+       0.20% 15
+       0.10% 16
+       0.10% 17
+       0.06% 18
+       0.06% 20
+       0.05% 19
+       0.03% 22
+       0.03% 30
+       0.03% 33
+       0.02% 21
+       0.02% 23
+       0.02% 31
+       0.02% 34
+       0.01% 24
+       0.01% 25
+       0.01% 26
+       0.01% 27
+       0.01% 28
+       0.01% 29
+       0.01% 32
+
+      Slot leader (369811 in total):
+      75.8163% False
+      24.1837% True
+
+      Slots (cumulative, rounded down) (369811 in total):
+      30.3866% 0
+      20.5770% 25
+      13.7408% 50
+       9.6198% 75
+       6.8097% 100
+       4.8154% 125
+       3.5694% 150
+       2.6841% 175
+       1.9832% 200
+       1.4781% 225
+       1.1544% 250
+       0.8507% 275
+       0.6712% 300
+       0.4759% 325
+       0.3340% 350
+       0.2423% 375
+       0.2015% 400
+       0.1617% 425
+       0.1111% 450
+       0.0844% 475
+       0.0416% 500
+       0.0073% 525
+
+      VR-1A/1B/2A/2B (9722 in total):
+      34.70% True,True,False,False
+      21.47% False,True,True,True
+      15.94% False,True,True,False
+      13.07% False,True,False,False
+       7.95% True,True,True,True
+       6.34% True,True,True,False
+       0.34% False,True,False,True
+       0.19% True,True,False,True
+
+      Voting rules (9722 in total):
+      70.64% True
+      29.36% False
+
+Finished in 741.6096 seconds
+1 example, 0 failures
+

peras-simulation/src/Peras/Conformance/Generators.hs

@@ -17,7 +17,7 @@ import qualified Data.Set as Set (singleton)
 import GHC.Generics (Generic)
 import Peras.Arbitraries ()
 import Peras.Block (
-  Block (MkBlock, certificate, creatorId, slotNumber),
+  Block (..),
   Certificate (MkCertificate, round),
   PartyId,
  )
@@ -39,6 +39,7 @@ import Peras.Numbering (
  )
 import Peras.Prototype.Crypto (
   createMembershipProof,
+  createSignedBlock,
   createSignedVote,
   mkParty,
  )
@@ -51,6 +52,7 @@ import Test.QuickCheck (
   chooseInteger,
   elements,
   sublistOf,
+  suchThat,
  )
 import Prelude hiding (round)
 
@@ -160,6 +162,13 @@ genVote gc@MkGenConstraints{voteCurrent, voteObeyVR1A, voteObeyVR1B, voteObeyVR2
       then pure . Just . fromRight undefined . runIdentity $ createSignedVote party' vr block pm 1
       else pure Nothing
 
+genMutatedBlock :: GenConstraints -> Block -> Gen Block
+genMutatedBlock _ MkBlock{slotNumber, creatorId, parentBlock, bodyHash, certificate, leadershipProof} =
+  do
+    bodyHash' <- arbitrary `suchThat` (/= bodyHash)
+    pure . fromRight undefined . runIdentity $
+      createSignedBlock (mkParty creatorId mempty mempty) slotNumber parentBlock certificate leadershipProof bodyHash'
+
 genNewChain :: GenConstraints -> NodeModel -> Gen Chain
 genNewChain gc@MkGenConstraints{blockCurrent} node@NodeModel{clock} =
   do

peras-simulation/src/Peras/Conformance/Model.hs

@@ -40,6 +40,7 @@ data EnvAction
   = Tick
   | NewChain Chain
   | NewVote Vote
+  | BadChain Chain
   | BadVote Vote
   deriving (Eq, Show)
 
@@ -525,6 +526,21 @@ transition _ s (NewVote v) =
     guard (isYes $ checkVotingRules s)
     guard (votingBlockHash s == blockHash v)
     Just (([], []), addVote' s v)
+transition _ s (BadChain blocks) =
+  do
+    guard
+      ( any
+          (\block -> hasForged (slotNumber block) (creatorId block))
+          blocks
+      )
+    Just (([], []), s)
+ where
+  equivocatedBlock :: SlotNumber -> PartyId -> Block -> Bool
+  equivocatedBlock slot pid block =
+    slot == slotNumber block && pid == creatorId block
+  hasForged :: SlotNumber -> PartyId -> Bool
+  hasForged slot pid =
+    any (any $ equivocatedBlock slot pid) $ allChains s
 transition _ s (BadVote v) =
   do
     guard (hasVoted (voterId v) (votingRound v) s)

peras-simulation/src/Peras/Conformance/Test.hs

@@ -36,6 +36,7 @@ import Peras.Conformance.Generators (
   actionsSizeScaling,
   genCommitteeMembership,
   genHonestTick,
+  genMutatedBlock,
   genProtocol,
   genSlotLeadership,
   genVote,
@@ -72,6 +73,7 @@ import Test.QuickCheck (
   Arbitrary (arbitrary),
   choose,
   elements,
+  suchThat,
   tabulate,
  )
 import Test.QuickCheck.DynamicLogic (DynLogicModel)
@@ -136,6 +138,7 @@ instance Pretty EnvAction where
   pPrint (NewChain chain) =
     "NewChain" <+> pPrint chain
   pPrint (NewVote vote) = "NewVote" <+> pPrintPrec prettyNormal 10 vote
+  pPrint (BadChain chain) = "BadVote" <+> pPrintPrec prettyNormal 10 chain
   pPrint (BadVote vote) = "BadVote" <+> pPrintPrec prettyNormal 10 vote
 
 instance Pretty Block where
@@ -205,6 +208,7 @@ instance Pretty Trace.PerasLog where
       hang "DiffuseChain:" 2 $ pPrint chain
     Trace.DiffuseVote{vote} ->
       hang "DiffuseVote" 2 $ pPrint vote
+    Trace.Snapshot s -> hang "Final state" 2 $ pPrint $ show s
 
 sortition :: NetworkModel -> (SutIsSlotLeader, SutIsVoter)
 sortition NetworkModel{leadershipSlots, voterRounds} = (flip elem leadershipSlots, flip elem voterRounds)
@@ -233,13 +237,15 @@ instance StateModel NetworkModel where
           if canGenVotes && newRound clock protocol
             then genVote gen s
             else pure Nothing
+        c <- BadChain <$> genBadChain
         b <- BadVote <$> genBadVote
         fBad <- (<= 0.10) <$> choose (0, 1 :: Double)
         (newChains, newVotes) <- fst <$> genHonestTick True gen s
         fmap (Some . Step) . elements $
           [Tick]
-            ++ (NewChain <$> newChains)
+            ++ (NewChain <$> filter validChain newChains)
             ++ cleanVotes (NewVote <$> newVotes <> maybe mempty pure v)
+            ++ [c | canGenBadChain && fBad]
             ++ [b | canGenBadVote && fBad]
       else scale (`div` actionsSizeScaling) $
         fmap Some $
@@ -251,6 +257,9 @@ instance StateModel NetworkModel where
               <$> genSlotLeadership 0.30 slotLimit
               <*> genCommitteeMembership 0.95 roundLimit
    where
+    validChain [] = True
+    validChain [_] = True
+    validChain (block : rest) = slotNumber block > slotNumber (head rest) && validChain rest -- FIXME: Remove when specification is fixed.
     equivocated MkVote{votingRound = r0, creatorId = p} MkVote{votingRound = r1, creatorId = p'} = r0 == r1 && p == p'
     cleanVotes =
       nubBy
@@ -275,6 +284,12 @@ instance StateModel NetworkModel where
       not (all null allChains) -- There must be some block to vote for.
         && r > 0 -- No voting is allowed in the zeroth round.
         && checkVotingRules' gen s
+    canGenBadChain = not $ all null allChains
+    genBadChain = do
+      elements allChains `suchThat` (not . null)
+        >>= \case
+          block : rest -> (: rest) <$> genMutatedBlock gen block
+          _ -> error "Impossible."
     r = inRound clock protocol
 
   shrinkAction _ _ Initial{} = []
@@ -333,7 +348,7 @@ monitorChain net@NetworkModel{nodeModel = s} NetworkModel{nodeModel = s'@NodeMod
 monitorCerts :: Monad m => NetworkModel -> NetworkModel -> PostconditionM m ()
 monitorCerts NetworkModel{nodeModel = s} NetworkModel{nodeModel = s'} =
   do
-    monitorPost $ tabulate "Certs found or created during fetching" [show $ on (-) (length . allSeenCerts) s' s]
+    monitorPost $ tabulate "Certs found or created during fetching (max one per round)" [show $ on (-) (length . allSeenCerts) s' s]
     monitorPost $ tabulate "New quora" [show $ length $ newQuora (fromIntegral (perasτ (protocol s))) (allSeenCerts s) (allVotes s')]
     monitorPost $ tabulate "Certs on preferred chain (cumulative)" [show $ length $ filter (isJust . certificate) $ pref s']
     monitorPost $ tabulate "Certs created (cumulative, rounded down)" [show $ (* 1) . (`div` 1) $ length $ allSeenCerts s']

peras-simulation/src/Peras/Conformance/Test/External.hs

@@ -183,6 +183,9 @@ instance Realized IO ([Chain], [Vote]) ~ ([Chain], [Vote]) => RunModel NetworkMo
     NewVote v -> do
       modify $ \rs -> rs{unfetchedVotes = unfetchedVotes rs ++ pure v}
       pure (mempty, mempty)
+    BadChain c -> do
+      modify $ \rs -> rs{unfetchedChains = unfetchedChains rs ++ pure c}
+      pure mempty
     BadVote v -> do
       modify $ \rs -> rs{unfetchedVotes = unfetchedVotes rs ++ pure v}
       pure (mempty, mempty)

peras-simulation/src/Peras/Conformance/Test/Prototype.hs

@@ -115,6 +115,9 @@ instance (Realized m () ~ (), Realized m ([Chain], [Vote]) ~ ([Chain], [Vote]),
     NewVote v -> do
       modify $ \rs -> rs{unfetchedVotes = unfetchedVotes rs ++ pure v}
       pure mempty
+    BadChain c -> do
+      modify $ \rs -> rs{unfetchedChains = unfetchedChains rs ++ pure c}
+      pure mempty
     BadVote v -> do
       modify $ \rs -> rs{unfetchedVotes = unfetchedVotes rs ++ pure v}
       pure mempty

peras-simulation/src/Peras/Prototype/Fetching.hs

@@ -21,8 +21,9 @@ import Data.Map (Map)
 import Data.Map as Map (fromList, keys, keysSet, union)
 import Data.Maybe (mapMaybe)
 import Data.Set (Set)
-import qualified Data.Set as Set (filter, fromList, intersection, map, notMember, size, union)
+import qualified Data.Set as Set (filter, fromList, intersection, map, notMember, size, toList, union)
 import Peras.Block (Block (..), Certificate (..), Party (pid))
+import qualified Peras.Block as Block (Block (creatorId, signature, slotNumber))
 import Peras.Chain (Chain, Vote (MkVote, blockHash, votingRound))
 import qualified Peras.Chain as Vote (Vote (creatorId, votingRound))
 import Peras.Crypto (Hash, hash)
@@ -49,9 +50,13 @@ fetching tracer MkPerasParams{..} party stateVar slot newChains newVotes =
 
     -- 1. Fetch new chains Cnew and votes Vnew.
     lift . traceWith tracer $ NewChainAndVotes (pid party) newChains newVotes
-    let isEquivocatedVote = on (==) (Vote.votingRound &&& Vote.creatorId)
-    let newVotes' = Set.fromList $ nubBy isEquivocatedVote newVotes
-        newChains' = Set.fromList newChains
+    let isEquivocatedBlock b b' = on (==) (Block.slotNumber &&& Block.creatorId) b b' && on (/=) Block.signature b b'
+        isEquivocatedChain c = any (\b -> any (isEquivocatedBlock b) c)
+        isEquivocatedVote = on (==) (Vote.votingRound &&& Vote.creatorId)
+        -- NB: The first chain or vote is considered to be unequivocated
+        --     and all subsequent matches are considered to be equivocated.
+        newVotes' = Set.fromList $ nubBy isEquivocatedVote newVotes
+        newChains' = Set.fromList $ nubBy isEquivocatedChain $ filter (not . flip any (Set.toList chains) . isEquivocatedChain) newChains
 
     -- 2. Add any new chains in Cnew to C, add any new certificates contained in chains in Cnew to Certs.
     let chains' = chains `Set.union` newChains'

peras-simulation/src/Peras/Prototype/Node.hs

@@ -4,7 +4,7 @@
 
 module Peras.Prototype.Node where
 
-import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
+import Control.Concurrent.Class.MonadSTM (MonadSTM (..), readTVarIO)
 import Control.Monad.Except (ExceptT (ExceptT), runExceptT)
 import Control.Monad.State (StateT, gets, lift, modify')
 import Control.Tracer (Tracer, nullTracer, traceWith)
@@ -88,3 +88,5 @@ tickNode tracer diffuser params party state s _ payload newChains newVotes =
       voting tracer params party state s (selectBlock tracer) (diffuseVote diffuser)
     -- 4. Invoke block creation if leader.
     ExceptT $ blockCreation tracer params party state s payload (diffuseChain diffuser)
+    -- Record the new state.
+    ExceptT $ fmap pure . traceWith tracer . Snapshot =<< readTVarIO state

peras-simulation/src/Peras/Prototype/Trace.hs

@@ -15,7 +15,7 @@ import Peras.Chain (Chain, Vote (..))
 import Peras.Crypto (Hash)
 import Peras.Numbering (RoundNumber, SlotNumber)
 import Peras.Orphans ()
-import Peras.Prototype.Types (PerasParams, VotingWeight)
+import Peras.Prototype.Types (PerasParams, PerasState, VotingWeight)
 
 data PerasLog
   = Protocol {parameters :: PerasParams}
@@ -33,6 +33,7 @@ data PerasLog
   | VotingLogic {partyId :: PartyId, vr1a :: Bool, vr1b :: Bool, vr2a :: Bool, vr2b :: Bool}
   | DiffuseChain {partyId :: PartyId, chain :: Chain}
   | DiffuseVote {partyId :: PartyId, vote :: Vote}
+  | Snapshot {state :: PerasState}
   deriving stock (Show, Eq, Generic)
 
 data VoteLog = MkVoteLog