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

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

import Cardano.Ledger.BaseTypes (Mismatch (..))
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 (ImpInit (LedgerSpec era))
spec :: forall era.
(ShelleyEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era) =>
SpecWith (ImpInit (LedgerSpec 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
addr1 <- forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m Addr
freshKeyAddr_
      let txAmount :: Coin
txAmount = Integer -> Coin
Coin Integer
2000000
      TxIn
txIn <- forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr1 Coin
txAmount
      Addr
addr2 <- forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m Addr
freshKeyAddr_
      (TxIn
_, TxOut era
rootTxOut) <- forall era. ImpTestM era (TxIn, 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)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [TxIn
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 -> Value era -> TxOut era
mkBasicTxOut Addr
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.
Mismatch 'RelEQ (Value era) -> ShelleyUtxoPredFailure era
ValueNotConservedUTxO forall a b. (a -> b) -> a -> b
$
                forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch
                  (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))
          ]