{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

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

import Cardano.Ledger.Allegra.Rules
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Mary
import Cardano.Ledger.Mary.Core
import Cardano.Ledger.Mary.Value
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.Shelley.Scripts
import Cardano.Ledger.Tools
import qualified Data.Map.Strict as Map
import Data.Sequence.Strict (StrictSeq (..))
import Lens.Micro
import Test.Cardano.Ledger.Core.Utils
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Mary.ImpTest

mintBasicToken ::
  (HasCallStack, MaryEraImp era) => ImpTestM era (Tx TopTx era)
mintBasicToken :: forall era.
(HasCallStack, MaryEraImp era) =>
ImpTestM era (Tx TopTx era)
mintBasicToken = do
  addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
  keyHash <- freshKeyHash
  scriptHash <- impAddNativeScript $ RequireSignature keyHash
  Positive amount <- arbitrary
  let txAsset = Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset (Map PolicyID (Map AssetName Integer) -> MultiAsset)
-> Map PolicyID (Map AssetName Integer) -> MultiAsset
forall a b. (a -> b) -> a -> b
$ PolicyID
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall k a. k -> a -> Map k a
Map.singleton (ScriptHash -> PolicyID
PolicyID ScriptHash
scriptHash) (Map AssetName Integer -> Map PolicyID (Map AssetName Integer))
-> Map AssetName Integer -> Map PolicyID (Map AssetName Integer)
forall a b. (a -> b) -> a -> b
$ AssetName -> Integer -> Map AssetName Integer
forall k a. k -> a -> Map k a
Map.singleton (ShortByteString -> AssetName
AssetName ShortByteString
"testAsset") Integer
amount
      txValue :: MaryValue
      txValue = Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty MultiAsset
txAsset
      txBody =
        TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL ((StrictSeq (TxOut era) -> Identity (StrictSeq (TxOut era)))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> StrictSeq (TxOut era) -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr Value era
MaryValue
txValue]
          TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> MultiAsset -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset
txAsset
  submitTx $ mkBasicTx txBody

spec ::
  ( HasCallStack
  , MaryEraImp era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(HasCallStack, MaryEraImp 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
"UTXO" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1279
  -- TODO: Re-enable after issue is resolved, by removing this override
  String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Mint a Token" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ ImpM (LedgerSpec era) (Tx TopTx era) -> ImpTestM era ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ImpM (LedgerSpec era) (Tx TopTx era)
forall era.
(HasCallStack, MaryEraImp era) =>
ImpTestM era (Tx TopTx era)
mintBasicToken
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ShelleyUtxoPredFailure" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/1279
    -- TODO: Re-enable after issue is resolved, by removing this override
    String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"ValueNotConservedUTxO" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      -- Burn too much
      Positive tooMuch <- ImpM (LedgerSpec era) (Positive Integer)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      txMinted <- mintBasicToken
      let MaryValue c (MultiAsset mintedMultiAsset) =
            case txMinted ^. bodyTxL . outputsTxBodyL of
              StrictSeq (TxOut era)
Empty -> String -> MaryValue
forall a. HasCallStack => String -> a
error String
"Empty outputs was unexpected"
              TxOut era
txOut :<| StrictSeq (TxOut era)
_ -> TxOut era
txOut TxOut era -> Getting MaryValue (TxOut era) MaryValue -> MaryValue
forall s a. s -> Getting a s a -> a
^. (Value era -> Const MaryValue (Value era))
-> TxOut era -> Const MaryValue (TxOut era)
Getting MaryValue (TxOut era) MaryValue
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL
          burnTooMuchMultiAsset@(MultiAsset burnTooMuch) =
            MultiAsset (Map.map (Map.map (subtract tooMuch . negate)) mintedMultiAsset)
          -- Produced should contain positive value that was atttempted to be burned
          burnTooMuchProducedMultiAsset = Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset ((Map AssetName Integer -> Map AssetName Integer)
-> Map PolicyID (Map AssetName Integer)
-> Map PolicyID (Map AssetName Integer)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Integer -> Integer)
-> Map AssetName Integer -> Map AssetName Integer
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Integer -> Integer
forall a. Num a => a -> a
negate) Map PolicyID (Map AssetName Integer)
burnTooMuch)
          txBody =
            TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (Set TxIn -> Identity (Set TxIn))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> Set TxIn -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Int -> Tx TopTx era -> TxIn
forall era (l :: TxLevel).
(HasCallStack, EraTx era) =>
Int -> Tx l era -> TxIn
txInAt Int
0 Tx TopTx era
txMinted]
              TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (MultiAsset -> Identity MultiAsset)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL ((MultiAsset -> Identity MultiAsset)
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> MultiAsset -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset
burnTooMuchMultiAsset
      (_, rootTxOut) <- getImpRootTxOut
      let rootTxOutValue = TxOut era
rootTxOut TxOut era -> Getting MaryValue (TxOut era) MaryValue -> MaryValue
forall s a. s -> Getting a s a -> a
^. (Value era -> Const MaryValue (Value era))
-> TxOut era -> Const MaryValue (TxOut era)
Getting MaryValue (TxOut era) MaryValue
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL
      submitFailingTx
        (mkBasicTx txBody)
        [ injectFailure $
            Shelley.ValueNotConservedUTxO $
              Mismatch
                (rootTxOutValue <> MaryValue c (MultiAsset mintedMultiAsset))
                (rootTxOutValue <> MaryValue c burnTooMuchProducedMultiAsset)
        ]

maryOnlySpec :: SpecWith (ImpInit (LedgerSpec MaryEra))
maryOnlySpec :: SpecWith (ImpInit (LedgerSpec MaryEra))
maryOnlySpec = String
-> SpecWith (ImpInit (LedgerSpec MaryEra))
-> SpecWith (ImpInit (LedgerSpec MaryEra))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXO" (SpecWith (ImpInit (LedgerSpec MaryEra))
 -> SpecWith (ImpInit (LedgerSpec MaryEra)))
