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

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

import Cardano.Ledger.BaseTypes (Mismatch (..), Network (..), StrictMaybe (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules (
  DijkstraMempoolPredFailure (..),
  DijkstraSubUtxoPredFailure (..),
  DijkstraUtxoPredFailure (..),
 )
import Cardano.Ledger.State (utxoG)
import Data.Maybe (isNothing)
import qualified Data.Set.NonEmpty as NES
import Lens.Micro ((&), (.~), (^.))
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
"MEMPOOL" (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
"AllInputsAreSpent" (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
"a transaction that has already been applied" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      txIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      appliedTx <- submitTx $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
      withNoFixup $ submitFailingMempoolTx appliedTx [AllInputsAreSpent]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a transaction whose inputs were each spent by a different transaction" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      firstTxIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      secondTxIn <- freshFundedTxIn
      submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [firstTxIn]
      submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [secondTxIn]
      withNoFixup $
        submitFailingMempoolTx
          (mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [firstTxIn, secondTxIn])
          [AllInputsAreSpent]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a transaction with no inputs" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$
      ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$
        Tx TopTx era
-> NonEmpty (DijkstraMempoolPredFailure era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, DijkstraEraImp era) =>
Tx TopTx era
-> NonEmpty (DijkstraMempoolPredFailure era) -> ImpTestM era ()
submitFailingMempoolTx (TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody) [Item (NonEmpty (DijkstraMempoolPredFailure era))
DijkstraMempoolPredFailure era
forall era. DijkstraMempoolPredFailure era
AllInputsAreSpent]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a batch whose sub-transaction inputs are unspent, but whose own are not" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spentTxIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [spentTxIn]
      unspentTxIn <- freshFundedTxIn
      let subTx :: Tx SubTx era
          subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
unspentTxIn]
      withNoFixup $
        submitFailingMempoolTx
          (mkTopTxWithSubTxs [subTx] & bodyTxL . inputsTxBodyL .~ [spentTxIn])
          [AllInputsAreSpent]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"LedgerFailure" (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
"an input that is already spent, alongside one that is not" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spentTxIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [spentTxIn]
      unspentTxIn <- freshFundedTxIn
      submitFailingMempoolTx
        (mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [spentTxIn, unspentTxIn])
        [ LedgerFailure . injectFailure . BadInputsUTxO $ NES.singleton spentTxIn
        , LedgerFailure . injectFailure . BadInputsUTxO $ NES.singleton spentTxIn
        ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"an input of a sub-transaction that is already spent" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spentTxIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [spentTxIn]
      let subTx :: Tx SubTx era
          subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> Set TxIn -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
spentTxIn]
      submitFailingMempoolTx
        (mkTopTxWithSubTxs [subTx])
        [ LedgerFailure . injectFailure . SubBadInputsUTxO $ NES.singleton spentTxIn
        , LedgerFailure . injectFailure . SubBadInputsUTxO $ NES.singleton spentTxIn
        ]

  -- `MempoolFailure` is unreachable in Dijkstra: the check that raises
  -- it in Conway, on votes cast by unelected committee members, is not
  -- part of this transition. It remains as the target that such a Conway
  -- failure injects into, and as the meaning of CBOR tag 2 on the wire.

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Accepted at the boundary" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a transaction whose inputs are all unspent" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      txIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      (mempoolState, _) <-
        expectRight
          =<< trySubmitMempoolTx (mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn])
      expectUTxOContent (mempoolState ^. utxoG) [(txIn, isNothing)]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Composite tests" (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
"no ledger check runs when all inputs are spent" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spentTxIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      submitTx_ $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [spentTxIn]
      let subTx :: Tx SubTx era
          subTx = TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody SubTx era -> Tx SubTx era)
-> TxBody SubTx era -> Tx SubTx era
forall a b. (a -> b) -> a -> b
$ TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody TxBody SubTx era
-> (TxBody SubTx era -> TxBody SubTx era) -> TxBody SubTx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Network -> Identity (StrictMaybe Network))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
AlonzoEraTxBody era =>
Lens' (TxBody l era) (StrictMaybe Network)
forall (l :: TxLevel). Lens' (TxBody l era) (StrictMaybe Network)
networkIdTxBodyL ((StrictMaybe Network -> Identity (StrictMaybe Network))
 -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> StrictMaybe Network -> TxBody SubTx era -> TxBody SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Network -> StrictMaybe Network
forall a. a -> StrictMaybe a
SJust Network
Mainnet
      withNoFixup $
        submitFailingMempoolTx
          (mkTopTxWithSubTxs [subTx] & bodyTxL . inputsTxBodyL .~ [spentTxIn])
          [AllInputsAreSpent]
      submitFailingMempoolTx
        (mkTopTxWithSubTxs [subTx])
        [ LedgerFailure . injectFailure . SubWrongNetworkInTxBody $
            Mismatch {mismatchSupplied = Mainnet, mismatchExpected = Testnet}
        ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a transaction the mempool validated, once it has been applied" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      txIn <- ImpTestM era TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
      tx <- fixupTx $ mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ [txIn]
      withNoFixup $ do
        (_, validatedTx) <- expectRight =<< trySubmitMempoolTx tx
        submitTx_ tx
        reapplyResult <- tryReapplyMempoolTx validatedTx
        expectMempoolRejection reapplyResult [AllInputsAreSpent]