{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE NumericUnderscores  #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}

{-# OPTIONS_GHC -Wno-orphans #-}

 -- | Test facility for 'Cardano.Node.Emulator.API.MonadEmulator'
module Cardano.Node.Emulator.Test (
  -- * Basic testing
    hasValidatedTransactionCountOfTotal
  , renderLogs
  -- * Testing with `quickcheck-contractmodel`
  , propSanityCheckModel
  , propSanityCheckAssertions
  , propRunActions_
  , propRunActions
  , propRunActionsWithOptions
  -- * Other exports
  , chainStateToChainIndex
  , chainStateToContractModelChainState
  -- * Re-export quickcheck-contractmodel
  , module Test.QuickCheck.ContractModel
) where

import Cardano.Api qualified as C
import Cardano.Api qualified as CardanoAPI
import Cardano.Node.Emulator.API (EmulatorLogs, EmulatorM, EmulatorMsg (ChainEvent), LogMessage (LogMessage), awaitSlot,
                                  emptyEmulatorStateWithInitialDist, esChainState, getParams)
import Cardano.Node.Emulator.Generators (knownAddresses)
import Cardano.Node.Emulator.Internal.Node qualified as E
import Cardano.Node.Emulator.Internal.Node.Params (pNetworkId, pProtocolParams)
import Control.Lens (use, view, (^.))
import Control.Monad.Except (runExceptT)
import Control.Monad.RWS.Strict (evalRWS)
import Control.Monad.Writer (runWriterT)
import Data.Default (def)
import Data.Foldable (toList)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Monoid (Sum (Sum))
import Data.Text qualified as Text
import Ledger (CardanoAddress, CardanoTx (CardanoEmulatorEraTx), OnChainTx, onChainTxIsValid, unOnChain)
import Ledger.Index qualified as Index
import Ledger.Tx.CardanoAPI (fromCardanoSlotNo)
import Ledger.Value.CardanoAPI qualified as Value
import Prettyprinter qualified as Pretty
import Prettyprinter.Render.Text qualified as Pretty
import Test.QuickCheck as QC (Property, Testable (property), counterexample, expectFailure, (.&&.))
import Test.QuickCheck.ContractModel (Actions, BalanceChangeOptions (BalanceChangeOptions),
                                      ChainIndex (ChainIndex, networkId, transactions),
                                      ChainState (ChainState, slot, utxo), ContractModel, HasChainIndex, IsRunnable,
                                      ModelState, RunModel, RunMonad (unRunMonad), TxInState (TxInState),
                                      assertBalanceChangesMatch, asserts, balanceChanges, runContractModel,
                                      signerPaysFees, stateAfter, symIsZero)
import Test.QuickCheck.ContractModel qualified as CM
import Test.QuickCheck.ContractModel.Internal (ContractModelResult)
import Test.QuickCheck.Monadic (PropertyM, monadic, monadicIO)
import Test.QuickCheck.StateModel (Realized)


-- | Test the number of validated transactions and the total number of transactions.
-- Returns a failure message if the numbers don't match up.
hasValidatedTransactionCountOfTotal :: Int -> Int -> EmulatorLogs -> Maybe String
hasValidatedTransactionCountOfTotal :: Int -> Int -> EmulatorLogs -> Maybe String
hasValidatedTransactionCountOfTotal Int
valid Int
total EmulatorLogs
lg =
  let count :: LogMessage EmulatorMsg -> (Sum Int, Sum Int)
count = \case
        LogMessage LogLevel
_ (ChainEvent (E.TxnValidation Index.Success{}))    -> (Int -> Sum Int
forall a. a -> Sum a
Sum Int
1, Int -> Sum Int
forall a. a -> Sum a
Sum Int
0)
        LogMessage LogLevel
_ (ChainEvent (E.TxnValidation Index.FailPhase1{})) -> (Int -> Sum Int
forall a. a -> Sum a
Sum Int
0, Int -> Sum Int
forall a. a -> Sum a
Sum Int
1)
        LogMessage LogLevel
_ (ChainEvent (E.TxnValidation Index.FailPhase2{})) -> (Int -> Sum Int
forall a. a -> Sum a
Sum Int
0, Int -> Sum Int
forall a. a -> Sum a
Sum Int
1)
        LogMessage EmulatorMsg
_otherLogMsg                                                   -> (Sum Int, Sum Int)
forall a. Monoid a => a
mempty
      (Sum Int
validCount, Sum Int
invalidCount) = (LogMessage EmulatorMsg -> (Sum Int, Sum Int))
-> EmulatorLogs -> (Sum Int, Sum Int)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap LogMessage EmulatorMsg -> (Sum Int, Sum Int)
count EmulatorLogs
lg
  in
    if Int
valid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
validCount then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Unexpected number of valid transactions: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
validCount
    else if Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
valid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
invalidCount then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"Unexpected number of invalid transactions: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
invalidCount
    else Maybe String
forall a. Maybe a
Nothing

-- | Render the logs in a format useful for debugging why a test failed.
renderLogs :: EmulatorLogs -> Text.Text
renderLogs :: EmulatorLogs -> Text
renderLogs = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.renderStrict (SimpleDocStream Any -> Text)
-> (EmulatorLogs -> SimpleDocStream Any) -> EmulatorLogs -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
Pretty.layoutPretty LayoutOptions
Pretty.defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> (EmulatorLogs -> Doc Any) -> EmulatorLogs -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
Pretty.vsep ([Doc Any] -> Doc Any)
-> (EmulatorLogs -> [Doc Any]) -> EmulatorLogs -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq (Doc Any) -> [Doc Any]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (Doc Any) -> [Doc Any])
-> (EmulatorLogs -> Seq (Doc Any)) -> EmulatorLogs -> [Doc Any]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogMessage EmulatorMsg -> Doc Any)
-> EmulatorLogs -> Seq (Doc Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LogMessage EmulatorMsg -> Doc Any
forall a ann. Pretty a => a -> Doc ann
Pretty.pretty


type instance Realized EmulatorM a = a

instance IsRunnable EmulatorM where
  awaitSlot :: SlotNo -> EmulatorM ()
awaitSlot = Slot -> EmulatorM ()
forall (m :: * -> *). MonadEmulator m => Slot -> m ()
awaitSlot (Slot -> EmulatorM ())
-> (SlotNo -> Slot) -> SlotNo -> EmulatorM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Slot
fromCardanoSlotNo

instance HasChainIndex EmulatorM where
  getChainIndex :: EmulatorM ChainIndex
getChainIndex = do
    NetworkId
nid <- Params -> NetworkId
pNetworkId (Params -> NetworkId)
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     Params
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
  EmulatorError
  (RWST Params EmulatorLogs EmulatorState Identity)
  Params
forall (m :: * -> *). MonadEmulator m => m Params
getParams
    NetworkId -> ChainState -> ChainIndex
chainStateToChainIndex NetworkId
nid (ChainState -> ChainIndex)
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     ChainState
-> EmulatorM ChainIndex
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ChainState EmulatorState ChainState
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     ChainState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ChainState EmulatorState ChainState
Lens' EmulatorState ChainState
esChainState
  getChainState :: EmulatorM ChainState
getChainState = do
    ChainState -> ChainState
chainStateToContractModelChainState (ChainState -> ChainState)
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     ChainState
-> EmulatorM ChainState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting ChainState EmulatorState ChainState
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     ChainState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ChainState EmulatorState ChainState
Lens' EmulatorState ChainState
esChainState

-- | Sanity check a `ContractModel`. Ensures that wallet balances are not always unchanged.
propSanityCheckModel :: forall state. ContractModel state => QC.Property
propSanityCheckModel :: Property
propSanityCheckModel =
  (Actions state -> Bool) -> Property
forall prop. Testable prop => prop -> Property
QC.expectFailure (ModelState state -> Bool
forall state. ModelState state -> Bool
noBalanceChanges (ModelState state -> Bool)
-> (Actions state -> ModelState state) -> Actions state -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContractModel state => Actions state -> ModelState state
forall state.
ContractModel state =>
Actions state -> ModelState state
stateAfter @state)
  where
    noBalanceChanges :: ModelState state -> Bool
noBalanceChanges ModelState state
s = (SymValue -> Bool) -> Map (AddressInEra Era) SymValue -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all SymValue -> Bool
symIsZero (ModelState state
s ModelState state
-> Getting
     (Map (AddressInEra Era) SymValue)
     (ModelState state)
     (Map (AddressInEra Era) SymValue)
-> Map (AddressInEra Era) SymValue
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (AddressInEra Era) SymValue)
  (ModelState state)
  (Map (AddressInEra Era) SymValue)
forall state.
Getter (ModelState state) (Map (AddressInEra Era) SymValue)
balanceChanges)

