Merge pull request #1385 from input-output-hk/tx-trace-spec

Add a test suite for testing consecutive close/contest transactions

Author: ch1bo

hydra-node/hydra-node.cabal

@@ -290,6 +290,7 @@ test-suite tests
     Hydra.Chain.Direct.StateSpec
     Hydra.Chain.Direct.TimeHandleSpec
     Hydra.Chain.Direct.TxSpec
+    Hydra.Chain.Direct.TxTraceSpec
     Hydra.Chain.Direct.WalletSpec
     Hydra.ContestationPeriodSpec
     Hydra.CryptoSpec
@@ -363,6 +364,7 @@ test-suite tests
     , lens-aeson
     , plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib}  >=1.1.1.0
     , plutus-tx
+    , pretty-simple
     , QuickCheck
     , quickcheck-dynamic                                                >=3.3.1   && <3.4
     , quickcheck-instances

hydra-node/src/Hydra/Chain/Direct/State.hs

@@ -479,12 +479,9 @@ collect ctx headId headParameters utxoToCollect spendableUTxO = do
 
   ChainContext{networkId, ownVerificationKey, scriptRegistry} = ctx
 
--- | Construct a close transaction based on the 'OpenState' and a confirmed
--- snapshot.
---  - 'SlotNo' parameter will be used as the 'Tx' lower bound.
---  - 'PointInTime' parameter will be used as an upper validity bound and
---       will define the start of the contestation period.
--- NB: lower and upper bound slot difference should not exceed contestation period
+-- | Construct a close transaction spending the head output in given 'UTxO',
+-- head parameters, and a confirmed snapshot. NOTE: Lower and upper bound slot
+-- difference should not exceed contestation period.
 close ::
   ChainContext ->
   -- | Spendable UTxO containing head, initial and commit outputs
@@ -533,6 +530,7 @@ contest ::
   HeadId ->
   ContestationPeriod ->
   ConfirmedSnapshot Tx ->
+  -- | Current slot and posix time to be used as the contestation time.
   PointInTime ->
   Either ContestTxError Tx
 contest ctx spendableUTxO headId contestationPeriod confirmedSnapshot pointInTime = do

hydra-node/src/Hydra/Snapshot.hs

