{-# LANGUAGE DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Unit tests for our "hand-rolled" transactions as they are used in the
-- "direct" chain component.
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

-- | Generate a UTXO representing /commit/ outputs for a given list of `Party`.
-- NOTE: Uses 'testPolicyId' for the datum.
-- NOTE: We don't generate empty commits and it is used only at one place so perhaps move it?
-- FIXME: This function is very complicated and it's hard to understand it after a while
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

-- NOTE: Uses 'testPolicyId' for the datum.
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))