Skip to content

Commit f28b409

Browse files
amesgenamesgen
committed
ChainOrder: test laws
1 parent c4d0c4e commit f28b409

File tree

6 files changed

+205
-0
lines changed

6 files changed

+205
-0
lines changed

‎ouroboros-consensus-protocol/ouroboros-consensus-protocol.cabal‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,12 @@ common common-lib
4343
if flag(asserts)
4444
ghc-options: -fno-ignore-asserts
4545

46+
common common-test
47+
import: common-lib
48+
ghc-options:
49+
-threaded
50+
-rtsopts
51+
4652
library
4753
import: common-lib
4854
hs-source-dirs: src/ouroboros-consensus-protocol
@@ -90,3 +96,24 @@ library unstable-protocol-testlib
9096
cardano-protocol-tpraos,
9197
cardano-slotting,
9298
ouroboros-consensus-protocol,
99+
100+
test-suite protocol-test
101+
import: common-test
102+
type: exitcode-stdio-1.0
103+
hs-source-dirs: test/protocol-test
104+
main-is: Main.hs
105+
other-modules:
106+
Test.Consensus.Protocol.Praos.SelectView
107+
108+
build-depends:
109+
QuickCheck,
110+
base,
111+
cardano-crypto-class,
112+
cardano-ledger-binary:testlib,
113+
cardano-ledger-core,
114+
containers,
115+
ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib},
116+
ouroboros-consensus-protocol,
117+
serialise,
118+
tasty,
119+
tasty-quickcheck,

‎ouroboros-consensus-protocol/test/protocol-test/Main.hs‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
module Main (main) where
2+
3+
import qualified Test.Consensus.Protocol.Praos.SelectView
4+
import Test.Tasty
5+
import Test.Util.TestEnv
6+
7+
main :: IO ()
8+
main = defaultMainWithTestEnv defaultTestEnvConfig tests
9+
10+
tests :: TestTree
11+
tests =
12+
testGroup "protocol"
13+
[ Test.Consensus.Protocol.Praos.SelectView.tests
14+
]

‎ouroboros-consensus-protocol/test/protocol-test/Test/Consensus/Protocol/Praos/SelectView.hs‎