@@ -82,10 +82,12 @@ instance (Typeable tx, ToCBOR (UTxOType tx), ToCBOR (TxIdType tx)) => ToCBOR (Sn
 instance (Typeable tx, FromCBOR (UTxOType tx), FromCBOR (TxIdType tx)) => FromCBOR (Snapshot tx) where
   fromCBOR = Snapshot <$> fromCBOR <*> fromCBOR <*> fromCBOR <*> fromCBOR
 
--- | A snapshot that can be used to close a head with. Either the initial one, or when it was signed by all parties, i.e. it is confirmed.
+-- | A snapshot that can be used to close a head with. Either the initial one,
+-- or when it was signed by all parties, i.e. it is confirmed.
 data ConfirmedSnapshot tx
   = InitialSnapshot
-      { headId :: HeadId
+      { -- XXX: 'headId' is actually unused. Only 'getSnapshot' forces this to exist.
+        headId :: HeadId
       , initialUTxO :: UTxOType tx
       }
   | ConfirmedSnapshot

hydra-node/test/Hydra/Chain/Direct/Contract/Abort.hs

@@ -11,7 +11,6 @@ import Cardano.Api.UTxO qualified as UTxO
 import Data.List qualified as List
 import Data.Map qualified as Map
 import Hydra.Chain (HeadParameters (..))
-import Hydra.Chain.Direct.Contract.Gen (genForParty)
 import Hydra.Chain.Direct.Contract.Mutation (
   Mutation (..),
   SomeMutation (..),
@@ -42,7 +41,7 @@ import Hydra.Contract.Initial qualified as Initial
 import Hydra.Contract.InitialError (InitialError (STNotBurned))
 import Hydra.Ledger.Cardano (genAddressInEra, genVerificationKey)
 import Hydra.Party (Party, partyToChain)
-import Test.Hydra.Fixture (cperiod)
+import Test.Hydra.Fixture (cperiod, genForParty)
 import Test.QuickCheck (Property, choose, counterexample, elements, oneof, shuffle, suchThat)
 
 --

hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs

@@ -8,7 +8,7 @@ import Hydra.Prelude hiding (label)
 
 import Cardano.Api.UTxO as UTxO
 import Data.Maybe (fromJust)
-import Hydra.Chain.Direct.Contract.Gen (genForParty, genHash, genMintedOrBurnedValue)
+import Hydra.Chain.Direct.Contract.Gen (genHash, genMintedOrBurnedValue)
 import Hydra.Chain.Direct.Contract.Mutation (
   Mutation (..),
   SomeMutation (..),
@@ -24,7 +24,6 @@ import Hydra.Chain.Direct.Contract.Mutation (
   replaceSnapshotNumber,
   replaceUtxoHash,
  )
-import Hydra.Chain.Direct.Fixture (testNetworkId)
 import Hydra.Chain.Direct.Fixture qualified as Fixture
 import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
 import Hydra.Chain.Direct.TimeHandle (PointInTime)
@@ -47,7 +46,7 @@ import Hydra.Plutus.Orphans ()
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
 import PlutusLedgerApi.V1.Time (DiffMilliSeconds (..), fromMilliSeconds)
 import PlutusLedgerApi.V2 (BuiltinByteString, POSIXTime, PubKeyHash (PubKeyHash), toBuiltin)
-import Test.Hydra.Fixture (aliceSk, bobSk, carolSk)
+import Test.Hydra.Fixture (aliceSk, bobSk, carolSk, genForParty)
 import Test.QuickCheck (arbitrarySizedNatural, choose, elements, listOf1, oneof, suchThat)
 import Test.QuickCheck.Instances ()
 
@@ -136,7 +135,7 @@ healthyOpenHeadTxIn = generateWith arbitrary 42
 
 healthyOpenHeadTxOut :: TxOut CtxUTxO
 healthyOpenHeadTxOut =
-  mkHeadOutput testNetworkId Fixture.testPolicyId headTxOutDatum
+  mkHeadOutput Fixture.testNetworkId Fixture.testPolicyId headTxOutDatum
     & addParticipationTokens healthyParticipants
  where
   headTxOutDatum = toUTxOContext (mkTxOutDatumInline healthyOpenHeadDatum)
@@ -293,7 +292,7 @@ genCloseMutation :: (Tx, UTxO) -> Gen SomeMutation
 genCloseMutation (tx, _utxo) =
   oneof
     [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do
-        mutatedAddress <- genAddressInEra testNetworkId
+        mutatedAddress <- genAddressInEra Fixture.testNetworkId
         pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut)
     , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do
         Head.Close . toPlutusSignatures <$> (arbitrary :: Gen (MultiSignature (Snapshot Tx)))

hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs

@@ -11,7 +11,7 @@ import Data.List qualified as List
 import Data.Map qualified as Map
 import Data.Maybe (fromJust)
 import Hydra.Chain (HeadParameters (..))
-import Hydra.Chain.Direct.Contract.Gen (genForParty, genHash, genMintedOrBurnedValue)
+import Hydra.Chain.Direct.Contract.Gen (genHash, genMintedOrBurnedValue)
 import Hydra.Chain.Direct.Contract.Mutation (
   Mutation (..),
   SomeMutation (..),
@@ -52,6 +52,7 @@ import Hydra.OnChainId (OnChainId)
 import Hydra.Party (Party, partyToChain)
 import Hydra.Plutus.Orphans ()
 import PlutusTx.Builtins (toBuiltin)
+import Test.Hydra.Fixture (genForParty)
 import Test.QuickCheck (choose, elements, oneof, suchThat)
 import Test.QuickCheck.Instances ()
 

hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs

@@ -9,7 +9,7 @@ import Hydra.Prelude hiding (label)
 import Data.Maybe (fromJust)
 
 import Cardano.Api.UTxO as UTxO
-import Hydra.Chain.Direct.Contract.Gen (genForParty, genHash, genMintedOrBurnedValue)
+import Hydra.Chain.Direct.Contract.Gen (genHash, genMintedOrBurnedValue)
 import Hydra.Chain.Direct.Contract.Mutation (
   Mutation (..),
   SomeMutation (..),
@@ -48,7 +48,7 @@ import Hydra.Plutus.Orphans ()
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
 import PlutusLedgerApi.V2 (BuiltinByteString, toBuiltin)
 import PlutusLedgerApi.V2 qualified as Plutus
-import Test.Hydra.Fixture (aliceSk, bobSk, carolSk)
+import Test.Hydra.Fixture (aliceSk, bobSk, carolSk, genForParty)
 import Test.QuickCheck (arbitrarySizedNatural, elements, listOf, listOf1, oneof, suchThat, vectorOf)
 import Test.QuickCheck.Gen (choose)
 import Test.QuickCheck.Instances ()

hydra-node/test/Hydra/Chain/Direct/Contract/Gen.hs

@@ -1,37 +1,17 @@
 -- | Generators used in mutation testing framework
 module Hydra.Chain.Direct.Contract.Gen where
 
-import Cardano.Crypto.Hash (hashToBytes)
-import Codec.CBOR.Magic (uintegerFromBytes)
 import Data.ByteString qualified as BS
 import Hydra.Cardano.Api
 import Hydra.Chain.Direct.Fixture qualified as Fixtures
 import Hydra.Contract.HeadTokens (headPolicyId)
 import Hydra.Contract.Util (hydraHeadV1)
-import Hydra.Crypto (Hash (HydraKeyHash))
-import Hydra.Party (Party (..))
 import Hydra.Prelude
 import PlutusTx.Builtins (fromBuiltin)
 import Test.QuickCheck (oneof, suchThat, vector)
 
 -- * Party / key utilities
 
--- | Generate some 'a' given the Party as a seed. NOTE: While this is useful to
--- generate party-specific values, it DOES depend on the generator used. For
--- example, `genForParty genVerificationKey` and `genForParty (fst <$>
--- genKeyPair)` do not yield the same verification keys!
-genForParty :: Gen a -> Party -> a
-genForParty gen Party{vkey} =
-  generateWith gen seed
- where
-  seed =
-    fromIntegral
-      . uintegerFromBytes
-      . hydraKeyHashToBytes
-      $ verificationKeyHash vkey
-
-  hydraKeyHashToBytes (HydraKeyHash h) = hashToBytes h
-
 genBytes :: Gen ByteString
 genBytes = arbitrary
 

hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs

@@ -10,7 +10,6 @@ import Hydra.Prelude
 import Cardano.Api.UTxO qualified as UTxO
 import Data.Maybe (fromJust)
 import Hydra.Chain (HeadParameters (..))
-import Hydra.Chain.Direct.Contract.Gen (genForParty)
 import Hydra.Chain.Direct.Contract.Mutation (
   Mutation (..),
   SomeMutation (..),
@@ -28,6 +27,7 @@ import Hydra.Ledger.Cardano (genOneUTxOFor, genValue)
 import Hydra.OnChainId (OnChainId, genOnChainId)
 import Hydra.Party (Party)
 import PlutusLedgerApi.Test.Examples qualified as Plutus
+import Test.Hydra.Fixture (genForParty)
 import Test.QuickCheck (choose, elements, oneof, suchThat, vectorOf)
 import Prelude qualified
 

hydra-node/test/Hydra/Chain/Direct/TxSpec.hs

@@ -17,7 +17,6 @@ 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,
@@ -36,6 +35,7 @@ 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.Hydra.Fixture (genForParty)
 import Test.QuickCheck (
   Property,
   choose,