{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

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

import Cardano.Ledger.Allegra.Scripts
import Cardano.Ledger.Mary.Core
import Cardano.Ledger.Mary.Value
import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure (..))
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireSignature,
 )
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (StrictSeq (..))
import Lens.Micro
import Test.Cardano.Ledger.Core.Utils (txInAt)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Mary.ImpTest

mintBasicToken ::
  forall era. (HasCallStack, AllegraEraScript era, MaryEraImp era) => ImpTestM era (Tx era)
mintBasicToken :: forall era.
(HasCallStack, AllegraEraScript era, MaryEraImp era) =>
ImpTestM era (Tx era)
mintBasicToken = do
  Addr (EraCrypto era)
addr <- forall s c (m :: * -> *).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (Addr c)
freshKeyAddr_
  KeyHash 'Witness (EraCrypto era)
keyHash <- forall s c (m :: * -> *) (r :: KeyRole).
(HasKeyPairs s c, MonadState s m,
 HasStatefulGen (StateGenM s) m) =>
m (KeyHash r c)
freshKeyHash
  ScriptHash (EraCrypto era)
scriptHash <- forall era.
EraScript era =>
NativeScript era -> ImpTestM era (ScriptHash (EraCrypto era))
impAddNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
RequireSignature KeyHash 'Witness (EraCrypto era)
keyHash
  Positive Integer
amount <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
  let txAsset :: MultiAsset (EraCrypto era)
txAsset = forall c. Map (PolicyID c) (Map AssetName Integer) -> MultiAsset c
MultiAsset forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (forall c. ScriptHash c -> PolicyID c
PolicyID ScriptHash (EraCrypto era)
scriptHash) forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (ShortByteString -> AssetName
AssetName ShortByteString
"testAsset") Integer
amount
      txValue :: MaryValue (EraCrypto era)
      txValue :: MaryValue (EraCrypto era)
txValue = forall c. Coin -> MultiAsset c -> MaryValue c
MaryValue forall a. Monoid a => a
mempty MultiAsset (EraCrypto era)
txAsset
      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) (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)
addr MaryValue (EraCrypto era)
txValue]
          forall a b. a -> (a -> b) -> b
& forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
mintTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset (EraCrypto era)
txAsset
  forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall a b. (a -> b) -> a -> b
$ forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
txBody

spec ::
  ( HasCallStack
  , MaryEraImp era
  , AllegraEraScript era
  , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
  ) =>
  SpecWith (ImpTestState era)
spec :: forall era.
(HasCallStack, MaryEraImp era, AllegraEraScript 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, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Mint a Token" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall era.
(HasCallStack, AllegraEraScript era, MaryEraImp era) =>
ImpTestM era (Tx era)
mintBasicToken
  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
      -- Burn too much
      Positive Integer
tooMuch <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      Tx era
txMinted <- forall era.
(HasCallStack, AllegraEraScript era, MaryEraImp era) =>
ImpTestM era (Tx era)
mintBasicToken
      let MaryValue Coin
c (MultiAsset Map (PolicyID (EraCrypto era)) (Map AssetName Integer)
mintedMultiAsset) =
            case Tx era
txMinted forall s a. s -> Getting a s a -> a
^. 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 of
              StrictSeq (TxOut era)
Empty -> forall a. HasCallStack => String -> a
error String
"Empty outputs was unexpected"
              TxOut era
txOut :<| StrictSeq (TxOut era)
_ -> TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL
          burnTooMuchMultiAsset :: MultiAsset (EraCrypto era)
burnTooMuchMultiAsset@(MultiAsset Map (PolicyID (EraCrypto era)) (Map AssetName Integer)
burnTooMuch) =
            forall c. Map (PolicyID c) (Map AssetName Integer) -> MultiAsset c
MultiAsset (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a. Num a => a -> a -> a
subtract Integer
tooMuch forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a
negate)) Map (PolicyID (EraCrypto era)) (Map AssetName Integer)
mintedMultiAsset)
          -- Produced should contain positive value that was atttempted to be burned
          burnTooMuchProducedMultiAsset :: MultiAsset (EraCrypto era)
burnTooMuchProducedMultiAsset = forall c. Map (PolicyID c) (Map AssetName Integer) -> MultiAsset c
MultiAsset (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. Num a => a -> a
negate) Map (PolicyID (EraCrypto era)) (Map AssetName Integer)
burnTooMuch)
          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
.~ [forall i era.
(HasCallStack, Integral i, EraTx era) =>
i -> Tx era -> TxIn (EraCrypto era)
txInAt (Int
0 :: Int) Tx era
txMinted]
              forall a b. a -> (a -> b) -> b
& forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
mintTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset (EraCrypto era)
burnTooMuchMultiAsset
      (TxIn (EraCrypto era)
_, TxOut era
rootTxOut) <- forall era. ImpTestM era (TxIn (EraCrypto era), TxOut era)
lookupImpRootTxOut
      let rootTxOutValue :: MaryValue (EraCrypto era)
rootTxOutValue = TxOut era
rootTxOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL
      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
              (MaryValue (EraCrypto era)
rootTxOutValue forall a. Semigroup a => a -> a -> a
<> forall c. Coin -> MultiAsset c -> MaryValue c
MaryValue Coin
c (forall c. Map (PolicyID c) (Map AssetName Integer) -> MultiAsset c
MultiAsset Map (PolicyID (EraCrypto era)) (Map AssetName Integer)
mintedMultiAsset))
              (MaryValue (EraCrypto era)
rootTxOutValue forall a. Semigroup a => a -> a -> a
<> forall c. Coin -> MultiAsset c -> MaryValue c
MaryValue Coin
c MultiAsset (EraCrypto era)
burnTooMuchProducedMultiAsset)
        ]