-- | Sanity check a `ContractModel`. Ensures that all assertions in
-- the property generation succeed.
propSanityCheckAssertions :: forall state. ContractModel state => Actions state -> QC.Property
propSanityCheckAssertions :: Actions state -> Property
propSanityCheckAssertions Actions state
as = ModelState state -> Property
forall state. ModelState state -> Property
asserts (ModelState state -> Property) -> ModelState state -> Property
forall a b. (a -> b) -> a -> b
$ Actions state -> ModelState state
forall state.
ContractModel state =>
Actions state -> ModelState state
stateAfter Actions state
as



-- | Run `Actions` in the emulator and check that the model and the emulator agree on the final
--   wallet balance changes. Starts with 100.000.000 Ada for each wallet and the default parameters.
propRunActions_ :: forall state.
    RunModel state EmulatorM
    => Actions state                           -- ^ The actions to run
    -> Property
propRunActions_ :: Actions state -> Property
propRunActions_ = (ModelState state -> EmulatorLogs -> Maybe String)
-> Actions state -> Property
forall state.
RunModel state EmulatorM =>
(ModelState state -> EmulatorLogs -> Maybe String)
-> Actions state -> Property
propRunActions (\ModelState state
_ EmulatorLogs
_ -> Maybe String
forall a. Maybe a
Nothing)

