Add Increment mutation module

Signed-off-by: Sasha Bogicevic <[email protected]>

hydra-tx/hydra-tx.cabal

@@ -162,6 +162,7 @@ test-suite tests
     Hydra.Tx.Contract.Commit
     Hydra.Tx.Contract.Contest.ContestCurrent
     Hydra.Tx.Contract.ContractSpec
+    Hydra.Tx.Contract.Increment
     Hydra.Tx.Contract.Decrement
     Hydra.Tx.Contract.Deposit
     Hydra.Tx.Contract.FanOut

hydra-tx/test/Hydra/Tx/Contract/ContractSpec.hs

@@ -43,6 +43,7 @@ import Hydra.Tx.Contract.Contest.ContestCurrent (genContestMutation, healthyCont
 import Hydra.Tx.Contract.Decrement (genDecrementMutation, healthyDecrementTx)
 import Hydra.Tx.Contract.Deposit (healthyDepositTx)
 import Hydra.Tx.Contract.FanOut (genFanoutMutation, healthyFanoutTx)
+import Hydra.Tx.Contract.Increment (healthyIncrementTx)
 import Hydra.Tx.Contract.Init (genInitMutation, healthyInitTx)
 import Hydra.Tx.Contract.Recover (genRecoverMutation, healthyRecoverTx)
 import Hydra.Tx.Crypto (aggregate, sign, toPlutusSignatures)
@@ -108,6 +109,9 @@ spec = parallel $ do
       propTransactionEvaluates healthyCollectComTx
     prop "does not survive random adversarial mutations" $
       propMutation healthyCollectComTx genCollectComMutation
+  describe "Increment" $ do
+    prop "is healthy" $
+      propTransactionEvaluates healthyIncrementTx
   describe "Decrement" $ do
     prop "is healthy" $
       propTransactionEvaluates healthyDecrementTx

hydra-tx/test/Hydra/Tx/Contract/Increment.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Hydra.Tx.Contract.Increment where
+
+import Hydra.Cardano.Api
+import Hydra.Prelude hiding (label)
+import Test.Hydra.Tx.Mutation (
+  addParticipationTokens,
+ )
+
+import Cardano.Api.UTxO qualified as UTxO
+import Hydra.Contract.HeadState qualified as Head
+import Hydra.Data.Party qualified as OnChain
+import Hydra.Plutus.Orphans ()
+import Hydra.Tx.ContestationPeriod (ContestationPeriod, toChain)
+import Hydra.Tx.Contract.Deposit (healthyDepositTx)
+import Hydra.Tx.Crypto (HydraKey, MultiSignature (..), aggregate, sign)
+import Hydra.Tx.HeadId (mkHeadId)
+import Hydra.Tx.HeadParameters (HeadParameters (..))
+import Hydra.Tx.Increment (
+  incrementTx,
+ )
+import Hydra.Tx.Init (mkHeadOutput)
+import Hydra.Tx.IsTx (IsTx (hashUTxO, withoutUTxO))
+import Hydra.Tx.Party (Party, deriveParty, partyToChain)
+import Hydra.Tx.ScriptRegistry (registryUTxO)
+import Hydra.Tx.Snapshot (Snapshot (..), SnapshotNumber, SnapshotVersion)
+import Hydra.Tx.Utils (adaOnly, splitUTxO)
+import PlutusTx.Builtins (toBuiltin)
+import Test.Hydra.Tx.Fixture (aliceSk, bobSk, carolSk, testNetworkId, testPolicyId)
+import Test.Hydra.Tx.Gen (genForParty, genScriptRegistry, genUTxOSized, genVerificationKey)
+import Test.QuickCheck (elements)
+import Test.QuickCheck.Instances ()
+
+healthyIncrementTx :: (Tx, UTxO)
+healthyIncrementTx =
+  (tx, lookupUTxO)
+ where
+  lookupUTxO =
+    UTxO.singleton (headInput, headOutput)
+      <> registryUTxO scriptRegistry
+      <> depositUTxO
+
+  tx =
+    incrementTx
+      scriptRegistry
+      somePartyCardanoVerificationKey
+      (mkHeadId testPolicyId)
+      parameters
+      (headInput, headOutput)
+      healthySnapshot
+      healthySignature
+      depositUTxO
+
+  depositUTxO = utxoFromTx $ fst healthyDepositTx
+
+  parameters =
+    HeadParameters
+      { parties = healthyParties
+      , contestationPeriod = healthyContestationPeriod
+      }
+
+  scriptRegistry = genScriptRegistry `generateWith` 42
+
+  headInput = generateWith arbitrary 42
+
+  headOutput =
+    mkHeadOutput testNetworkId testPolicyId (toUTxOContext $ mkTxOutDatumInline healthyDatum)
+      & addParticipationTokens healthyParticipants
+      & modifyTxOutValue (<> foldMap txOutValue healthyUTxO)
+
+somePartyCardanoVerificationKey :: VerificationKey PaymentKey
+somePartyCardanoVerificationKey =
+  elements healthyParticipants `generateWith` 42
+
+healthySigningKeys :: [SigningKey HydraKey]
+healthySigningKeys = [aliceSk, bobSk, carolSk]
+
+healthyParticipants :: [VerificationKey PaymentKey]
+healthyParticipants =
+  genForParty genVerificationKey <$> healthyParties
+
+healthyParties :: [Party]
+healthyParties = deriveParty <$> healthySigningKeys
+
+healthyOnChainParties :: [OnChain.Party]
+healthyOnChainParties = partyToChain <$> healthyParties
+
+healthySignature :: MultiSignature (Snapshot Tx)
+healthySignature = aggregate [sign sk healthySnapshot | sk <- healthySigningKeys]
+
+healthySnapshotNumber :: SnapshotNumber
+healthySnapshotNumber = 1
+
+healthySnapshotVersion :: SnapshotVersion
+healthySnapshotVersion = 1
+
+healthySnapshot :: Snapshot Tx
+healthySnapshot =
+  let (utxoToDecommit', utxo) = splitUTxO healthyUTxO
+   in Snapshot
+        { headId = mkHeadId testPolicyId
+        , version = healthySnapshotVersion
+        , number = succ healthySnapshotNumber
+        , confirmed = []
+        , utxo
+        , utxoToCommit = Nothing
+        , utxoToDecommit = Just utxoToDecommit'
+        }
+
+splitDecommitUTxO :: UTxO -> (UTxO, UTxO)
+splitDecommitUTxO utxo =
+  case UTxO.pairs utxo of
+    [] -> error "empty utxo in splitDecommitUTxO"
+    (decommit : _rest) ->
+      let decommitUTxO' = UTxO.fromPairs [decommit]
+       in (utxo `withoutUTxO` decommitUTxO', decommitUTxO')
+
+healthyContestationPeriod :: ContestationPeriod
+healthyContestationPeriod =
+  arbitrary `generateWith` 42
+
+healthyUTxO :: UTxO
+healthyUTxO = adaOnly <$> generateWith (genUTxOSized 3) 42
+
+healthyDatum :: Head.State
+healthyDatum =
+  let (_utxoToDecommit', utxo) = splitDecommitUTxO healthyUTxO
+   in Head.Open
+        Head.OpenDatum
+          { utxoHash = toBuiltin $ hashUTxO @Tx utxo
+          , parties = healthyOnChainParties
+          , contestationPeriod = toChain healthyContestationPeriod
+          , headId = toPlutusCurrencySymbol testPolicyId
+          , version = toInteger healthySnapshotVersion
+          }