Lines changed: 91 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,91 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE LambdaCase #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
{-# LANGUAGE TypeApplications #-}
7+
8+
{-# OPTIONS_GHC -Wno-orphans #-}
9+
10+
module Test.Consensus.Protocol.Praos.SelectView (tests) where
11+
12+
import qualified Cardano.Crypto.Hash as Crypto
13+
import qualified Cardano.Crypto.Util as Crypto
14+
import Cardano.Crypto.VRF (OutputVRF, mkTestOutputVRF)
15+
import Cardano.Ledger.Crypto (Crypto (..), StandardCrypto)
16+
import qualified Cardano.Ledger.Keys as SL
17+
import Codec.Serialise (encode)
18+
import Control.Monad
19+
import Data.Containers.ListUtils (nubOrdOn)
20+
import Ouroboros.Consensus.Block
21+
import Ouroboros.Consensus.Protocol.Praos.Common
22+
import Test.Cardano.Ledger.Binary.Arbitrary ()
23+
import Test.Ouroboros.Consensus.Protocol
24+
import Test.QuickCheck.Gen (Gen (..))
25+
import Test.QuickCheck.Random (mkQCGen)
26+
import Test.Tasty
27+
import Test.Tasty.QuickCheck hiding (elements)
28+
import Test.Util.QuickCheck
29+
import Test.Util.TestEnv
30+
31+
tests :: TestTree
32+
tests = testGroup "PraosChainSelectView"
33+
[ adjustQuickCheckTests (* 50)
34+
-- Use a small max size by default in order to have a decent chance to
35+
-- trigger the actual tiebreaker cases.
36+
$ adjustQuickCheckMaxSize (`div` 10)
37+
$ tests_chainOrder (Proxy @(PraosChainSelectView StandardCrypto))
38+
]
39+
40+
instance Crypto c => Arbitrary (PraosChainSelectView c) where
41+
arbitrary = do
42+
size <- fromIntegral <$> getSize
43+
csvChainLength <- BlockNo <$> choose (1, size)
44+
csvSlotNo <- SlotNo <$> choose (1, size)
45+
csvIssuer <- elements knownIssuers
46+
csvIssueNo <- genIssueNo
47+
pure PraosChainSelectView {
48+
csvChainLength
49+
, csvSlotNo
50+
, csvIssuer
51+
, csvIssueNo
52+
, csvTieBreakVRF = mkVRFFor csvIssuer csvSlotNo
53+
}
54+
where
55+
-- We want to draw from the same small set of issuer identities in order to
56+
-- have a chance to explore cases where the issuers of two 'SelectView's
57+
-- are identical.
58+
knownIssuers :: [SL.VKey SL.BlockIssuer c]
59+
knownIssuers =
60+
nubOrdOn SL.hashKey
61+
$ unGen (replicateM numIssuers (SL.VKey <$> arbitrary)) randomSeed 100
62+
where
63+
randomSeed = mkQCGen 4 -- chosen by fair dice roll
64+
numIssuers = 10
65+
66+
-- TODO Actually randomize this once the issue number tiebreaker has been
67+
-- fixed to be transitive. See the document in
68+
-- https://github.com/IntersectMBO/ouroboros-consensus/pull/891 for
69+
-- details.
70+
--
71+
-- TL;DR: In an edge case, the issue number tiebreaker prevents the
72+
-- chain order from being transitive. This could be fixed relatively
73+
-- easily, namely by swapping the issue number tiebreaker and the VRF
74+
-- tiebreaker. However, this is technically not backwards-compatible,
75+
-- impacting the current pre-Conway diffusion pipelining scheme.
76+
--
77+
-- See https://github.com/IntersectMBO/ouroboros-consensus/issues/1075.
78+
genIssueNo = pure 1
79+
80+
-- The header VRF is a deterministic function of the issuer VRF key, the
81+
-- slot and the epoch nonce. Additionally, for any particular chain, the
82+
-- slot determines the epoch nonce.
83+
mkVRFFor :: SL.VKey SL.BlockIssuer c -> SlotNo -> OutputVRF (VRF c)
84+
mkVRFFor issuer slot =
85+
mkTestOutputVRF
86+
$ Crypto.bytesToNatural
87+
$ Crypto.hashToBytes
88+
$ Crypto.xor (Crypto.castHash issuerHash)
89+
$ Crypto.hashWithSerialiser encode slot
90+
where
91+
SL.KeyHash issuerHash = SL.hashKey issuer

‎ouroboros-consensus/ouroboros-consensus.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -331,6 +331,7 @@ library unstable-consensus-testlib
331331
Test.Ouroboros.Consensus.ChainGenerator.Slot
332332
Test.Ouroboros.Consensus.ChainGenerator.Some
333333
Test.Ouroboros.Consensus.DiffusionPipelining
334+
Test.Ouroboros.Consensus.Protocol
334335
Test.QuickCheck.Extras
335336
Test.Util.BoolProps
336337
Test.Util.ChainDB

‎ouroboros-consensus/src/unstable-consensus-testlib/Test/Ouroboros/Consensus/Protocol.hs‎

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
{-# LANGUAGE TypeApplications #-}
4+
5+
module Test.Ouroboros.Consensus.Protocol (tests_chainOrder) where
6+
7+
import Data.Proxy
8+
import Data.Typeable (Typeable, typeRep)
9+
import Ouroboros.Consensus.Protocol.Abstract
10+
import Test.Tasty
11+
import Test.Tasty.QuickCheck
12+
import Test.Util.QuickCheck
13+
14+
-- | Test the laws of the 'ChainOrder' class (in particular, that 'Ord' is
15+
-- lawful) /except/ for the high-level "Chain extension precedence" property.
16+
tests_chainOrder ::
17+
forall a.
18+
( ChainOrder a
19+
, Typeable a
20+
, Arbitrary a
21+
, Show a
22+
, Arbitrary (ChainOrderConfig a)
23+
, Show (ChainOrderConfig a)
24+
)
25+
=> Proxy a
26+
-> TestTree
27+
tests_chainOrder aPrx = testGroup ("ChainOrder " <> show (typeRep aPrx))
28+
[ testProperty "Eq & Ord" (prop_lawfulEqAndTotalOrd @a)
29+
, testProperty "Consistency with Ord" $ \cfg (a :: a) b ->
30+
preferCandidate cfg a b ==> a `lt` b
31+
]

‎ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs‎

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,8 @@ module Test.Util.QuickCheck (
2929
, collects
3030
, forAllGenRunShrinkCheck
3131
, implies
32+
-- * Typeclass laws
33+
, prop_lawfulEqAndTotalOrd
3234
) where
3335

3436
import Control.Monad.Except
@@ -226,3 +228,42 @@ collects = repeatedly collect
226228
implies :: Testable prop => Bool -> prop -> Property
227229
implies p1 p2 = not p1 .||. p2
228230
infixr 0 `implies`
231+
232+
{-------------------------------------------------------------------------------
233+
Typeclass laws
234+
-------------------------------------------------------------------------------}
235+
236+
prop_lawfulEqAndTotalOrd ::
237+
forall a. (Show a, Ord a)
238+
=> a -> a -> a -> Property
239+
prop_lawfulEqAndTotalOrd a b c = conjoin
240+
[ counterexample "Not total: a <= b || b <= a VIOLATED" $
241+
a <= b || b <= a
242+
, counterexample "Not transitive: a <= b && b <= c => a <= c VIOLATED" $
243+
let antecedent = a <= b && b <= c in
244+
classify antecedent "Antecedent for transitivity" $
245+
antecedent `implies` a <= c
246+
, counterexample "Not reflexive: a <= a VIOLATED" $
247+
a `le` a
248+
, counterexample "Not antisymmetric: a <= b && b <= a => a == b VIOLATED" $
249+
let antecedent = a <= b && b <= a in
250+
classify antecedent "Antecedent for antisymmetry" $
251+
antecedent `implies` a == b
252+
, -- compatibility laws
253+
counterexample "(a <= b) == (b >= a) VIOLATED" $
254+
(a <= b) === (b >= a)
255+
, counterexample "(a < b) == (a <= b && a /= b) VIOLATED" $
256+
(a < b) === (a <= b && a /= b)
257+
, counterexample "(a > b) = (b < a) VIOLATED" $
258+
(a > b) === (b < a)
259+
, counterexample "(a < b) == (compare a b == LT) VIOLATED" $
260+
(a < b) === (compare a b == LT)
261+
, counterexample "(a > b) == (compare a b == GT) VIOLATED" $
262+
(a > b) === (compare a b == GT)
263+
, counterexample "(a == b) == (compare a b == EQ) VIOLATED" $
264+
(a == b) === (compare a b == EQ)
265+
, counterexample "min a b == if a <= b then a else b VIOLATED" $
266+
min a b === if a <= b then a else b
267+
, counterexample "max a b == if a >= b then a else b VIOLATED" $
268+
max a b === if a >= b then a else b
269+
]

0 commit comments

Comments
 (0)