propRunActions :: forall state.
    RunModel state EmulatorM
    => (ModelState state -> EmulatorLogs -> Maybe String) -- ^ Predicate to check at the end of execution
    -> Actions state                           -- ^ The actions to run
    -> Property
propRunActions :: (ModelState state -> EmulatorLogs -> Maybe String)
-> Actions state -> Property
propRunActions = Map (AddressInEra Era) Value
-> Params
-> (ModelState state -> EmulatorLogs -> Maybe String)
-> Actions state
-> Property
forall state.
RunModel state EmulatorM =>
Map (AddressInEra Era) Value
-> Params
-> (ModelState state -> EmulatorLogs -> Maybe String)
-> Actions state
-> Property
propRunActionsWithOptions ([(AddressInEra Era, Value)] -> Map (AddressInEra Era) Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(AddressInEra Era, Value)] -> Map (AddressInEra Era) Value)
-> [(AddressInEra Era, Value)] -> Map (AddressInEra Era) Value
forall a b. (a -> b) -> a -> b
$ (, Rational -> Value
Value.adaValueOf Rational
100_000_000) (AddressInEra Era -> (AddressInEra Era, Value))
-> [AddressInEra Era] -> [(AddressInEra Era, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AddressInEra Era]
knownAddresses) Params
forall a. Default a => a
def

propRunActionsWithOptions :: forall state.
    RunModel state EmulatorM
    => Map CardanoAddress C.Value              -- ^ Initial distribution of funds
    -> E.Params                                -- ^ Node parameters
    -> (ModelState state -> EmulatorLogs -> Maybe String) -- ^ Predicate to check at the end of execution
    -> Actions state                           -- ^ The actions to run
    -> Property
propRunActionsWithOptions :: Map (AddressInEra Era) Value
-> Params
-> (ModelState state -> EmulatorLogs -> Maybe String)
-> Actions state
-> Property
propRunActionsWithOptions Map (AddressInEra Era) Value
initialDist Params
params ModelState state -> EmulatorLogs -> Maybe String
predicate Actions state
actions =
    ModelState state -> Property
forall state. ModelState state -> Property
asserts ModelState state
finalState Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
QC..&&.
    (RunMonad EmulatorM Property -> Property)
-> PropertyM (RunMonad EmulatorM) Property -> Property
forall a (m :: * -> *).
(Testable a, Monad m) =>
(m Property -> Property) -> PropertyM m a -> Property
monadic RunMonad EmulatorM Property -> Property
runFinalPredicate PropertyM (RunMonad EmulatorM) Property
monadicPredicate
    where
        finalState :: ModelState state
finalState = Actions state -> ModelState state
forall state.
ContractModel state =>
Actions state -> ModelState state
stateAfter Actions state
actions
        ps :: ProtocolParameters
ps = Params -> ProtocolParameters
pProtocolParams Params
params

        monadicPredicate :: PropertyM (RunMonad EmulatorM) Property
        monadicPredicate :: PropertyM (RunMonad EmulatorM) Property
