{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

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

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Block (EbReferencesAnnouncement (..), LeiosEraBlockHeader (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Dijkstra.Block.Endorser (EraEndorserBlock (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules (EbPredFailure (..))
import Control.Monad.State.Strict (MonadState (..))
import Lens.Micro ((&), (.~), (^.))
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  ( DijkstraEraImp era
  , HashAnnotated (Tx TopTx era) EraIndependentTx
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(DijkstraEraImp era,
 HashAnnotated (Tx TopTx era) EraIndependentTx) =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"EB" (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
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Applying EB" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let
      genSimpleTx :: ImpTestM era (AnyLevelTx era)
      genSimpleTx :: ImpTestM era (AnyLevelTx era)
genSimpleTx = do
        addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
        amnt <- inject . Coin <$> choose (100, 1000000000)
        pure $
          AnyLevelTx $
            mkBasicTx @era mkBasicTxBody
              & bodyTxL . outputsTxBodyL .~ [mkBasicTxOut addr amnt]

      genRBandEB :: ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era)
genRBandEB = ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era)
-> ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era)
forall era a. ImpTestM era a -> ImpTestM era a
simulateThenRestore (ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era)
 -> ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era))
-> ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era)
-> ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era)
forall a b. (a -> b) -> a -> b
$ do
        nBlockTxs <- (Int, Int) -> ImpM (LedgerSpec era) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
0, Int
10)
        blockTxs <- impRecordSubmittedTxs $ replicateM_ nBlockTxs $ do
          AnyLevelTx tx <- genSimpleTx
          submitAnyTx tx
        nEbTxs <- choose (0, 100)
        ebTxs <- impRecordSubmittedTxs $ replicateM_ nEbTxs $ do
          AnyLevelTx tx <- genSimpleTx
          submitAnyTx tx
        eb <- makeEndorserBlock ebTxs
        pure (blockTxs, eb)

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Succeeds when EB is announced" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (blockTxs, eb) <- ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era)
genRBandEB
      let announcement = EndorserBlock era -> EbReferencesAnnouncement
forall era.
EraEndorserBlock era =>
EndorserBlock era -> EbReferencesAnnouncement
mkEbReferencesAnnouncement EndorserBlock era
eb
      st <- get
      issuer <- freshKeyHash
      impAnn "Submit RB" $
        expectRightDeepExpr_
          =<< tryTxsInBlock
            (ebReferencesAnnouncementBlockHeaderL .~ SJust announcement)
            blockTxs
            st
            issuer
      impAnn "Submit EB" $ applyEndorserBlock eb
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails when the EB is not announced" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ebTxs <- ImpTestM era (StrictSeq (Tx TopTx era))
-> ImpTestM era (StrictSeq (Tx TopTx era))
forall era a. ImpTestM era a -> ImpTestM era a
simulateThenRestore (ImpTestM era (StrictSeq (Tx TopTx era))
 -> ImpTestM era (StrictSeq (Tx TopTx era)))
-> ImpTestM era (StrictSeq (Tx TopTx era))
-> ImpTestM era (StrictSeq (Tx TopTx era))
forall a b. (a -> b) -> a -> b
$ do
        nEbTxs <- (Int, Int) -> ImpM (LedgerSpec era) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
0, Int
100)
        impRecordSubmittedTxs $ replicateM_ nEbTxs $ do
          AnyLevelTx tx <- genSimpleTx
          submitAnyTx tx
      eb <- makeEndorserBlock ebTxs
      impAnn "Submit EB" $
        applyFailingEndorserBlock
          eb
          [ injectFailure $ EbWasNotAnnounced $ hashAnnotated $ eb ^. referencesEndorserBlockL
          ]
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails when the EB announcment has a different hash" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (blockTxs, eb) <- ImpTestM era (StrictSeq (Tx TopTx era), EndorserBlock era)
genRBandEB
      announcement <- arbitrary
      st <- get
      issuer <- freshKeyHash
      impAnn "Submit RB" $
        expectRightDeepExpr_
          =<< tryTxsInBlock
            (ebReferencesAnnouncementBlockHeaderL .~ SJust announcement)
            blockTxs
            st
            issuer
      impAnn "Submit EB" $
        applyFailingEndorserBlock
          eb
          [ injectFailure $
              EbAnnouncementHashMismatch
                Mismatch
                  { mismatchSupplied = hashAnnotated $ eb ^. referencesEndorserBlockL
                  , mismatchExpected = ebReferencesAnnouncementHash announcement
                  }
          ]