{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications #-}

module Test.Cardano.Ledger.Api.LeiosSpec (spec) where

import Cardano.Crypto.DSIGN (signDSIGN)
import Cardano.Crypto.Hash.Class (hashToBytes)
import Cardano.Crypto.Leios (LeiosSeatId (..), aggregateLeiosCert, leiosSignContext)
import Cardano.Ledger.Api.Era (DijkstraEra)
import Cardano.Ledger.Api.Leios
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Hashes (extractHash)
import Cardano.Ledger.Shelley.LedgerState (nesELL)
import Cardano.Ledger.Slot (epochInfoFirst)
import Cardano.Slotting.EpochInfo (EpochInfo (epochInfoSlotLength_))
import Cardano.Slotting.Time (mkSlotLength)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Lens.Micro.Mtl (use)
import Test.Cardano.Crypto.Leios.Gen (TestSeatType (..), mkCommitteeFromTestSeats)
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common

mkValidLeiosCertWithEnv :: ImpTestM DijkstraEra (LeiosCertEnv, LeiosCert)
mkValidLeiosCertWithEnv :: ImpTestM DijkstraEra (LeiosCertEnv, LeiosCert)
mkValidLeiosCertWithEnv = do
  headerHash <- ImpM (LedgerSpec DijkstraEra) (SafeHash EraIndependentBlockHeader)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  annSlot <- getCurSlotNo
  let (keys, committee) =
        mkCommitteeFromTestSeats $ replicate 3 (WithKey, 1 / 4) <> [(NoKey, 1 / 4)]
      env =
        LeiosCertEnv
          { lseCurrentSlotNo :: SlotNo
lseCurrentSlotNo = SlotNo
annSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
14
          , lseAnnouncementSlotNo :: SlotNo
lseAnnouncementSlotNo = SlotNo
annSlot
          , lseAnnouncedInBlockHeader :: SafeHash EraIndependentBlockHeader
lseAnnouncedInBlockHeader = SafeHash EraIndependentBlockHeader
headerHash
          , lseLeiosCommittee :: LeiosCommittee
lseLeiosCommittee = LeiosCommittee
committee
          , lseThreshold :: UnitInterval
lseThreshold = Integer
3 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
4
          , lseAnnouncementPeriodLength :: Milliseconds32
lseAnnouncementPeriodLength = Word32 -> Milliseconds32
Milliseconds32 Word32
1_000
          , lseVotePeriodLength :: Milliseconds32
lseVotePeriodLength = Word32 -> Milliseconds32
Milliseconds32 Word32
4_000
          , lseDiffusionPeriodLength :: Milliseconds32
lseDiffusionPeriodLength = Word32 -> Milliseconds32
Milliseconds32 Word32
7_000
          }
      msg = Hash HASH EraIndependentBlockHeader -> ByteString
forall h a. Hash h a -> ByteString
hashToBytes (Hash HASH EraIndependentBlockHeader -> ByteString)
-> Hash HASH EraIndependentBlockHeader -> ByteString
forall a b. (a -> b) -> a -> b
$ SafeHash EraIndependentBlockHeader
-> Hash HASH EraIndependentBlockHeader
forall i. SafeHash i -> Hash HASH i
extractHash SafeHash EraIndependentBlockHeader
headerHash
  cert <-
    expectRightDeep $
      aggregateLeiosCert committee $
        Map.fromList
          [ (LeiosSeatId i, signDSIGN leiosSignContext msg key)
          | (i, key) <- zip [0 ..] (take 3 keys)
          ]
  pure (env, cert)

spec :: Spec
spec :: Spec
spec = Proxy DijkstraEra
-> SpecWith (ImpInit (LedgerSpec DijkstraEra)) -> Spec
forall (proxy :: * -> *) era.
ShelleyEraImp era =>
proxy era -> SpecWith (ImpInit (LedgerSpec era)) -> Spec
withImpInitEachEraVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @DijkstraEra) (SpecWith (ImpInit (LedgerSpec DijkstraEra)) -> Spec)
-> SpecWith (ImpInit (LedgerSpec DijkstraEra)) -> Spec
forall a b. (a -> b) -> a -> b
$
  String
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"validateLeiosCert" (SpecWith (ImpInit (LedgerSpec DijkstraEra))
 -> SpecWith (ImpInit (LedgerSpec DijkstraEra)))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Accepts a valid certificate at the earliest slot" (ImpM (LedgerSpec DijkstraEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ())))
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a b. (a -> b) -> a -> b
$ do
      (env, cert) <- ImpTestM DijkstraEra (LeiosCertEnv, LeiosCert)
mkValidLeiosCertWithEnv
      globals <- use impGlobalsL
      validateLeiosCert @DijkstraEra globals env cert `shouldBe` Right ()

    String
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Returns a signature failure for a different announcing header" (ImpM (LedgerSpec DijkstraEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ())))
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a b. (a -> b) -> a -> b
$ do
      (env, cert) <- ImpTestM DijkstraEra (LeiosCertEnv, LeiosCert)
mkValidLeiosCertWithEnv
      globals <- use impGlobalsL
      otherHash <- arbitrary
      validateLeiosCert @DijkstraEra globals env {lseAnnouncedInBlockHeader = otherHash} cert
        `shouldBe` Left (LeiosCertInvalidSignature :| [])

    String
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Preserves multiple predicate failures" (ImpM (LedgerSpec DijkstraEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ())))
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a b. (a -> b) -> a -> b
$ do
      (env, cert) <- ImpTestM DijkstraEra (LeiosCertEnv, LeiosCert)
mkValidLeiosCertWithEnv
      globals <- use impGlobalsL
      epoch <- getsNES nesELL
      let cur = HasCallStack => EpochInfo Identity -> EpochNo -> SlotNo
EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) (EpochNo
epoch EpochNo -> EpochNo -> EpochNo
forall a. Num a => a -> a -> a
+ EpochNo
1)
          ann = SlotNo
cur SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
1
          env' = LeiosCertEnv
env {lseCurrentSlotNo = cur, lseAnnouncementSlotNo = ann}
      validateLeiosCert @DijkstraEra globals env' cert
        `shouldBe` Left
          ( LeiosCertTooEarly (Mismatch cur (ann + 14))
              :| [LeiosCertAnnouncedInPreviousEpoch (Mismatch (epoch + 1) epoch)]
          )

    String
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Uses the slot length from the supplied Globals" (ImpM (LedgerSpec DijkstraEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ())))
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a b. (a -> b) -> a -> b
$ do
      (env, cert) <- ImpTestM DijkstraEra (LeiosCertEnv, LeiosCert)
mkValidLeiosCertWithEnv
      globals <- use impGlobalsL
      let cur = LeiosCertEnv -> SlotNo
lseCurrentSlotNo LeiosCertEnv
env SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
1
          env' = LeiosCertEnv
env {lseCurrentSlotNo = cur}
          longerSlots =
            Globals
globals
              { epochInfo =
                  (epochInfo globals) {epochInfoSlotLength_ = const $ pure $ mkSlotLength 2}
              }
      validateLeiosCert @DijkstraEra globals env' cert
        `shouldBe` Left (LeiosCertTooEarly (Mismatch cur (lseCurrentSlotNo env)) :| [])
      validateLeiosCert @DijkstraEra longerSlots env' cert `shouldBe` Right ()