{-# 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 (EraCrypto era)
addr1 <- forall s c (m :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g 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 :: * -> *) g.
(HasKeyPairs s c, MonadState s m, HasStatefulGen g 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.
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))
          ]