monadicPredicate = do
            ContractModelResult state
result <- Actions state
-> PropertyM (RunMonad EmulatorM) (ContractModelResult state)
forall state (m :: * -> *).
(ContractModel state, RunModel state m, HasChainIndex m) =>
Actions state -> PropertyM (RunMonad m) (ContractModelResult state)
runContractModel Actions state
actions
            Property -> PropertyM (RunMonad EmulatorM) Property
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> PropertyM (RunMonad EmulatorM) Property)
-> Property -> PropertyM (RunMonad EmulatorM) Property
forall a b. (a -> b) -> a -> b
$ ContractModelResult state -> Property
balanceChangePredicate ContractModelResult state
result

        runFinalPredicate :: RunMonad EmulatorM Property
                          -> Property
        runFinalPredicate :: RunMonad EmulatorM Property -> Property
runFinalPredicate RunMonad EmulatorM Property
contract =
          let (Either EmulatorError Property
res, EmulatorLogs
lg) = (\RWS
  Params EmulatorLogs EmulatorState (Either EmulatorError Property)
m -> RWS
  Params EmulatorLogs EmulatorState (Either EmulatorError Property)
-> Params
-> EmulatorState
-> (Either EmulatorError Property, EmulatorLogs)
forall r w s a. RWS r w s a -> r -> s -> (a, w)
evalRWS RWS
  Params EmulatorLogs EmulatorState (Either EmulatorError Property)
m Params
params (Map (AddressInEra Era) Value -> EmulatorState
emptyEmulatorStateWithInitialDist Map (AddressInEra Era) Value
initialDist))
                              (RWS
   Params EmulatorLogs EmulatorState (Either EmulatorError Property)
 -> (Either EmulatorError Property, EmulatorLogs))
-> (RunMonad EmulatorM Property
    -> RWS
         Params EmulatorLogs EmulatorState (Either EmulatorError Property))
-> RunMonad EmulatorM Property
-> (Either EmulatorError Property, EmulatorLogs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT
  EmulatorError
  (RWST Params EmulatorLogs EmulatorState Identity)
  Property
-> RWS
     Params EmulatorLogs EmulatorState (Either EmulatorError Property)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
                              (ExceptT
   EmulatorError
   (RWST Params EmulatorLogs EmulatorState Identity)
   Property
 -> RWS
      Params EmulatorLogs EmulatorState (Either EmulatorError Property))
-> (RunMonad EmulatorM Property
    -> ExceptT
         EmulatorError
         (RWST Params EmulatorLogs EmulatorState Identity)
         Property)
-> RunMonad EmulatorM Property
-> RWS
     Params EmulatorLogs EmulatorState (Either EmulatorError Property)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Property, SymIndex) -> Property)
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     (Property, SymIndex)
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     Property
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Property, SymIndex) -> Property
forall a b. (a, b) -> a
fst
                              (ExceptT
   EmulatorError
   (RWST Params EmulatorLogs EmulatorState Identity)
   (Property, SymIndex)
 -> ExceptT
      EmulatorError
      (RWST Params EmulatorLogs EmulatorState Identity)
      Property)
-> (RunMonad EmulatorM Property
    -> ExceptT
         EmulatorError
         (RWST Params EmulatorLogs EmulatorState Identity)
         (Property, SymIndex))
-> RunMonad EmulatorM Property
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT SymIndex EmulatorM Property
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     (Property, SymIndex)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT
                              (WriterT SymIndex EmulatorM Property
 -> ExceptT
      EmulatorError
      (RWST Params EmulatorLogs EmulatorState Identity)
      (Property, SymIndex))
-> (RunMonad EmulatorM Property
    -> WriterT SymIndex EmulatorM Property)
-> RunMonad EmulatorM Property
-> ExceptT
     EmulatorError
     (RWST Params EmulatorLogs EmulatorState Identity)
     (Property, SymIndex)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RunMonad EmulatorM Property -> WriterT SymIndex EmulatorM Property
forall (m :: * -> *) a. RunMonad m a -> WriterT SymIndex m a
unRunMonad
                              (RunMonad EmulatorM Property
 -> (Either EmulatorError Property, EmulatorLogs))
-> RunMonad EmulatorM Property
-> (Either EmulatorError Property, EmulatorLogs)
forall a b. (a -> b) -> a -> b
$ RunMonad EmulatorM Property
contract
          in PropertyM IO Property -> Property
