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

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

import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules
import Cardano.Ledger.TxIn (mkTxInPartial)
import qualified Data.OMap.Strict as OMap
import qualified Data.Set as Set
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
"LEDGER" (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
"Spending sub-transaction outputs" (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
"Fails when top-level transaction spends output from its own sub-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
      txIn <- (Addr -> Coin -> ImpTestM era TxIn
forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
`sendCoinTo` Integer -> Coin
Coin Integer
10_000_000) (Addr -> ImpTestM era TxIn)
-> ImpM (LedgerSpec era) Addr -> ImpTestM era TxIn
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
      subTxIn <- (`sendCoinTo` Coin 5_000_000) =<< freshKeyAddr_

      let subTx :: Tx SubTx era
          -- consume an input, to avoid the fixup adding one, which would throw off the test conditions
          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
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
subTxIn])
          subTxId = Tx SubTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx SubTx era
subTx -- now stable through fixup
          badInput = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
subTxId Integer
0
          tx =
            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
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx 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))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Set TxIn -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn, Item (Set TxIn)
TxIn
badInput]
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Identity (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OMap TxId (Tx SubTx era)
    -> Identity (OMap TxId (Tx SubTx era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OMap TxId (Tx SubTx era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx]

      submitFailingTx
        tx
        -- the failure is produced twice - checking against the origin and threaded state, respectively
        [ injectFailure $ BadInputsUTxO $ NES.singleton badInput
        , injectFailure $ BadInputsUTxO $ NES.singleton badInput
        ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails when sub-transaction spends output from another sub-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
      (_, addr1) <- ImpM (LedgerSpec era) (KeyHash Payment, Addr)
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m (KeyHash Payment, Addr)
freshKeyAddr
      txIn1 <- sendCoinTo addr1 (Coin 10_000_000)
      (_, addr2) <- freshKeyAddr
      txIn2 <- sendCoinTo addr2 (Coin 10_000_000)

      let subTx1 :: Tx SubTx era
          subTx1 =
            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
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> Set TxIn -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn1]
          subTx1Id = Tx SubTx era -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
txIdTx Tx SubTx era
subTx1

          badInput = HasCallStack => TxId -> Integer -> TxIn
TxId -> Integer -> TxIn
mkTxInPartial TxId
subTx1Id Integer
0
          subTx2 :: Tx SubTx era
          subTx2 =
            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
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> Set TxIn -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (Set TxIn)
TxIn
txIn2, Item (Set TxIn)
TxIn
badInput]

          tx =
            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
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Identity (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OMap TxId (Tx SubTx era)
    -> Identity (OMap TxId (Tx SubTx era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OMap TxId (Tx SubTx era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx1, Item (OMap TxId (Tx SubTx era))
Tx SubTx era
subTx2]

      submitFailingTx
        tx
        [ injectFailure $ SubBadInputsUTxO $ NES.singleton badInput
        , injectFailure $ SubBadInputsUTxO $ NES.singleton badInput
        ]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Succeeds when inputs don't reference sub-transaction outputs" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (_, addr1) <- ImpM (LedgerSpec era) (KeyHash Payment, Addr)
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m (KeyHash Payment, Addr)
freshKeyAddr
      txIn1 <- sendCoinTo addr1 (Coin 10_000_000)
      (_, addr2) <- freshKeyAddr
      txIn2 <- sendCoinTo addr2 (Coin 10_000_000)

      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
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> Set TxIn -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn1

          tx =
            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
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx 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))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Set TxIn -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
txIn2
              Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((OMap TxId (Tx SubTx era)
     -> Identity (OMap TxId (Tx SubTx era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (OMap TxId (Tx SubTx era)
    -> Identity (OMap TxId (Tx SubTx era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
DijkstraEraTxBody era =>
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
Lens' (TxBody TopTx era) (OMap TxId (Tx SubTx era))
subTransactionsTxBodyL ((OMap TxId (Tx SubTx era) -> Identity (OMap TxId (Tx SubTx era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> OMap TxId (Tx SubTx era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Tx SubTx era -> OMap TxId (Tx SubTx era)
forall k v. HasOKey k v => v -> OMap k v
OMap.singleton Tx SubTx era
subTx

      submitTx_ tx