-> SpecWith (ImpInit (LedgerSpec MaryEra))
-> SpecWith (ImpInit (LedgerSpec MaryEra))
forall a b. (a -> b) -> a -> b
$
  String
-> SpecWith (ImpInit (LedgerSpec MaryEra))
-> SpecWith (ImpInit (LedgerSpec MaryEra))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"AllegraUtxoPredFailure" (SpecWith (ImpInit (LedgerSpec MaryEra))
 -> SpecWith (ImpInit (LedgerSpec MaryEra)))
-> SpecWith (ImpInit (LedgerSpec MaryEra))
-> SpecWith (ImpInit (LedgerSpec MaryEra))
forall a b. (a -> b) -> a -> b
$
    String
-> ImpM (LedgerSpec MaryEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec MaryEra) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"OutputTooBigUTxO" (ImpM (LedgerSpec MaryEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec MaryEra) ())))
-> ImpM (LedgerSpec MaryEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec MaryEra) ()))
forall a b. (a -> b) -> a -> b
$ do
      pp <- Lens' (PParams MaryEra) (PParams MaryEra)
-> ImpTestM MaryEra (PParams MaryEra)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams MaryEra -> f (PParams MaryEra))
-> PParams MaryEra -> f (PParams MaryEra)
forall a. a -> a
Lens' (PParams MaryEra) (PParams MaryEra)
id
      policyId <- PolicyID <$> (impAddNativeScript . RequireSignature =<< freshKeyHash)
      -- Serialized, 125 asset names of 32 bytes exceed the 4000 bytes allowed for a `Value`
      assetNames <- replicateM 125 $ AssetName <$> uniformShortByteStringM 32
      addr <- freshKeyAddr_
      let multiAsset = [(PolicyID, AssetName, Integer)] -> MultiAsset
multiAssetFromList [(PolicyID
policyId, AssetName
assetName, Integer
1) | AssetName
assetName <- [AssetName]
assetNames]
          txOut = PParams MaryEra -> TxOut MaryEra -> TxOut MaryEra
forall era. EraTxOut era => PParams era -> TxOut era -> TxOut era
setMinCoinTxOut PParams MaryEra
pp (TxOut MaryEra -> TxOut MaryEra)
-> (MaryValue -> TxOut MaryEra) -> MaryValue -> TxOut MaryEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Addr -> Value MaryEra -> TxOut MaryEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (MaryValue -> TxOut MaryEra) -> MaryValue -> TxOut MaryEra
forall a b. (a -> b) -> a -> b
$ Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty MultiAsset
multiAsset
      submitFailingTx
        ( mkBasicTx $
            mkBasicTxBody
              & mintTxBodyL .~ multiAsset
              & outputsTxBodyL .~ [txOut]
        )
        [injectFailure $ OutputTooBigUTxO [txOut]]