forall a. Testable a => PropertyM IO a -> Property
monadicIO (PropertyM IO Property -> Property)
-> PropertyM IO Property -> Property
forall a b. (a -> b) -> a -> b
$
              let logs :: String
logs = Text -> String
Text.unpack (EmulatorLogs -> Text
renderLogs EmulatorLogs
lg)
              in case (Either EmulatorError Property
res, ModelState state -> EmulatorLogs -> Maybe String
predicate ModelState state
finalState EmulatorLogs
lg) of
                (Left EmulatorError
err, Maybe String
_) -> Property -> PropertyM IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
logs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EmulatorError -> String
forall a. Show a => a -> String
show EmulatorError
err)
                                        (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                (Right Property
prop, Just String
msg) -> Property -> PropertyM IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
logs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg) Property
prop
                (Right Property
prop, Maybe String
Nothing) -> Property -> PropertyM IO Property
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
logs Property
prop

        balanceChangePredicate :: ContractModelResult state -> Property
        balanceChangePredicate :: ContractModelResult state -> Property
balanceChangePredicate ContractModelResult state
result =
          let prettyAddr :: a -> String
prettyAddr a
a = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (a -> String
forall a. Show a => a -> String
show a
a) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (a -> String
forall a. Show a => a -> String
show a
a) [(String, String)]
prettyWalletNames
          in BalanceChangeOptions -> ContractModelResult state -> Property
forall state.
BalanceChangeOptions -> ContractModelResult state -> Property
assertBalanceChangesMatch (Bool
-> FeeCalculation
-> ProtocolParameters
-> (AddressInEra Era -> String)
-> BalanceChangeOptions
BalanceChangeOptions Bool
False FeeCalculation
signerPaysFees ProtocolParameters
ps AddressInEra Era -> String
forall a. Show a => a -> String
prettyAddr) ContractModelResult state
result

