{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Ledger.Dijkstra.Imp.LeiosCertSpec (spec) where

import Cardano.Crypto.DSIGN
import Cardano.Crypto.Hash.Class
import Cardano.Crypto.Leios
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Block
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Dijkstra.BlockBody
import Cardano.Ledger.Dijkstra.PParams
import Cardano.Ledger.Dijkstra.Rules
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.State
import Data.List.NonEmpty (NonEmpty)
import Lens.Micro
import Test.Cardano.Ledger.BlockHeader
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  DijkstraEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp era =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"LEIOSCERT" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Certifies the EB announced by the preceding block" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    signKeys <- Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
forall era.
(HasCallStack, DijkstraEraImp era) =>
Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
setupLeiosCommittee Int
4
    announcingBlock <- announceEb
    cert <- mkLeiosCert (take 3 signKeys) $ announcingBlock ^. blockHeaderHashBlockHeaderG
    replicateM_ 14 passTick
    certifyInBlock cert

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LeiosCertTooEarly" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    signKeys <- Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
forall era.
(HasCallStack, DijkstraEraImp era) =>
Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
setupLeiosCommittee Int
4
    announcingBlock <- announceEb
    cert <- mkLeiosCert (take 3 signKeys) $ announcingBlock ^. blockHeaderHashBlockHeaderG
    let announcementSlot = Block TestBlockHeader era
announcingBlock Block TestBlockHeader era
-> Getting SlotNo (Block TestBlockHeader era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (Block TestBlockHeader era) SlotNo
forall h era. EraBlockHeader h era => Lens' (Block h era) SlotNo
Lens' (Block TestBlockHeader era) SlotNo
slotNoBlockHeaderL
    replicateM_ 13 passTick
    certifyInFailingBlock
      cert
      [injectFailure $ LeiosCertTooEarly (Mismatch (announcementSlot + 13) (announcementSlot + 14))]
    passTick
    certifyInBlock cert

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Rounds the certification delay up to whole slots" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    signKeys <- Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
forall era.
(HasCallStack, DijkstraEraImp era) =>
Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
setupLeiosCommittee Int
4
    modifyPParams $ ppLeiosDiffusionPeriodLengthL .~ Milliseconds32 7_001
    announcingBlock <- announceEb
    cert <- mkLeiosCert (take 3 signKeys) $ announcingBlock ^. blockHeaderHashBlockHeaderG
    let announcementSlot = Block TestBlockHeader era
announcingBlock Block TestBlockHeader era
-> Getting SlotNo (Block TestBlockHeader era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (Block TestBlockHeader era) SlotNo
forall h era. EraBlockHeader h era => Lens' (Block h era) SlotNo
Lens' (Block TestBlockHeader era) SlotNo
slotNoBlockHeaderL
    replicateM_ 14 passTick
    certifyInFailingBlock
      cert
      [injectFailure $ LeiosCertTooEarly (Mismatch (announcementSlot + 14) (announcementSlot + 15))]
    passTick
    certifyInBlock cert

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LeiosCertAnnouncedInPreviousEpoch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    signKeys <- Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
forall era.
(HasCallStack, DijkstraEraImp era) =>
Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
setupLeiosCommittee Int
4
    announcingBlock <- announceEb
    cert <- mkLeiosCert (take 3 signKeys) $ announcingBlock ^. blockHeaderHashBlockHeaderG
    announcementEpoch <- getsNES nesELL
    passEpoch
    currentEpoch <- getsNES nesELL
    certifyInFailingBlock
      cert
      [injectFailure $ LeiosCertAnnouncedInPreviousEpoch (Mismatch currentEpoch announcementEpoch)]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LeiosCertInsufficientWeight" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    signKeys <- Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
forall era.
(HasCallStack, DijkstraEraImp era) =>
Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
setupLeiosCommittee Int
4
    announcingBlock <- announceEb
    cert <- mkLeiosCert (take 2 signKeys) $ announcingBlock ^. blockHeaderHashBlockHeaderG
    replicateM_ 14 passTick
    certifyInFailingBlock
      cert
      [injectFailure $ LeiosCertInsufficientWeight (Mismatch (1 / 2) (3 / 4))]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LeiosCertInvalidSignature" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    signKeys <- Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
forall era.
(HasCallStack, DijkstraEraImp era) =>
Int -> ImpTestM era [SignKeyDSIGN LeiosDSIGN]
setupLeiosCommittee Int
4
    _ <- announceEb
    otherHeaderHash <- arbitrary
    cert <- mkLeiosCert (take 3 signKeys) otherHeaderHash
    replicateM_ 14 passTick
    certifyInFailingBlock cert [injectFailure LeiosCertInvalidSignature]

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"LeiosCertSignersWithoutKey" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- a pool that registers no BLS key is seated without one
    _ <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
    passNEpochs 2
    announcingBlock <- announceEb
    committee <- getsNES $ nesEsL . esSnapshotsL . ssStakeSetL . ssLeiosCommitteeL
    signKey <- arbitrary
    let msg = Hash HASH EraIndependentBlockHeader -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (Hash HASH EraIndependentBlockHeader -> ByteString)
-> (SafeHash EraIndependentBlockHeader
    -> Hash HASH EraIndependentBlockHeader)
-> SafeHash EraIndependentBlockHeader
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeHash EraIndependentBlockHeader
-> Hash HASH EraIndependentBlockHeader
forall i. SafeHash i -> Hash HASH i
extractHash (SafeHash EraIndependentBlockHeader -> ByteString)
-> SafeHash EraIndependentBlockHeader -> ByteString
forall a b. (a -> b) -> a -> b
$ Block TestBlockHeader era
announcingBlock Block TestBlockHeader era
-> Getting
     (SafeHash EraIndependentBlockHeader)
     (Block TestBlockHeader era)
     (SafeHash EraIndependentBlockHeader)
-> SafeHash EraIndependentBlockHeader
forall s a. s -> Getting a s a -> a
^. Getting
  (SafeHash EraIndependentBlockHeader)
  (Block TestBlockHeader era)
  (SafeHash EraIndependentBlockHeader)
SimpleGetter
  (Block TestBlockHeader era) (SafeHash EraIndependentBlockHeader)
forall h era.
EraBlockHeader h era =>
SimpleGetter (Block h era) (SafeHash EraIndependentBlockHeader)
blockHeaderHashBlockHeaderG
    cert <-
      expectRightDeep $
        aggregateLeiosCert committee [(LeiosSeatId 0, signDSIGN leiosSignContext msg signKey)]
    replicateM_ 14 passTick
    certifyInFailingBlock cert [injectFailure $ LeiosCertSignersWithoutKey [0]]

announceEb :: DijkstraEraImp era => ImpTestM era (Block TestBlockHeader era)
announceEb :: forall era.
DijkstraEraImp era =>
ImpTestM era (Block TestBlockHeader era)
announceEb = do
  ebRefsAnn <- ImpM (LedgerSpec era) EbReferencesAnnouncement
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  withTxsInModifiedBlock (ebReferencesAnnouncementBlockHeaderL .~ SJust ebRefsAnn) (pure ())

certifyInBlock :: DijkstraEraImp era => LeiosCert -> ImpTestM era ()
certifyInBlock :: forall era. DijkstraEraImp era => LeiosCert -> ImpTestM era ()
certifyInBlock LeiosCert
cert = do
  protVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  void $
    withTxsInModifiedBlock (modifyBlockBody protVer $ leiosCertBlockBodyL .~ SJust cert) (pure ())

certifyInFailingBlock ::
  DijkstraEraImp era =>
  LeiosCert ->
  NonEmpty (PredicateFailure (EraRule "BBODY" era)) ->
  ImpTestM era ()
certifyInFailingBlock :: forall era.
DijkstraEraImp era =>
LeiosCert
-> NonEmpty (PredicateFailure (EraRule "BBODY" era))
-> ImpTestM era ()
certifyInFailingBlock LeiosCert
cert NonEmpty (PredicateFailure (EraRule "BBODY" era))
expectedFailures = do
  protVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
  withTxsInModifiedFailingBlockM
    (modifyBlockBody protVer $ leiosCertBlockBodyL .~ SJust cert)
    (pure ())
    (\Block TestBlockHeader era
_ -> NonEmpty (EraRuleFailure "BBODY" era)
-> ImpM (LedgerSpec era) (NonEmpty (EraRuleFailure "BBODY" era))
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty (PredicateFailure (EraRule "BBODY" era))
NonEmpty (EraRuleFailure "BBODY" era)
expectedFailures)