{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Hydra.Chain.Direct.TxSpec where
import Hydra.Cardano.Api
import Hydra.Chain.Direct.Tx
import Hydra.Prelude hiding (label)
import Test.Hydra.Prelude
import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Core (EraTx (getMinFeeTx))
import Data.Map qualified as Map
import Data.Text qualified as T
import Hydra.Cardano.Api.Pretty (renderTx)
import Hydra.Chain (HeadParameters (..))
import Hydra.Chain.Direct.Contract.Gen (genForParty)
import Hydra.Chain.Direct.Fixture (
epochInfo,
pparams,
systemStart,
testNetworkId,
testPolicyId,
testSeedInput,
)
import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
import Hydra.Chain.Direct.State (HasKnownUTxO (getKnownUTxO), genChainStateWithTx)
import Hydra.Chain.Direct.State qualified as Transition
import Hydra.Chain.Direct.Wallet (ErrCoverFee (..), coverFee_)
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.HeadTokens (headPolicyId, mkHeadTokenScript)
import Hydra.Contract.Initial qualified as Initial
import Hydra.Ledger.Cardano (adaOnly, genOneUTxOFor, genVerificationKey)
import Hydra.Ledger.Cardano.Evaluate (EvaluationReport, maxTxExecutionUnits)
import Hydra.Party (Party)
import Test.QuickCheck (
Property,
choose,
counterexample,
elements,
forAll,
forAllBlind,
label,
property,
vectorOf,
withMaxSuccess,
(===),
)
import Test.QuickCheck.Instances.Semigroup ()
import Test.QuickCheck.Monadic (monadicIO)
import Test.QuickCheck.Property (checkCoverage)
spec :: Spec
spec :: Spec
spec =
Spec -> Spec
forall a. SpecWith a -> SpecWith a
parallel (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"HeadSeed (cardano)" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
String -> (TxIn -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"headSeedToTxIn . txInToHeadSeed === id" ((TxIn -> Property) -> Spec) -> (TxIn -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxIn
txIn -> do
let headSeed :: HeadSeed
headSeed = TxIn -> HeadSeed
txInToHeadSeed TxIn
txIn
HeadSeed -> Maybe TxIn
forall (m :: * -> *). MonadFail m => HeadSeed -> m TxIn
headSeedToTxIn HeadSeed
headSeed Maybe TxIn -> Maybe TxIn -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== TxIn -> Maybe TxIn
forall a. a -> Maybe a
Just TxIn
txIn
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (HeadSeed -> String
forall b a. (Show a, IsString b) => a -> b
show HeadSeed
headSeed)
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"HeadId (cardano)" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
String -> (PolicyId -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"headIdToPolicyId . mkHeadId === id" ((PolicyId -> Property) -> Spec) -> (PolicyId -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \PolicyId
pid -> do
let headId :: HeadId
headId = PolicyId -> HeadId
mkHeadId PolicyId
pid
HeadId -> Maybe PolicyId
forall (m :: * -> *). MonadFail m => HeadId -> m PolicyId
headIdToPolicyId HeadId
headId Maybe PolicyId -> Maybe PolicyId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== PolicyId -> Maybe PolicyId
forall a. a -> Maybe a
Just PolicyId
pid
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (HeadId -> String
forall b a. (Show a, IsString b) => a -> b
show HeadId
headId)
String -> (TxIn -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"curencySymbolToHeadId . headIdToCurrencySymbol === id" ((TxIn -> Property) -> Spec) -> (TxIn -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$ \TxIn
txIn -> 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
$ do
let headId :: HeadId
headId = PolicyId -> HeadId
mkHeadId (PolicyId -> HeadId) -> PolicyId -> HeadId
forall a b. (a -> b) -> a -> b
$ TxIn -> PolicyId
headPolicyId TxIn
txIn
let cs :: CurrencySymbol
cs = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
HeadId
headId' <- CurrencySymbol -> PropertyM IO HeadId
forall (m :: * -> *). MonadFail m => CurrencySymbol -> m HeadId
currencySymbolToHeadId CurrencySymbol
cs
Property -> PropertyM IO Property
forall a. a -> PropertyM IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> PropertyM IO Property)
-> Property -> PropertyM IO Property
forall a b. (a -> b) -> a -> b
$ HeadId
headId' HeadId -> HeadId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== HeadId
headId
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"observeHeadTx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"All valid transitions for all possible states can be observed." (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Gen (ChainContext, ChainState, Tx Era, ChainTransition)
-> ((ChainContext, ChainState, Tx Era, ChainTransition)
-> Property)
-> Property
forall prop a. Testable prop => Gen a -> (a -> prop) -> Property
forAllBlind Gen (ChainContext, ChainState, Tx Era, ChainTransition)
genChainStateWithTx (((ChainContext, ChainState, Tx Era, ChainTransition) -> Property)
-> Property)
-> ((ChainContext, ChainState, Tx Era, ChainTransition)
-> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \(ChainContext
_ctx, ChainState
st, Tx Era
tx, ChainTransition
transition) ->
[ChainTransition] -> Property -> Property
forall a prop.
(Show a, Enum a, Bounded a, Typeable a, Testable prop) =>
[a] -> prop -> Property
genericCoverTable [ChainTransition
transition] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (ChainTransition -> String
forall b a. (Show a, IsString b) => a -> b
show ChainTransition
transition) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
let utxo :: UTxO
utxo = ChainState -> UTxO
forall a. HasKnownUTxO a => a -> UTxO
getKnownUTxO ChainState
st
in case NetworkId -> UTxO -> Tx Era -> HeadObservation
observeHeadTx NetworkId
testNetworkId UTxO
utxo Tx Era
tx of
HeadObservation
NoHeadTx -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
Init{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Init
Abort{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Abort
Commit{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Commit
CollectCom{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Collect
Close{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Close
Contest{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Contest
Fanout{} -> ChainTransition
transition ChainTransition -> ChainTransition -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== ChainTransition
Transition.Fanout
String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"collectComTx" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
String -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"cover fee correctly handles redeemers" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
Int
-> (TxIn
-> ContestationPeriod
-> NonEmpty Party
-> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> Property)
-> Property
forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
60 ((TxIn
-> ContestationPeriod
-> NonEmpty Party
-> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> Property)
-> Property)
-> (TxIn
-> ContestationPeriod
-> NonEmpty Party
-> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> Property)
-> Property
forall a b. (a -> b) -> a -> b
$ \TxIn
txIn ContestationPeriod
cperiod (Party
party :| [Party]
parties) Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
walletUTxO -> do
let allParties :: [Party]
allParties = Party
party Party -> [Party] -> [Party]
forall a. a -> [a] -> [a]
: [Party]
parties
cardanoKeys :: [VerificationKey PaymentKey]
cardanoKeys = Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
genForParty Gen (VerificationKey PaymentKey)
genVerificationKey (Party -> VerificationKey PaymentKey)
-> [Party] -> [VerificationKey PaymentKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
allParties
Gen (VerificationKey PaymentKey)
-> (VerificationKey PaymentKey -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll ([VerificationKey PaymentKey] -> Gen (VerificationKey PaymentKey)
forall a. [a] -> Gen a
elements [VerificationKey PaymentKey]
cardanoKeys) ((VerificationKey PaymentKey -> Property) -> Property)
-> (VerificationKey PaymentKey -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \VerificationKey PaymentKey
signer ->
Gen ScriptRegistry -> (ScriptRegistry -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen ScriptRegistry
genScriptRegistry ((ScriptRegistry -> Property) -> Property)
-> (ScriptRegistry -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ScriptRegistry
scriptRegistry ->
let params :: HeadParameters
params = ContestationPeriod -> [Party] -> HeadParameters
HeadParameters ContestationPeriod
cperiod [Party]
allParties
participants :: [OnChainId]
participants = VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId (VerificationKey PaymentKey -> OnChainId)
-> [VerificationKey PaymentKey] -> [OnChainId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VerificationKey PaymentKey]
cardanoKeys
tx :: Tx Era
tx = NetworkId -> TxIn -> [OnChainId] -> HeadParameters -> Tx Era
initTx NetworkId
testNetworkId TxIn
txIn [OnChainId]
participants HeadParameters
params
in case Tx Era -> Either NotAnInitReason InitObservation
observeInitTx Tx Era
tx of
Right InitObservation{[(TxIn, TxOut CtxUTxO)]
initials :: [(TxIn, TxOut CtxUTxO)]
$sel:initials:InitObservation :: InitObservation -> [(TxIn, TxOut CtxUTxO)]
initials, (TxIn, TxOut CtxUTxO)
initialThreadUTxO :: (TxIn, TxOut CtxUTxO)
$sel:initialThreadUTxO:InitObservation :: InitObservation -> (TxIn, TxOut CtxUTxO)
initialThreadUTxO} -> do
let lookupUTxO :: Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
lookupUTxO =
[Map TxIn (TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO)
forall a. Monoid a => [a] -> a
mconcat
[ [(TxIn, TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((TxIn, TxOut CtxUTxO)
initialThreadUTxO (TxIn, TxOut CtxUTxO)
-> [(TxIn, TxOut CtxUTxO)] -> [(TxIn, TxOut CtxUTxO)]
forall a. a -> [a] -> [a]
: [(TxIn, TxOut CtxUTxO)]
initials)
, UTxO -> Map TxIn (TxOut CtxUTxO)
forall out. UTxO' out -> Map TxIn out
UTxO.toMap (ScriptRegistry -> UTxO
registryUTxO ScriptRegistry
scriptRegistry)
]
Map TxIn (TxOut CtxUTxO)
-> (Map TxIn (TxOut CtxUTxO)
-> Map (TxIn StandardCrypto) (TxOut CtxUTxO))
-> Map (TxIn StandardCrypto) (TxOut CtxUTxO)
forall a b. a -> (a -> b) -> b
& (TxIn -> TxIn StandardCrypto)
-> Map TxIn (TxOut CtxUTxO)
-> Map (TxIn StandardCrypto) (TxOut CtxUTxO)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys TxIn -> TxIn StandardCrypto
toLedgerTxIn
Map (TxIn StandardCrypto) (TxOut CtxUTxO)
-> (Map (TxIn StandardCrypto) (TxOut CtxUTxO)
-> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto)))
-> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall a b. a -> (a -> b) -> b
& (TxOut CtxUTxO -> BabbageTxOut (BabbageEra StandardCrypto))
-> Map (TxIn StandardCrypto) (TxOut CtxUTxO)
-> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map TxOut CtxUTxO -> BabbageTxOut (BabbageEra StandardCrypto)
TxOut CtxUTxO -> TxOut (ShelleyLedgerEra Era)
toLedgerTxOut
in case UTxO
-> ScriptRegistry
-> VerificationKey PaymentKey
-> (TxIn, TxOut CtxUTxO)
-> PlutusScript
-> Map TxIn (TxOut CtxUTxO)
-> Map TxIn (TxOut CtxUTxO)
-> Either AbortTxError (Tx Era)
abortTx UTxO
forall a. Monoid a => a
mempty ScriptRegistry
scriptRegistry VerificationKey PaymentKey
signer (TxIn, TxOut CtxUTxO)
initialThreadUTxO (TxIn -> PlutusScript
mkHeadTokenScript TxIn
testSeedInput) ([(TxIn, TxOut CtxUTxO)] -> Map TxIn (TxOut CtxUTxO)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, TxOut CtxUTxO)]
initials) Map TxIn (TxOut CtxUTxO)
forall a. Monoid a => a
mempty of
Left AbortTxError
err ->
Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"AbortTx construction failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> AbortTxError -> String
forall b a. (Show a, IsString b) => a -> b
show AbortTxError
err)
Right (Tx Era -> Tx (ShelleyLedgerEra Era)
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
AlonzoEraTx (ShelleyLedgerEra era)) =>
Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx -> Tx (ShelleyLedgerEra Era)
txAbort) ->
case PParams (ShelleyLedgerEra Era)
-> SystemStart
-> EpochInfo (Either Text)
-> Map (TxIn StandardCrypto) (TxOut (ShelleyLedgerEra Era))
-> Map (TxIn StandardCrypto) (TxOut (ShelleyLedgerEra Era))
-> AlonzoTx (ShelleyLedgerEra Era)
-> Either ErrCoverFee (AlonzoTx (ShelleyLedgerEra Era))
coverFee_ PParams (ShelleyLedgerEra Era)
pparams SystemStart
systemStart EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
epochInfo Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
Map (TxIn StandardCrypto) (TxOut (ShelleyLedgerEra Era))
lookupUTxO Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
Map (TxIn StandardCrypto) (TxOut (ShelleyLedgerEra Era))
walletUTxO AlonzoTx (ShelleyLedgerEra Era)
Tx (ShelleyLedgerEra Era)
txAbort of
Left ErrCoverFee
err ->
Bool
True
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
label
( case ErrCoverFee
err of
ErrNoFuelUTxOFound{} -> String
"No fuel UTxO found"
ErrNotEnoughFunds{} -> String
"Not enough funds"
ErrUnknownInput{} -> String
"Unknown input"
ErrScriptExecutionFailed{} -> String
"Script(s) execution failed"
ErrTranslationError{} -> String
"Transaction context translation error"
)
Right AlonzoTx (ShelleyLedgerEra Era)
ledgerTx ->
let actualExecutionCost :: Coin
actualExecutionCost = PParams (BabbageEra StandardCrypto)
-> Tx (BabbageEra StandardCrypto) -> Coin
forall era. EraTx era => PParams era -> Tx era -> Coin
getMinFeeTx PParams (ShelleyLedgerEra Era)
PParams (BabbageEra StandardCrypto)
pparams AlonzoTx (ShelleyLedgerEra Era)
Tx (BabbageEra StandardCrypto)
ledgerTx
fee :: Coin
fee = Tx Era -> Coin
forall era. Tx era -> Coin
txFee' Tx Era
apiTx
apiTx :: Tx Era
apiTx = Tx (ShelleyLedgerEra Era) -> Tx Era
fromLedgerTx AlonzoTx (ShelleyLedgerEra Era)
Tx (ShelleyLedgerEra Era)
ledgerTx
in Coin
actualExecutionCost Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Coin
Coin Integer
0 Bool -> Bool -> Bool
&& Coin
fee Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
actualExecutionCost
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
label String
"Ok"
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Execution cost: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
actualExecutionCost)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Fee: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Coin -> String
forall b a. (Show a, IsString b) => a -> b
show Coin
fee)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Tx: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Tx Era -> String
forall b a. (Show a, IsString b) => a -> b
show Tx Era
apiTx)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Input utxo: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> String
forall b a. (Show a, IsString b) => a -> b
show (Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
walletUTxO Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
-> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
forall a. Semigroup a => a -> a -> a
<> Map
(TxIn StandardCrypto) (BabbageTxOut (BabbageEra StandardCrypto))
lookupUTxO))
Left NotAnInitReason
e ->
Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Failed to construct and observe init tx."
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Tx Era -> String
renderTx Tx Era
tx)
Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (NotAnInitReason -> String
forall b a. (Show a, IsString b) => a -> b
show NotAnInitReason
e)
withinTxExecutionBudget :: EvaluationReport -> Property
withinTxExecutionBudget :: EvaluationReport -> Property
withinTxExecutionBudget EvaluationReport
report =
(Natural
totalMem Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxMem Bool -> Bool -> Bool
&& Natural
totalCpu Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxCpu)
Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
( String
"Ex. Cost Limits exceeded, mem: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
totalMem
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
maxMem
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", cpu: "
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
totalCpu
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/"
String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall b a. (Show a, IsString b) => a -> b
show Natural
maxCpu
)
where
budgets :: [ExecutionUnits]
budgets = [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. [Either a b] -> [b]
rights ([Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits])
-> [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
report
totalMem :: Natural
totalMem = [Natural] -> Natural
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> Natural
executionMemory (ExecutionUnits -> Natural) -> [ExecutionUnits] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExecutionUnits]
budgets
totalCpu :: Natural
totalCpu = [Natural] -> Natural
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> Natural
executionSteps (ExecutionUnits -> Natural) -> [ExecutionUnits] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExecutionUnits]
budgets
ExecutionUnits
{ executionMemory :: ExecutionUnits -> Natural
executionMemory = Natural
maxMem
, executionSteps :: ExecutionUnits -> Natural
executionSteps = Natural
maxCpu
} = ExecutionUnits
maxTxExecutionUnits
generateCommitUTxOs :: [Party] -> Gen (Map.Map TxIn (TxOut CtxUTxO, UTxO))
generateCommitUTxOs :: [Party] -> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
generateCommitUTxOs [Party]
parties = do
[TxIn]
txins <- Int -> Gen TxIn -> Gen [TxIn]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
parties) (forall a. Arbitrary a => Gen a
arbitrary @TxIn)
let vks :: [(VerificationKey PaymentKey, Party)]
vks = (\Party
p -> (Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
`genForParty` Party
p, Party
p)) (Party -> (VerificationKey PaymentKey, Party))
-> [Party] -> [(VerificationKey PaymentKey, Party)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party]
parties
[UTxO]
committedUTxO <-
Int -> Gen UTxO -> Gen [UTxO]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
parties) (Gen UTxO -> Gen [UTxO]) -> Gen UTxO -> Gen [UTxO]
forall a b. (a -> b) -> a -> b
$
(TxOut CtxUTxO -> TxOut CtxUTxO) -> UTxO -> UTxO
forall a b. (a -> b) -> UTxO' a -> UTxO' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxOut CtxUTxO -> TxOut CtxUTxO
adaOnly (UTxO -> UTxO) -> Gen UTxO -> Gen UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (VerificationKey PaymentKey -> Gen UTxO
genOneUTxOFor (VerificationKey PaymentKey -> Gen UTxO)
-> Gen (VerificationKey PaymentKey) -> Gen UTxO
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Gen (VerificationKey PaymentKey)
forall a. Arbitrary a => Gen a
arbitrary)
let commitUTxO :: [(TxIn, (TxOut CtxUTxO, UTxO))]
commitUTxO =
[TxIn]
-> [(TxOut CtxUTxO, UTxO)] -> [(TxIn, (TxOut CtxUTxO, UTxO))]
forall a b. [a] -> [b] -> [(a, b)]
zip [TxIn]
txins ([(TxOut CtxUTxO, UTxO)] -> [(TxIn, (TxOut CtxUTxO, UTxO))])
-> [(TxOut CtxUTxO, UTxO)] -> [(TxIn, (TxOut CtxUTxO, UTxO))]
forall a b. (a -> b) -> a -> b
$
((VerificationKey PaymentKey, Party)
-> UTxO -> (TxOut CtxUTxO, UTxO))
-> ((VerificationKey PaymentKey, Party), UTxO)
-> (TxOut CtxUTxO, UTxO)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (VerificationKey PaymentKey, Party)
-> UTxO -> (TxOut CtxUTxO, UTxO)
mkCommitUTxO (((VerificationKey PaymentKey, Party), UTxO)
-> (TxOut CtxUTxO, UTxO))
-> [((VerificationKey PaymentKey, Party), UTxO)]
-> [(TxOut CtxUTxO, UTxO)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(VerificationKey PaymentKey, Party)]
-> [UTxO] -> [((VerificationKey PaymentKey, Party), UTxO)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(VerificationKey PaymentKey, Party)]
vks [UTxO]
committedUTxO
Map TxIn (TxOut CtxUTxO, UTxO)
-> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxIn (TxOut CtxUTxO, UTxO)
-> Gen (Map TxIn (TxOut CtxUTxO, UTxO)))
-> Map TxIn (TxOut CtxUTxO, UTxO)
-> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
forall a b. (a -> b) -> a -> b
$ [(TxIn, (TxOut CtxUTxO, UTxO))] -> Map TxIn (TxOut CtxUTxO, UTxO)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxIn, (TxOut CtxUTxO, UTxO))]
commitUTxO
where
mkCommitUTxO :: (VerificationKey PaymentKey, Party) -> UTxO -> (TxOut CtxUTxO, UTxO)
mkCommitUTxO :: (VerificationKey PaymentKey, Party)
-> UTxO -> (TxOut CtxUTxO, UTxO)
mkCommitUTxO (VerificationKey PaymentKey
vk, Party
party) UTxO
utxo =
( TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext (TxOut CtxTx Era -> TxOut CtxUTxO)
-> TxOut CtxTx Era -> TxOut CtxUTxO
forall a b. (a -> b) -> a -> b
$
AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
(forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
testNetworkId PlutusScript
forall {lang}. PlutusScript lang
commitScript)
Value
commitValue
(Datum -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline Datum
commitDatum)
ReferenceScript
ReferenceScriptNone
, UTxO
utxo
)
where
commitValue :: Value
commitValue =
[Value] -> Value
forall a. Monoid a => [a] -> a
mconcat
[ Coin -> Value
lovelaceToValue (Integer -> Coin
Coin Integer
2000000)
, (TxOut CtxUTxO -> Value) -> UTxO -> Value
forall m a. Monoid m => (a -> m) -> UTxO' a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO -> Value
forall ctx. TxOut ctx -> Value
txOutValue UTxO
utxo
, [(AssetId, Quantity)] -> Value
valueFromList
[ (PolicyId -> AssetName -> AssetId
AssetId PolicyId
testPolicyId (VerificationKey PaymentKey -> AssetName
assetNameFromVerificationKey VerificationKey PaymentKey
vk), Quantity
1)
]
]
commitScript :: PlutusScript lang
commitScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Commit.validatorScript
commitDatum :: Datum
commitDatum = Party -> UTxO -> CurrencySymbol -> Datum
mkCommitDatum Party
party UTxO
utxo (PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
testPolicyId)
prettyEvaluationReport :: EvaluationReport -> String
prettyEvaluationReport :: EvaluationReport -> String
prettyEvaluationReport (EvaluationReport
-> [(ScriptWitnessIndex,
Either ScriptExecutionError ExecutionUnits)]
forall k a. Map k a -> [(k, a)]
Map.toList -> [(ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)]
xs) =
String
"Script Evaluation(s):\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ((ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
-> String
prettyKeyValue ((ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
-> String)
-> [(ScriptWitnessIndex,
Either ScriptExecutionError ExecutionUnits)]
-> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)]
xs)
where
prettyKeyValue :: (ScriptWitnessIndex, Either ScriptExecutionError ExecutionUnits)
-> String
prettyKeyValue (ScriptWitnessIndex
ptr, Either ScriptExecutionError ExecutionUnits
result) =
Text -> String
forall a. ToString a => a -> String
toString (Text
" - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptWitnessIndex -> Text
forall b a. (Show a, IsString b) => a -> b
show ScriptWitnessIndex
ptr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either ScriptExecutionError ExecutionUnits -> Text
prettyResult Either ScriptExecutionError ExecutionUnits
result)
prettyResult :: Either ScriptExecutionError ExecutionUnits -> Text
prettyResult =
(ScriptExecutionError -> Text)
-> (ExecutionUnits -> Text)
-> Either ScriptExecutionError ExecutionUnits
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\n" Text
" " (Text -> Text)
-> (ScriptExecutionError -> Text) -> ScriptExecutionError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptExecutionError -> Text
forall b a. (Show a, IsString b) => a -> b
show) ExecutionUnits -> Text
forall b a. (Show a, IsString b) => a -> b
show
genAbortableOutputs :: [Party] -> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
genAbortableOutputs :: [Party]
-> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
genAbortableOutputs [Party]
parties =
Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
go
where
go :: Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
go = do
([Party]
initParties, [Party]
commitParties) <- (Int -> [Party] -> ([Party], [Party])
forall a. Int -> [a] -> ([a], [a])
`splitAt` [Party]
parties) (Int -> ([Party], [Party])) -> Gen Int -> Gen ([Party], [Party])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, [Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
parties)
[(TxIn, TxOut CtxUTxO)]
initials <- (Party -> Gen (TxIn, TxOut CtxUTxO))
-> [Party] -> Gen [(TxIn, TxOut CtxUTxO)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Party -> Gen (TxIn, TxOut CtxUTxO)
genInitial [Party]
initParties
[(TxIn, TxOut CtxUTxO, UTxO)]
commits <- ((TxIn, (TxOut CtxUTxO, UTxO)) -> (TxIn, TxOut CtxUTxO, UTxO))
-> [(TxIn, (TxOut CtxUTxO, UTxO))] -> [(TxIn, TxOut CtxUTxO, UTxO)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(TxIn
a, (TxOut CtxUTxO
b, UTxO
c)) -> (TxIn
a, TxOut CtxUTxO
b, UTxO
c)) ([(TxIn, (TxOut CtxUTxO, UTxO))] -> [(TxIn, TxOut CtxUTxO, UTxO)])
-> (Map TxIn (TxOut CtxUTxO, UTxO)
-> [(TxIn, (TxOut CtxUTxO, UTxO))])
-> Map TxIn (TxOut CtxUTxO, UTxO)
-> [(TxIn, TxOut CtxUTxO, UTxO)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map TxIn (TxOut CtxUTxO, UTxO) -> [(TxIn, (TxOut CtxUTxO, UTxO))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map TxIn (TxOut CtxUTxO, UTxO) -> [(TxIn, TxOut CtxUTxO, UTxO)])
-> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
-> Gen [(TxIn, TxOut CtxUTxO, UTxO)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Party] -> Gen (Map TxIn (TxOut CtxUTxO, UTxO))
generateCommitUTxOs [Party]
commitParties
([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
-> Gen ([(TxIn, TxOut CtxUTxO)], [(TxIn, TxOut CtxUTxO, UTxO)])
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(TxIn, TxOut CtxUTxO)]
initials, [(TxIn, TxOut CtxUTxO, UTxO)]
commits)
genInitial :: Party -> Gen (TxIn, TxOut CtxUTxO)
genInitial Party
p =
VerificationKey PaymentKey -> TxIn -> (TxIn, TxOut CtxUTxO)
mkInitial (Gen (VerificationKey PaymentKey)
genVerificationKey Gen (VerificationKey PaymentKey)
-> Party -> VerificationKey PaymentKey
forall a. Gen a -> Party -> a
`genForParty` Party
p) (TxIn -> (TxIn, TxOut CtxUTxO))
-> Gen TxIn -> Gen (TxIn, TxOut CtxUTxO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxIn
forall a. Arbitrary a => Gen a
arbitrary
mkInitial ::
VerificationKey PaymentKey ->
TxIn ->
(TxIn, TxOut CtxUTxO)
mkInitial :: VerificationKey PaymentKey -> TxIn -> (TxIn, TxOut CtxUTxO)
mkInitial VerificationKey PaymentKey
vk TxIn
txin =
( TxIn
txin
, VerificationKey PaymentKey -> TxOut CtxUTxO
initialTxOut VerificationKey PaymentKey
vk
)
initialTxOut :: VerificationKey PaymentKey -> TxOut CtxUTxO
initialTxOut :: VerificationKey PaymentKey -> TxOut CtxUTxO
initialTxOut VerificationKey PaymentKey
vk =
TxOut CtxTx Era -> TxOut CtxUTxO
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
forall {k} (f :: * -> k -> *) (era :: k).
ToUTxOContext f =>
f CtxTx era -> f CtxUTxO era
toUTxOContext (TxOut CtxTx Era -> TxOut CtxUTxO)
-> TxOut CtxTx Era -> TxOut CtxUTxO
forall a b. (a -> b) -> a -> b
$
AddressInEra
-> Value -> TxOutDatum CtxTx -> ReferenceScript -> TxOut CtxTx Era
forall ctx.
AddressInEra
-> Value -> TxOutDatum ctx -> ReferenceScript -> TxOut ctx
TxOut
(forall lang era.
(IsShelleyBasedEra era, IsPlutusScriptLanguage lang) =>
NetworkId -> PlutusScript lang -> AddressInEra era
mkScriptAddress @PlutusScriptV2 NetworkId
testNetworkId PlutusScript
forall {lang}. PlutusScript lang
initialScript)
([(AssetId, Quantity)] -> Value
valueFromList [(PolicyId -> AssetName -> AssetId
AssetId PolicyId
testPolicyId (VerificationKey PaymentKey -> AssetName
assetNameFromVerificationKey VerificationKey PaymentKey
vk), Quantity
1)])
(Datum -> TxOutDatum CtxTx
forall era a ctx.
(ToScriptData a, IsBabbageEraOnwards era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline Datum
initialDatum)
ReferenceScript
ReferenceScriptNone
initialScript :: PlutusScript lang
initialScript = SerialisedScript -> PlutusScript lang
forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript SerialisedScript
Initial.validatorScript
initialDatum :: Datum
initialDatum = CurrencySymbol -> Datum
Initial.datum (PolicyId -> CurrencySymbol
toPlutusCurrencySymbol PolicyId
testPolicyId)
assetNameFromVerificationKey :: VerificationKey PaymentKey -> AssetName
assetNameFromVerificationKey :: VerificationKey PaymentKey -> AssetName
assetNameFromVerificationKey =
OnChainId -> AssetName
onChainIdToAssetName (OnChainId -> AssetName)
-> (VerificationKey PaymentKey -> OnChainId)
-> VerificationKey PaymentKey
-> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId
fst3 :: (a, b, c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a
third :: (a, b, c) -> c
third :: forall a b c. (a, b, c) -> c
third (a
_, b
_, c
c) = c
c
drop2nd :: (a, b, c) -> (a, c)
drop2nd :: forall a b c. (a, b, c) -> (a, c)
drop2nd (a
a, b
_, c
c) = (a
a, c
c)
drop3rd :: (a, b, c) -> (a, b)
drop3rd :: forall a b c. (a, b, c) -> (a, b)
drop3rd (a
a, b
b, c
_) = (a
a, b
b)
tripleToPair :: (a, b, c) -> (a, (b, c))
tripleToPair :: forall a b c. (a, b, c) -> (a, (b, c))
tripleToPair (a
a, b
b, c
c) = (a
a, (b
b, c
c))