prettyWalletNames :: [(String, String)]
prettyWalletNames :: [(String, String)]
prettyWalletNames = [ (AddressInEra Era -> String
forall a. Show a => a -> String
show AddressInEra Era
addr, String
"Wallet " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nr) | (AddressInEra Era
addr, Int
nr) <- [AddressInEra Era] -> [Int] -> [(AddressInEra Era, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [AddressInEra Era]
knownAddresses [Int
1..Int
10::Int]]

-- Note `chainStateToChainIndex` below is moved from `Plutus.Contract.Test.ContractModel.Internal`
-- and could use some serious clean up. Mostly to get rid of the conversions to/from plutus types.

-- Note, we don't store the genesis transaction in the index but put it in the before state
-- instead to avoid showing that as a balance change in the models.
chainStateToChainIndex :: CardanoAPI.NetworkId -> E.ChainState -> ChainIndex
chainStateToChainIndex :: NetworkId -> ChainState -> ChainIndex
chainStateToChainIndex NetworkId
nid ChainState
cs =
            ChainIndex :: [TxInState] -> NetworkId -> ChainIndex
ChainIndex { -- The Backwards order
                         transactions :: [TxInState]
transactions = ([TxInState], ChainState) -> [TxInState]
forall a b. (a, b) -> a
fst (([TxInState], ChainState) -> [TxInState])
-> ([TxInState], ChainState) -> [TxInState]
forall a b. (a -> b) -> a -> b
$ ([OnChainTx]
 -> ([TxInState], ChainState) -> ([TxInState], ChainState))
-> ([TxInState], ChainState)
-> [[OnChainTx]]
-> ([TxInState], ChainState)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [OnChainTx]
-> ([TxInState], ChainState) -> ([TxInState], ChainState)
addBlock ([], ChainState
beforeState)
                                                             ( [[OnChainTx]] -> [[OnChainTx]]
forall a. [a] -> [a]
reverse
                                                             ([[OnChainTx]] -> [[OnChainTx]])
-> (ChainState -> [[OnChainTx]]) -> ChainState -> [[OnChainTx]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[OnChainTx]] -> [[OnChainTx]]
forall a. Int -> [a] -> [a]
drop Int
1
                                                             ([[OnChainTx]] -> [[OnChainTx]])
-> (ChainState -> [[OnChainTx]]) -> ChainState -> [[OnChainTx]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[OnChainTx]] -> [[OnChainTx]]
forall a. [a] -> [a]
reverse
                                                             ([[OnChainTx]] -> [[OnChainTx]])
-> (ChainState -> [[OnChainTx]]) -> ChainState -> [[OnChainTx]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [[OnChainTx]] ChainState [[OnChainTx]]
-> ChainState -> [[OnChainTx]]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [[OnChainTx]] ChainState [[OnChainTx]]
Lens' ChainState [[OnChainTx]]
E.chainNewestFirst
                                                             (ChainState -> [[OnChainTx]]) -> ChainState -> [[OnChainTx]]
forall a b. (a -> b) -> a -> b
$ ChainState
cs)
                       , networkId :: NetworkId
networkId = NetworkId
nid
                       }
    where beforeState :: ChainState
beforeState = ChainState :: SlotNo -> UTxO Era -> ChainState
CM.ChainState { slot :: SlotNo
slot = SlotNo
0
                                      , utxo :: UTxO Era
utxo = [[OnChainTx]] -> UTxO Era
Index.initialise (Int -> [[OnChainTx]] -> [[OnChainTx]]
forall a. Int -> [a] -> [a]
take Int
1 ([[OnChainTx]] -> [[OnChainTx]]) -> [[OnChainTx]] -> [[OnChainTx]]
forall a b. (a -> b) -> a -> b
$ [[OnChainTx]] -> [[OnChainTx]]
forall a. [a] -> [a]
reverse (ChainState
cs ChainState
-> Getting [[OnChainTx]] ChainState [[OnChainTx]] -> [[OnChainTx]]
forall s a. s -> Getting a s a -> a
^. Getting [[OnChainTx]] ChainState [[OnChainTx]]
Lens' ChainState [[OnChainTx]]
E.chainNewestFirst))
                                      }
          addBlock :: [OnChainTx]
-> ([TxInState], ChainState) -> ([TxInState], ChainState)
addBlock [OnChainTx]
block ([TxInState]
txs, ChainState
state) =
            ( [TxInState]
txs [TxInState] -> [TxInState] -> [TxInState]
forall a. [a] -> [a] -> [a]
++ [ Tx Era -> ChainState -> Bool -> TxInState
TxInState ((\(CardanoEmulatorEraTx Tx Era
tx') -> Tx Era
tx') (CardanoTx -> Tx Era)
-> (OnChainTx -> CardanoTx) -> OnChainTx -> Tx Era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainTx -> CardanoTx
unOnChain (OnChainTx -> Tx Era) -> OnChainTx -> Tx Era
forall a b. (a -> b) -> a -> b
$ OnChainTx
tx)
                                  ChainState
state
                                  (OnChainTx -> Bool
onChainTxIsValid OnChainTx
tx)
                      | OnChainTx
tx <- [OnChainTx]
block ]
            , [OnChainTx] -> ChainState -> ChainState
updateState [OnChainTx]
block ChainState
state )

          updateState :: [OnChainTx] -> CM.ChainState -> CM.ChainState
          updateState :: [OnChainTx] -> ChainState -> ChainState
updateState [OnChainTx]
block ChainState
state =
            ChainState :: SlotNo -> UTxO Era -> ChainState
CM.ChainState{ slot :: SlotNo
slot = ChainState -> SlotNo
slot ChainState
state SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1
                         , utxo :: UTxO Era
utxo = [OnChainTx] -> UTxO Era -> UTxO Era
Index.insertBlock [OnChainTx]
block (ChainState -> UTxO Era
utxo ChainState
state)
                         }

chainStateToContractModelChainState :: E.ChainState -> CM.ChainState
chainStateToContractModelChainState :: ChainState -> ChainState
chainStateToContractModelChainState ChainState
cst =
  ChainState :: SlotNo -> UTxO Era -> ChainState
ChainState { utxo :: UTxO Era
utxo = ChainState
cst ChainState -> Getting (UTxO Era) ChainState (UTxO Era) -> UTxO Era
forall s a. s -> Getting a s a -> a
^. Getting (UTxO Era) ChainState (UTxO Era)
Lens' ChainState (UTxO Era)
E.index
             , slot :: SlotNo
slot = Slot -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Slot -> SlotNo) -> Slot -> SlotNo
forall a b. (a -> b) -> a -> b
$ ChainState
cst ChainState -> Getting Slot ChainState Slot -> Slot
forall s a. s -> Getting a s a -> a
^. Getting Slot ChainState Slot
Lens' ChainState Slot
E.chainCurrentSlot
             }