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

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

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.BaseTypes (Inject (..), Network (..), StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
import Cardano.Ledger.Dijkstra.Core (
  BabbageEraTxBody (..),
  EraTx (..),
  EraTxBody (..),
  EraTxOut (..),
  InjectRuleFailure (..),
 )
import Cardano.Ledger.Dijkstra.Rules (DijkstraUtxoPredFailure (..))
import Cardano.Ledger.Tools (ensureMinCoinTxOut)
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Dijkstra.ImpTest (
  DijkstraEraImp,
  ImpInit,
  LedgerSpec,
  freshKeyHash,
  getsPParams,
  submitFailingTx,
 )
import Test.Cardano.Ledger.Imp.Common (SpecWith, arbitrary, describe, it)

spec ::
  forall era.
  ( DijkstraEraImp era
  , InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(DijkstraEraImp era,
 InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure 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
"Collaterals" (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 to submit a transaction containing a Ptr in collateral return" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      cred <- KeyHash Payment -> Credential Payment
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Payment -> Credential Payment)
-> ImpM (LedgerSpec era) (KeyHash Payment)
-> ImpM (LedgerSpec era) (Credential Payment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Payment)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      ptr <- arbitrary
      pp <- getsPParams id
      let
        ptrAddr = Network -> Credential Payment -> StakeReference -> Addr
Addr Network
Testnet Credential Payment
cred (Ptr -> StakeReference
StakeRefPtr Ptr
ptr)
        ptrOutput = PParams era -> TxOut era -> TxOut era
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
ensureMinCoinTxOut PParams era
pp (TxOut era -> TxOut era) -> TxOut era -> TxOut era
forall a b. (a -> b) -> a -> b
$ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
ptrAddr (Value era -> TxOut era)
-> (Coin -> Value era) -> Coin -> TxOut era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coin -> Value era
forall t s. Inject t s => t -> s
inject (Coin -> TxOut era) -> Coin -> TxOut era
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
100
        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))
-> ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era.
BabbageEraTxBody era =>
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
Lens' (TxBody TopTx era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL ((StrictMaybe (TxOut era) -> Identity (StrictMaybe (TxOut era)))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> StrictMaybe (TxOut era) -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxOut era -> StrictMaybe (TxOut era)
forall a. a -> StrictMaybe a
SJust TxOut era
ptrOutput
      submitFailingTx tx [injectFailure $ PtrPresentInCollateralReturn ptrOutput]