{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

-- | Test properties for the generic voting committee class helpers
module Test.Consensus.Committee.Class (tests) where

import Data.Containers.NonEmpty (HasNonEmpty (..))
import Data.Function (on)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Proxy (Proxy (..))
import GHC.Word (Word64)
import Ouroboros.Consensus.Committee.Class
  ( UniqueVotesWithSameTargetError (..)
  , checkUniqueVotesWithSameTarget
  )
import Ouroboros.Consensus.Committee.Crypto
  ( ElectionId
  , VoteCandidate
  )
import Test.Consensus.Committee.TestCrypto (TestCrypto)
import qualified Test.Consensus.Committee.TestCrypto as TestCrypto
import Test.Consensus.Committee.Utils (mkBucket)
import Test.QuickCheck
  ( Arbitrary (..)
  , Gen
  , Positive (..)
  , Property
  , Small (..)
  , counterexample
  , forAll
  , tabulate
  , vectorOf
  , (.&&.)
  , (===)
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (Testable (..), testProperty)
import Test.Util.TestEnv (adjustQuickCheckTests)

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"UniqueVotesWithSameTarget properties"
    [ (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty
          String
"prop_checkUniqueVotesWithSameTarget"
          Property
prop_checkUniqueVotesWithSameTarget
    ]

-- * Mock committee implementation for testing

type TestVoterId = Word64

data TestVote
  = TestVote
  { TestVote -> ElectionId TestCrypto
tvElectionId :: ElectionId TestCrypto
  , TestVote -> VoteCandidate TestCrypto
tvCandidate :: VoteCandidate TestCrypto
  , TestVote -> TestVoterId
tvVoterId :: TestVoterId
  }
  deriving (TestVote -> TestVote -> Bool
(TestVote -> TestVote -> Bool)
-> (TestVote -> TestVote -> Bool) -> Eq TestVote
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestVote -> TestVote -> Bool
== :: TestVote -> TestVote -> Bool
$c/= :: TestVote -> TestVote -> Bool
/= :: TestVote -> TestVote -> Bool
Eq, Int -> TestVote -> ShowS
[TestVote] -> ShowS
TestVote -> String
(Int -> TestVote -> ShowS)
-> (TestVote -> String) -> ([TestVote] -> ShowS) -> Show TestVote
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestVote -> ShowS
showsPrec :: Int -> TestVote -> ShowS
$cshow :: TestVote -> String
show :: TestVote -> String
$cshowList :: [TestVote] -> ShowS
showList :: [TestVote] -> ShowS
Show)

-- * Test property

prop_checkUniqueVotesWithSameTarget :: Property
prop_checkUniqueVotesWithSameTarget :: Property
prop_checkUniqueVotesWithSameTarget =
  Gen (NonEmpty TestVote)
-> (NonEmpty TestVote -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen (NonEmpty TestVote)
Gen (NE [TestVote])
genVotes ((NonEmpty TestVote -> Property) -> Property)
-> (NonEmpty TestVote -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \NonEmpty TestVote
votes -> do
    let result :: Either (UniqueVotesWithSameTargetError TestVote) ()
result =
          Proxy TestCrypto
-> (TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto))
-> (TestVote -> TestVote -> Ordering)
-> NE [TestVote]
-> Either (UniqueVotesWithSameTargetError TestVote) ()
forall crypto vote.
(Eq (ElectionId crypto), Eq (VoteCandidate crypto)) =>
Proxy crypto
-> (vote -> (ElectionId crypto, VoteCandidate crypto))
-> (vote -> vote -> Ordering)
-> NE [vote]
-> Either (UniqueVotesWithSameTargetError vote) ()
checkUniqueVotesWithSameTarget
            (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @TestCrypto)
            TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget
            TestVote -> TestVote -> Ordering
cmpVoteId
            NonEmpty TestVote
NE [TestVote]
votes
    String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Outcome" [Either (UniqueVotesWithSameTargetError TestVote) () -> String
showOutcome Either (UniqueVotesWithSameTargetError TestVote) ()
result]
      (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"List length" [Integer -> Integer -> String
mkBucket Integer
10 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NonEmpty TestVote -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty TestVote
votes))]
      (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
        ( [String] -> String
unlines
            [ String
"Unexpected outcome:"
            , String
"Votes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NonEmpty TestVote -> String
forall a. Show a => a -> String
show NonEmpty TestVote
votes
            , String
"Result: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Either (UniqueVotesWithSameTargetError TestVote) () -> String
showOutcome Either (UniqueVotesWithSameTargetError TestVote) ()
result
            ]
        )
      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ case Either (UniqueVotesWithSameTargetError TestVote) ()
result of
        Left (DuplicateVotes NE [TestVote]
duplicateVotes) -> do
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
            ( [String] -> String
unlines
                [ String
"Duplicate votes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NonEmpty TestVote -> String
forall a. Show a => a -> String
show NonEmpty TestVote
NE [TestVote]
duplicateVotes
                ]
            )
            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ (NonEmpty TestVote -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty TestVote
NE [TestVote]
duplicateVotes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
              Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (Bool -> Property
forall prop. Testable prop => prop -> Property
property (NE [TestVote] -> Int
uniqueVoterIdsCount NE [TestVote]
duplicateVotes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1))
        Left (TargetMismatch TestVote
firstVote NE [TestVote]
mismatchingVotes) -> do
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
            ( [String] -> String
unlines
                [ String
"First vote: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestVote -> String
forall a. Show a => a -> String
show TestVote
firstVote
                , String
"Mismatching votes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NonEmpty TestVote -> String
forall a. Show a => a -> String
show NonEmpty TestVote
NE [TestVote]
mismatchingVotes
                ]
            )
            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ (NE [TestVote]
-> Maybe (ElectionId TestCrypto, VoteCandidate TestCrypto)
allSameTarget NonEmpty TestVote
NE [TestVote]
votes Maybe (TestVoterId, ByteString)
-> Maybe (TestVoterId, ByteString) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Maybe (TestVoterId, ByteString)
forall a. Maybe a
Nothing)
              Property -> Bool -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. ((TestVote -> Bool) -> NonEmpty TestVote -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\TestVote
v' -> TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget TestVote
v' (TestVoterId, ByteString) -> (TestVoterId, ByteString) -> Bool
forall a. Eq a => a -> a -> Bool
/= TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget TestVote
firstVote) NonEmpty TestVote
NE [TestVote]
mismatchingVotes)
        Right () -> do
          let firstVote :: TestVote
firstVote = NonEmpty TestVote -> TestVote
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty TestVote
votes
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
            ( [String] -> String
unlines
                [ String
"First votes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NonEmpty TestVote -> String
forall a. Show a => a -> String
show NonEmpty TestVote
votes
                ]
            )
            (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ (NE [TestVote]
-> Maybe (ElectionId TestCrypto, VoteCandidate TestCrypto)
allSameTarget NonEmpty TestVote
NE [TestVote]
votes Maybe (TestVoterId, ByteString)
-> Maybe (TestVoterId, ByteString) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (TestVoterId, ByteString) -> Maybe (TestVoterId, ByteString)
forall a. a -> Maybe a
Just (TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget TestVote
firstVote))
              Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (NE [TestVote] -> Int
uniqueVoterIdsCount NonEmpty TestVote
NE [TestVote]
votes Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== NonEmpty TestVote -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty TestVote
votes)

-- * Generators

-- | Generate a vote list (empty, all same target, or mixed targets)
genVotes :: Gen (NE [TestVote])
genVotes :: Gen (NE [TestVote])
genVotes = do
  numVotes <- Gen Int
genNumVotes
  NonEmpty.fromList <$> vectorOf numVotes genVote
 where
  genNumVotes :: Gen Int
genNumVotes = do
    Small Int -> Int
forall a. Small a -> a
getSmall (Small Int -> Int)
-> (Positive (Small Int) -> Small Int)
-> Positive (Small Int)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive (Small Int) -> Small Int
forall a. Positive a -> a
getPositive
      (Positive (Small Int) -> Int)
-> Gen (Positive (Small Int)) -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary @(Positive (Small Int))

  genVote :: Gen TestVote
genVote = do
    (electionId, candidate) <- Gen (TestVoterId, ByteString)
genTarget
    voterId <- genVoterId
    pure (TestVote electionId candidate voterId)

  genTarget :: Gen (TestVoterId, ByteString)
genTarget = do
    electionId <- Gen TestVoterId
Gen (ElectionId TestCrypto)
TestCrypto.genElectionId
    candidate <- TestCrypto.genVoteCandidate
    pure (electionId, candidate)

  genVoterId :: Gen TestVoterId
genVoterId = do
    Small TestVoterId -> TestVoterId
forall a. Small a -> a
getSmall (Small TestVoterId -> TestVoterId)
-> Gen (Small TestVoterId) -> Gen TestVoterId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary @(Small TestVoterId)

-- * Helpers

-- | Get the target from a vote
getVoteTarget ::
  TestVote ->
  (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget :: TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget = \case
  TestVote ElectionId TestCrypto
electionId VoteCandidate TestCrypto
candidate TestVoterId
_ -> (ElectionId TestCrypto
electionId, VoteCandidate TestCrypto
candidate)

-- | Compare two votes by their ID
cmpVoteId ::
  TestVote ->
  TestVote ->
  Ordering
cmpVoteId :: TestVote -> TestVote -> Ordering
cmpVoteId =
  TestVoterId -> TestVoterId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (TestVoterId -> TestVoterId -> Ordering)
-> (TestVote -> TestVoterId) -> TestVote -> TestVote -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` \case
    TestVote ElectionId TestCrypto
_ VoteCandidate TestCrypto
_ TestVoterId
voteId -> TestVoterId
voteId

-- | Check if all votes in a non-empty list have the same target
allSameTarget ::
  NE [TestVote] ->
  Maybe (ElectionId TestCrypto, VoteCandidate TestCrypto)
allSameTarget :: NE [TestVote]
-> Maybe (ElectionId TestCrypto, VoteCandidate TestCrypto)
allSameTarget (TestVote
v :| [TestVote]
vs)
  | (TestVote -> Bool) -> [TestVote] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\TestVote
v' -> TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget TestVote
v (TestVoterId, ByteString) -> (TestVoterId, ByteString) -> Bool
forall a. Eq a => a -> a -> Bool
== TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget TestVote
v') [TestVote]
vs =
      (TestVoterId, ByteString) -> Maybe (TestVoterId, ByteString)
forall a. a -> Maybe a
Just (TestVote -> (ElectionId TestCrypto, VoteCandidate TestCrypto)
getVoteTarget TestVote
v)
  | Bool
otherwise =
      Maybe (TestVoterId, ByteString)
Maybe (ElectionId TestCrypto, VoteCandidate TestCrypto)
forall a. Maybe a
Nothing

-- | Get the number of unique voter IDs in a non-empty list of votes
uniqueVoterIdsCount ::
  NE [TestVote] ->
  Int
uniqueVoterIdsCount :: NE [TestVote] -> Int
uniqueVoterIdsCount NE [TestVote]
votes =
  NonEmpty TestVote -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((TestVote -> TestVote -> Bool)
-> NonEmpty TestVote -> NonEmpty TestVote
forall a. (a -> a -> Bool) -> NonEmpty a -> NonEmpty a
NonEmpty.nubBy (TestVoterId -> TestVoterId -> Bool
forall a. Eq a => a -> a -> Bool
(==) (TestVoterId -> TestVoterId -> Bool)
-> (TestVote -> TestVoterId) -> TestVote -> TestVote -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TestVote -> TestVoterId
tvVoterId) NonEmpty TestVote
NE [TestVote]
votes)

-- | Show the outcome of ensureSameTarget
showOutcome ::
  Either (UniqueVotesWithSameTargetError TestVote) () ->
  String
showOutcome :: Either (UniqueVotesWithSameTargetError TestVote) () -> String
showOutcome (Left (TargetMismatch TestVote
_ NE [TestVote]
_)) = String
"TargetMismatch"
showOutcome (Left (DuplicateVotes NE [TestVote]
_)) = String
"DuplicateVotes"
showOutcome (Right ()) = String
"Success"