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

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

import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure (..))
import Cardano.Ledger.Val (inject)
import Data.Sequence.Strict (StrictSeq (..))
import Lens.Micro
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  ( ShelleyEraImp era
  , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
  ) =>
  SpecWith (ImpTestState era)
spec :: forall era.
(ShelleyEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era) =>
SpecWith (ImpTestState era)
spec = forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXO" forall a b. (a -> b) -> a -> b
$ do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ShelleyUtxoPredFailure" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"ValueNotConservedUTxO" forall a b. (a -> b) -> a -> b
$ do
      Addr (EraCrypto era)
addr1 <- forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Addr c)
freshKeyAddr_
      let txAmount :: Coin
txAmount = Integer -> Coin
Coin Integer
2000000
      TxIn (EraCrypto era)
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era))
sendCoinTo Addr (EraCrypto era)
addr1 Coin
txAmount
      Addr (EraCrypto era)
addr2 <- forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Addr c)
freshKeyAddr_
      (TxIn (EraCrypto era)
_, TxOut era
rootTxOut) <- forall era. ImpTestM era (TxIn (EraCrypto era), TxOut era)
lookupImpRootTxOut
      let extra :: Coin
extra = Integer -> Coin
Coin Integer
3
          rootTxOutValue :: Value era
rootTxOutValue = TxOut era
rootTxOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL
          txBody :: TxBody era
txBody =
            forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn (EraCrypto era)
txIn]
              forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto era)
addr2 forall a. Monoid a => a
mempty]
          adjustTxOut :: StrictSeq (TxOut era) -> StrictSeq (TxOut era)
adjustTxOut = \case
            StrictSeq (TxOut era)
Empty -> forall a. HasCallStack => String -> a
error String
"Unexpected empty sequence of outputs"
            TxOut era
txOut :<| StrictSeq (TxOut era)
outs -> (TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Coin
extra)) forall a. a -> StrictSeq a -> StrictSeq a
:<| StrictSeq (TxOut era)
outs
          adjustFirstTxOut :: Tx era -> Tx era
adjustFirstTxOut Tx era
tx =
            Tx era
tx
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ StrictSeq (TxOut era) -> StrictSeq (TxOut era)
adjustTxOut
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. EraTxWits era => TxWits era
mkBasicTxWits
      forall era a.
(Tx era -> ImpTestM era (Tx era))
-> ImpTestM era a -> ImpTestM era a
withPostFixup (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
updateAddrTxWits forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> Tx era
adjustFirstTxOut) forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          (forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody)
          [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
              forall era. Value era -> Value era -> ShelleyUtxoPredFailure era
ValueNotConservedUTxO
                (Value era
rootTxOutValue forall a. Semigroup a => a -> a -> a
<> forall t s. Inject t s => t -> s
inject Coin
txAmount)
                (Value era
rootTxOutValue forall a. Semigroup a => a -> a -> a
<> forall t s. Inject t s => t -> s
inject (Coin
txAmount forall a. Semigroup a => a -> a -> a
<> Coin
extra))
          ]