{-# LANGUAGE TypeApplications #-}

-- | 'leiosClaim', and 'verifyLeiosClaim' on certificates made by the test
-- committee.
module Test.Consensus.Leios.Cert (tests) where

import Cardano.Crypto.Leios (VerificationError (..))
import Cardano.Ledger.BaseTypes (Milliseconds32 (..))
import Control.Monad.Except (runExcept)
import Data.Maybe.Strict (StrictMaybe (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Leios.Cert
  ( LeiosCertRejection (..)
  , LeiosClaim (..)
  , leiosClaim
  , verifyLeiosClaim
  )
import Ouroboros.Consensus.Leios.Protocol (LeiosLedgerView (..))
import Ouroboros.Consensus.Leios.Types (RankingBlockHash, toRankingBlockHash)
import Test.Consensus.Leios.Committee
  ( certOf
  , testCommittee
  , testQuorumStakeThreshold
  )
import Test.Consensus.Leios.TestBlock (LeiosTestBlock, firstLeiosBlock)
import Test.Tasty
import Test.Tasty.HUnit

tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Leios certificates"
    [ TestName -> Assertion -> TestTree
testCase TestName
"a block claims its predecessor's announcement" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        ChainHash LeiosTestBlock
-> WithOrigin SlotNo -> Either LeiosCertRejection LeiosClaim
claimOf (HeaderHash LeiosTestBlock -> ChainHash LeiosTestBlock
forall {k} (b :: k). HeaderHash b -> ChainHash b
BlockHash HeaderHash LeiosTestBlock
TestHash
announcing) (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
announcingSlot)
          Either LeiosCertRejection LeiosClaim
-> Either LeiosCertRejection LeiosClaim -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosClaim -> Either LeiosCertRejection LeiosClaim
forall a b. b -> Either a b
Right LeiosClaim
claim
    , TestName -> Assertion -> TestTree
testCase TestName
"a block whose predecessor is genesis claims nothing" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        ChainHash LeiosTestBlock
-> WithOrigin SlotNo -> Either LeiosCertRejection LeiosClaim
claimOf ChainHash LeiosTestBlock
forall {k} (b :: k). ChainHash b
GenesisHash WithOrigin SlotNo
forall t. WithOrigin t
Origin
          Either LeiosCertRejection LeiosClaim
-> Either LeiosCertRejection LeiosClaim -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosCertRejection -> Either LeiosCertRejection LeiosClaim
forall a b. a -> Either a b
Left LeiosCertRejection
LeiosCertAtGenesis
    , TestName -> Assertion -> TestTree
testCase TestName
"the certificate a quorum makes of the predecessor is valid" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        StrictMaybe LeiosLedgerView
-> LeiosCert -> LeiosClaim -> Either LeiosCertRejection ()
verify (LeiosLedgerView -> StrictMaybe LeiosLedgerView
forall a. a -> StrictMaybe a
SJust LeiosLedgerView
view) (RankingBlockHash -> [Word16] -> LeiosCert
certOf (HeaderHash LeiosTestBlock -> RankingBlockHash
rbHashOf HeaderHash LeiosTestBlock
TestHash
announcing) [Word16
0, Word16
1, Word16
2]) LeiosClaim
claim
          Either LeiosCertRejection ()
-> Either LeiosCertRejection () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= () -> Either LeiosCertRejection ()
forall a b. b -> Either a b
Right ()
    , TestName -> Assertion -> TestTree
testCase TestName
"a certificate of a block other than the predecessor is invalid" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        StrictMaybe LeiosLedgerView
-> LeiosCert -> LeiosClaim -> Either LeiosCertRejection ()
verify (LeiosLedgerView -> StrictMaybe LeiosLedgerView
forall a. a -> StrictMaybe a
SJust LeiosLedgerView
view) (RankingBlockHash -> [Word16] -> LeiosCert
certOf (HeaderHash LeiosTestBlock -> RankingBlockHash
rbHashOf HeaderHash LeiosTestBlock
TestHash
other) [Word16
0, Word16
1, Word16
2]) LeiosClaim
claim
          Either LeiosCertRejection ()
-> Either LeiosCertRejection () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosCertRejection -> Either LeiosCertRejection ()
forall a b. a -> Either a b
Left (VerificationError -> LeiosCertRejection
LeiosCertInvalid VerificationError
InvalidSignature)
    , TestName -> Assertion -> TestTree
testCase TestName
"the certificate a minority makes is invalid" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        StrictMaybe LeiosLedgerView
-> LeiosCert -> LeiosClaim -> Either LeiosCertRejection ()
verify (LeiosLedgerView -> StrictMaybe LeiosLedgerView
forall a. a -> StrictMaybe a
SJust LeiosLedgerView
view) (RankingBlockHash -> [Word16] -> LeiosCert
certOf (HeaderHash LeiosTestBlock -> RankingBlockHash
rbHashOf HeaderHash LeiosTestBlock
TestHash
announcing) [Word16
0]) LeiosClaim
claim
          Either LeiosCertRejection ()
-> Either LeiosCertRejection () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosCertRejection -> Either LeiosCertRejection ()
forall a b. a -> Either a b
Left (VerificationError -> LeiosCertRejection
LeiosCertInvalid (Ratio Integer -> VerificationError
InsufficientWeight (Ratio Integer
1 Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Fractional a => a -> a -> a
/ Ratio Integer
4)))
    , TestName -> Assertion -> TestTree
testCase TestName
"a certificate without a committee is invalid" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$
        StrictMaybe LeiosLedgerView
-> LeiosCert -> LeiosClaim -> Either LeiosCertRejection ()
verify StrictMaybe LeiosLedgerView
forall a. StrictMaybe a
SNothing (RankingBlockHash -> [Word16] -> LeiosCert
certOf (HeaderHash LeiosTestBlock -> RankingBlockHash
rbHashOf HeaderHash LeiosTestBlock
TestHash
announcing) [Word16
0, Word16
1, Word16
2]) LeiosClaim
claim
          Either LeiosCertRejection ()
-> Either LeiosCertRejection () -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= LeiosCertRejection -> Either LeiosCertRejection ()
forall a b. a -> Either a b
Left LeiosCertRejection
LeiosCertWithoutCommittee
    ]
 where
  claimOf :: ChainHash LeiosTestBlock
-> WithOrigin SlotNo -> Either LeiosCertRejection LeiosClaim
claimOf ChainHash LeiosTestBlock
prevHash WithOrigin SlotNo
predecessorSlot =
    Except LeiosCertRejection LeiosClaim
-> Either LeiosCertRejection LeiosClaim
forall e a. Except e a -> Either e a
runExcept (Except LeiosCertRejection LeiosClaim
 -> Either LeiosCertRejection LeiosClaim)
-> Except LeiosCertRejection LeiosClaim
-> Either LeiosCertRejection LeiosClaim
forall a b. (a -> b) -> a -> b
$ forall blk.
ConvertRawHash blk =>
ChainHash blk
-> WithOrigin SlotNo -> Except LeiosCertRejection LeiosClaim
leiosClaim @LeiosTestBlock ChainHash LeiosTestBlock
prevHash WithOrigin SlotNo
predecessorSlot
  verify :: StrictMaybe LeiosLedgerView
-> LeiosCert -> LeiosClaim -> Either LeiosCertRejection ()
verify StrictMaybe LeiosLedgerView
mbView LeiosCert
cert LeiosClaim
claim' = Except LeiosCertRejection () -> Either LeiosCertRejection ()
forall e a. Except e a -> Either e a
runExcept (Except LeiosCertRejection () -> Either LeiosCertRejection ())
-> Except LeiosCertRejection () -> Either LeiosCertRejection ()
forall a b. (a -> b) -> a -> b
$ StrictMaybe LeiosLedgerView
-> LeiosCert -> LeiosClaim -> Except LeiosCertRejection ()
verifyLeiosClaim StrictMaybe LeiosLedgerView
mbView LeiosCert
cert LeiosClaim
claim'

  claim :: LeiosClaim
claim = SlotNo -> RankingBlockHash -> LeiosClaim
LeiosClaim SlotNo
announcingSlot (HeaderHash LeiosTestBlock -> RankingBlockHash
rbHashOf HeaderHash LeiosTestBlock
TestHash
announcing)

  announcingSlot :: SlotNo
announcingSlot = LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot (Word64 -> LeiosTestBlock
firstLeiosBlock Word64
0)
  announcing :: HeaderHash LeiosTestBlock
announcing = LeiosTestBlock -> HeaderHash LeiosTestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash (Word64 -> LeiosTestBlock
firstLeiosBlock Word64
0)
  other :: HeaderHash LeiosTestBlock
other = LeiosTestBlock -> HeaderHash LeiosTestBlock
forall b. HasHeader b => b -> HeaderHash b
blockHash (Word64 -> LeiosTestBlock
firstLeiosBlock Word64
1)

rbHashOf :: HeaderHash LeiosTestBlock -> RankingBlockHash
rbHashOf :: HeaderHash LeiosTestBlock -> RankingBlockHash
rbHashOf = Proxy LeiosTestBlock
-> HeaderHash LeiosTestBlock -> RankingBlockHash
forall blk.
ConvertRawHash blk =>
Proxy blk -> HeaderHash blk -> RankingBlockHash
toRankingBlockHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @LeiosTestBlock)

view :: LeiosLedgerView
view :: LeiosLedgerView
view =
  MkLeiosLedgerView
    { llvCommittee :: LeiosCommittee
llvCommittee = LeiosCommittee
testCommittee
    , llvQuorumStakeThreshold :: UnitInterval
llvQuorumStakeThreshold = UnitInterval
testQuorumStakeThreshold
    , llvAnnouncementPeriod :: Milliseconds32
llvAnnouncementPeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
1000
    , llvVotePeriod :: Milliseconds32
llvVotePeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
4000
    , llvDiffusionPeriod :: Milliseconds32
llvDiffusionPeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
1000
    , llvMaxEbBodySize :: Word32
llvMaxEbBodySize = Word32
5000
    , llvMaxEbTxsSize :: Word32
llvMaxEbTxsSize = Word32
5000
    }