{-# LANGUAGE TypeApplications #-}

-- | Tests of which votes the node's 'VoteState' keeps.
module Test.Consensus.Leios.VoteState (tests) where

import Cardano.Crypto.Hash (Hash (UnsafeHash))
import Cardano.Ledger.State (emptyLeiosCommittee)
import Control.Monad (forM)
import Control.Monad.IOSim (runSimOrThrow)
import Control.Tracer (nullTracer)
import qualified Data.ByteString.Short as SBS
import Data.List (scanl')
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Data.Time.Clock (NominalDiffTime)
import Ouroboros.Consensus.Block (SlotNo (..))
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..), addRelTime)
import Ouroboros.Consensus.Leios.AnnounceState (newAnnounceState)
import Ouroboros.Consensus.Leios.NotifyLog (newNotifyLog)
import Ouroboros.Consensus.Leios.Types (LeiosVote (..), RankingBlockHash (..))
import Ouroboros.Consensus.Leios.VoteState
  ( currentVotes
  , newVoteState
  , pruneVotes
  , recordVote
  )
import Ouroboros.Consensus.MiniProtocol.LeiosNotify.Client.State
  ( AcceptedVote (..)
  , VoteWindow (..)
  )
import Ouroboros.Consensus.Util.IOLike (atomically)
import Test.Consensus.Leios.LeiosNotify.Codec (signedVote)
import Test.Consensus.Leios.TestBlock (LeiosTestBlock)
import Test.QuickCheck
  ( Gen
  , Property
  , choose
  , conjoin
  , counterexample
  , elements
  , forAll
  , listOf
  , (===)
  )
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Test.Util.Orphans.IOLike ()

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"VoteState"
    [ TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty
        TestName
"the node keeps the first vote of each seat in every election still worth relaying"
        Property
prop_keepsUnexpired
    ]

-- | Pruning when each vote arrives, then recording it, keeps the first vote of
-- each seat in exactly the elections whose deadline had not passed at the last
-- pruning, and never records a vote of one seat in one election twice, even
-- once it pruned the election, so the node never relays it twice either.
prop_keepsUnexpired :: Property
prop_keepsUnexpired :: Property
prop_keepsUnexpired = Gen [(RelativeTime, SlotNo, LeiosVote)]
-> ([(RelativeTime, SlotNo, LeiosVote)] -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen [(RelativeTime, SlotNo, LeiosVote)]
genVotes (([(RelativeTime, SlotNo, LeiosVote)] -> Property) -> Property)
-> ([(RelativeTime, SlotNo, LeiosVote)] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \[(RelativeTime, SlotNo, LeiosVote)]
vs ->
  let (Map SlotNo (Map LeiosSeatId LeiosVote)
kept, [(RelativeTime, SlotNo, LeiosSeatId)]
recorded) = (forall s.
 IOSim
   s
   (Map SlotNo (Map LeiosSeatId LeiosVote),
    [(RelativeTime, SlotNo, LeiosSeatId)]))
-> (Map SlotNo (Map LeiosSeatId LeiosVote),
    [(RelativeTime, SlotNo, LeiosSeatId)])
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s.
  IOSim
    s
    (Map SlotNo (Map LeiosSeatId LeiosVote),
     [(RelativeTime, SlotNo, LeiosSeatId)]))
 -> (Map SlotNo (Map LeiosSeatId LeiosVote),
     [(RelativeTime, SlotNo, LeiosSeatId)]))
-> (forall s.
    IOSim
      s
      (Map SlotNo (Map LeiosSeatId LeiosVote),
       [(RelativeTime, SlotNo, LeiosSeatId)]))
-> (Map SlotNo (Map LeiosSeatId LeiosVote),
    [(RelativeTime, SlotNo, LeiosSeatId)])
forall a b. (a -> b) -> a -> b
$ do
        notifyLog <- forall (m :: * -> *) blk.
(IOLike m, NoThunks (Header blk)) =>
m (NotifyLog m blk)
newNotifyLog @_ @LeiosTestBlock
        announceState <- newAnnounceState notifyLog
        st <- newVoteState nullTracer announceState notifyLog
        recorded' <- fmap catMaybes $ forM vs $ \(RelativeTime
at, SlotNo
slot, LeiosVote
vote) -> STM (IOSim s) (Maybe (RelativeTime, SlotNo, LeiosSeatId))
-> IOSim s (Maybe (RelativeTime, SlotNo, LeiosSeatId))
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) (Maybe (RelativeTime, SlotNo, LeiosSeatId))
 -> IOSim s (Maybe (RelativeTime, SlotNo, LeiosSeatId)))
-> STM (IOSim s) (Maybe (RelativeTime, SlotNo, LeiosSeatId))
-> IOSim s (Maybe (RelativeTime, SlotNo, LeiosSeatId))
forall a b. (a -> b) -> a -> b
$ do
          VoteState (IOSim s) LeiosTestBlock
-> RelativeTime -> STM (IOSim s) ()
forall (m :: * -> *) blk.
IOLike m =>
VoteState m blk -> RelativeTime -> STM m ()
pruneVotes VoteState (IOSim s) LeiosTestBlock
st RelativeTime
at
          (AddVoteResult -> Maybe (RelativeTime, SlotNo, LeiosSeatId))
-> (() -> Maybe (RelativeTime, SlotNo, LeiosSeatId))
-> Either AddVoteResult ()
-> Maybe (RelativeTime, SlotNo, LeiosSeatId)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (RelativeTime, SlotNo, LeiosSeatId)
-> AddVoteResult -> Maybe (RelativeTime, SlotNo, LeiosSeatId)
forall a b. a -> b -> a
const Maybe (RelativeTime, SlotNo, LeiosSeatId)
forall a. Maybe a
Nothing) (Maybe (RelativeTime, SlotNo, LeiosSeatId)
-> () -> Maybe (RelativeTime, SlotNo, LeiosSeatId)
forall a b. a -> b -> a
const ((RelativeTime, SlotNo, LeiosSeatId)
-> Maybe (RelativeTime, SlotNo, LeiosSeatId)
forall a. a -> Maybe a
Just (RelativeTime
at, SlotNo
slot, LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
vote)))
            (Either AddVoteResult ()
 -> Maybe (RelativeTime, SlotNo, LeiosSeatId))
-> STM s (Either AddVoteResult ())
-> STM s (Maybe (RelativeTime, SlotNo, LeiosSeatId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VoteState (IOSim s) LeiosTestBlock
-> AcceptedVote -> STM (IOSim s) (Either AddVoteResult ())
forall (m :: * -> *) blk.
IOLike m =>
VoteState m blk -> AcceptedVote -> STM m (Either AddVoteResult ())
recordVote VoteState (IOSim s) LeiosTestBlock
st (SlotNo -> LeiosVote -> AcceptedVote
accepted SlotNo
slot LeiosVote
vote)
        kept' <- atomically (currentVotes st)
        pure (kept', recorded')
      lastPruned :: RelativeTime
lastPruned = [RelativeTime] -> RelativeTime
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (NominalDiffTime -> RelativeTime
RelativeTime NominalDiffTime
0 RelativeTime -> [RelativeTime] -> [RelativeTime]
forall a. a -> [a] -> [a]
: [RelativeTime
at | (RelativeTime
at, SlotNo
_, LeiosVote
_) <- [(RelativeTime, SlotNo, LeiosVote)]
vs])
      elections :: [(SlotNo, LeiosSeatId)]
elections = [(SlotNo
slot, LeiosSeatId
seat) | (RelativeTime
_, SlotNo
slot, LeiosSeatId
seat) <- [(RelativeTime, SlotNo, LeiosSeatId)]
recorded]
   in [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"kept" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Map SlotNo (Map LeiosSeatId LeiosVote)
kept
              Map SlotNo (Map LeiosSeatId LeiosVote)
-> Map SlotNo (Map LeiosSeatId LeiosVote) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (SlotNo -> Map LeiosSeatId LeiosVote -> Bool)
-> Map SlotNo (Map LeiosSeatId LeiosVote)
-> Map SlotNo (Map LeiosSeatId LeiosVote)
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\SlotNo
slot Map LeiosSeatId LeiosVote
_ -> RelativeTime
lastPruned RelativeTime -> RelativeTime -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> RelativeTime
voteUntilOf SlotNo
slot) ([(RelativeTime, SlotNo, LeiosVote)]
-> Map SlotNo (Map LeiosSeatId LeiosVote)
firstVotes [(RelativeTime, SlotNo, LeiosVote)]
vs)
        , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"recorded twice" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [(SlotNo, LeiosSeatId)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(SlotNo, LeiosSeatId)]
elections Int -> Int -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Set (SlotNo, LeiosSeatId) -> Int
forall a. Set a -> Int
Set.size ([(SlotNo, LeiosSeatId)] -> Set (SlotNo, LeiosSeatId)
forall a. Ord a => [a] -> Set a
Set.fromList [(SlotNo, LeiosSeatId)]
elections)
        ]
 where
  firstVotes :: [(RelativeTime, SlotNo, LeiosVote)]
-> Map SlotNo (Map LeiosSeatId LeiosVote)
firstVotes [(RelativeTime, SlotNo, LeiosVote)]
vs =
    (Map LeiosSeatId LeiosVote
 -> Map LeiosSeatId LeiosVote -> Map LeiosSeatId LeiosVote)
-> [(SlotNo, Map LeiosSeatId LeiosVote)]
-> Map SlotNo (Map LeiosSeatId LeiosVote)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
      ((Map LeiosSeatId LeiosVote
 -> Map LeiosSeatId LeiosVote -> Map LeiosSeatId LeiosVote)
-> Map LeiosSeatId LeiosVote
-> Map LeiosSeatId LeiosVote
-> Map LeiosSeatId LeiosVote
forall a b c. (a -> b -> c) -> b -> a -> c
flip Map LeiosSeatId LeiosVote
-> Map LeiosSeatId LeiosVote -> Map LeiosSeatId LeiosVote
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union)
      [(SlotNo
slot, LeiosSeatId -> LeiosVote -> Map LeiosSeatId LeiosVote
forall k a. k -> a -> Map k a
Map.singleton (LeiosVote -> LeiosSeatId
voteSeatId LeiosVote
v) LeiosVote
v) | (RelativeTime
at, SlotNo
slot, LeiosVote
v) <- [(RelativeTime, SlotNo, LeiosVote)]
vs, RelativeTime
at RelativeTime -> RelativeTime -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> RelativeTime
voteUntilOf SlotNo
slot]

  accepted :: SlotNo -> LeiosVote -> AcceptedVote
accepted SlotNo
slot LeiosVote
vote =
    MkAcceptedVote
      { acceptedVote :: LeiosVote
acceptedVote = LeiosVote
vote
      , voteElectionSlot :: SlotNo
voteElectionSlot = SlotNo
slot
      , voteCommittee :: LeiosCommittee
voteCommittee = LeiosCommittee
emptyLeiosCommittee
      , voteWindow :: VoteWindow
voteWindow = RelativeTime -> RelativeTime -> VoteWindow
MkVoteWindow (SlotNo -> RelativeTime
slotStart SlotNo
slot) (SlotNo -> RelativeTime
voteUntilOf SlotNo
slot)
      }

-- | Votes arriving over time, each for an election slot that began at most two
-- windows earlier, so that some arrive after their window closed.
genVotes :: Gen [(RelativeTime, SlotNo, LeiosVote)]
genVotes :: Gen [(RelativeTime, SlotNo, LeiosVote)]
genVotes = do
  gaps <- Gen Double -> Gen [Double]
forall a. Gen a -> Gen [a]
listOf ((Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0, Double
2 :: Double))
  forM (drop 1 (scanl' (+) 0 gaps)) $ \Double
t -> do
    age <- (Double, Double) -> Gen Double
forall a. Random a => (a, a) -> Gen a
choose (Double
0, Double
2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
window)
    (,,) (RelativeTime (realToFrac t)) (SlotNo (floor (max 0 (t - age))))
      <$> elements someVotes

-- | One-second slots, the first starting at 0.
slotStart :: SlotNo -> RelativeTime
slotStart :: SlotNo -> RelativeTime
slotStart (SlotNo Word64
s) = NominalDiffTime -> RelativeTime
RelativeTime (Word64 -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
s)

-- | Votes are worth relaying for 'window' seconds after their slot began.
voteUntilOf :: SlotNo -> RelativeTime
voteUntilOf :: SlotNo -> RelativeTime
voteUntilOf SlotNo
slot = NominalDiffTime -> RelativeTime -> RelativeTime
addRelTime NominalDiffTime
window (SlotNo -> RelativeTime
slotStart SlotNo
slot)

window :: NominalDiffTime
window :: NominalDiffTime
window = NominalDiffTime
10

-- | Several votes of each of a few seats, so that the first one is told from
-- the others.
someVotes :: [LeiosVote]
someVotes :: [LeiosVote]
someVotes =
  [ RankingBlockHash -> Word16 -> LeiosVote
signedVote (Hash HASH EraIndependentBlockHeader -> RankingBlockHash
MkRankingBlockHash (ShortByteString -> Hash HASH EraIndependentBlockHeader
forall h a.
(HashAlgorithm h, HasCallStack) =>
ShortByteString -> Hash h a
UnsafeHash (Int -> Word8 -> ShortByteString
SBS.replicate Int
32 Word8
tag))) Word16
seat
  | Word8
tag <- [Word8
0 .. Word8
3]
  , Word16
seat <- [Word16
0 .. Word16
3]
  ]