Increase tx size to make increment work for now

Author: v0d1ch

hydra-cluster/config/devnet/genesis-shelley.json

@@ -22,7 +22,7 @@
         "keyDeposit": 0,
         "maxBlockBodySize": 65536,
         "maxBlockHeaderSize": 1100,
-        "maxTxSize": 16384,
+        "maxTxSize": 17700,
         "minFeeA": 44,
         "minFeeB": 155381,
         "minPoolCost": 0,

hydra-cluster/src/Hydra/Cluster/Scenarios.hs

@@ -701,7 +701,9 @@ canCommit :: Tracer IO EndToEndLog -> FilePath -> RunningNode -> TxId -> IO ()
 canCommit tracer workDir node hydraScriptsTxId =
   (`finally` returnFundsToFaucet tracer node Alice) $ do
     refuelIfNeeded tracer node Alice 30_000_000
-    let contestationPeriod = UnsafeContestationPeriod 1
+    -- NOTE: it is important to provide _large_ enough contestation period so that
+    -- increment tx can be submitted before the deadline
+    let contestationPeriod = UnsafeContestationPeriod 5
     aliceChainConfig <-
       chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [] contestationPeriod
         <&> setNetworkId networkId
@@ -752,7 +754,7 @@ canRecoverDeposit tracer workDir node hydraScriptsTxId =
       refuelIfNeeded tracer node Alice 30_000_000
       refuelIfNeeded tracer node Bob 30_000_000
       -- NOTE: this value is also used to determine the deposit deadline
-      let deadline = 1
+      let deadline = 5
       let contestationPeriod = UnsafeContestationPeriod deadline
       aliceChainConfig <-
         chainConfigFor Alice workDir nodeSocket hydraScriptsTxId [Bob] contestationPeriod

hydra-plutus/src/Hydra/Contract/Head.hs

@@ -3,6 +3,7 @@
 {-# OPTIONS_GHC -fno-specialize #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:conservative-optimisation #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:optimize #-}
 -- Plutus core version to compile to. In babbage era, that is Cardano protocol
 -- version 7 and 8, only plutus-core version 1.0.0 is available.
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-}
@@ -41,11 +42,10 @@ import PlutusLedgerApi.V2 (
   TxInInfo (..),
   TxInfo (..),
   TxOut (..),
-  TxOutRef (..),
   UpperBound (..),
   Value (Value),
  )
-import PlutusLedgerApi.V2.Contexts (findOwnInput, spendsOutput)
+import PlutusLedgerApi.V2.Contexts (findOwnInput, findTxInByTxOutRef)
 import PlutusTx (CompiledCode)
 import PlutusTx qualified
 import PlutusTx.AssocMap qualified as AssocMap
@@ -240,34 +240,42 @@ checkIncrement ::
   IncrementRedeemer ->
   Bool
 checkIncrement ctx@ScriptContext{scriptContextTxInfo = txInfo} openBefore redeemer =
-  -- FIXME: spec is mentioning the n also needs to be unchanged - what is n here?
+  -- FIXME: spec is mentioning the n also needs to be unchanged - what is n here? utxo hash?
   -- "parameters cid, 𝑘̃ H , 𝑛, 𝑇 stay unchanged"
   mustNotChangeParameters (prevParties, nextParties) (prevCperiod, nextCperiod) (prevHeadId, nextHeadId)
     && mustIncreaseVersion
-    && checkSnapshotSignature
     && mustIncreaseValue
     && mustBeSignedByParticipant ctx prevHeadId
+    && checkSnapshotSignature
     && claimedDepositIsSpent
  where
-  deposited = foldMap (depositDatum . txInInfoResolved) (txInfoInputs txInfo)
+  inputs = txInfoInputs txInfo
+
+  depositInput =
+    case findTxInByTxOutRef increment txInfo of
+      Nothing -> traceError $(errorCode DepositInputNotFound)
+      Just i -> i
 
-  depositHash = hashPreSerializedCommits deposited
+  commits = depositDatum $ txInInfoResolved depositInput
 
-  depositInput = txInfoInputs txInfo !! 1
+  depositHash = hashPreSerializedCommits commits
 
   depositRef = txInInfoOutRef depositInput
 
   depositValue = txOutValue $ txInInfoResolved depositInput
 
-  headInValue = txOutValue $ txInInfoResolved (head (txInfoInputs txInfo))
+  headInValue =
+    case find (hasST prevHeadId) $ txOutValue . txInInfoResolved <$> inputs of
+      Nothing -> traceError $(errorCode HeadInputNotFound)
+      Just i -> i
 
-  headOutValue = foldMap txOutValue $ txInfoOutputs txInfo
+  headOutValue = txOutValue $ head $ txInfoOutputs txInfo
 
   IncrementRedeemer{signature, snapshotNumber, increment} = redeemer
 
   claimedDepositIsSpent =
     traceIfFalse $(errorCode DepositNotSpent) $
-      depositRef == increment && spendsOutput txInfo (txOutRefId depositRef) (txOutRefIdx depositRef)
+      depositRef == increment
 
   checkSnapshotSignature =
     verifySnapshotSignature nextParties (nextHeadId, prevVersion, snapshotNumber, nextUtxoHash, depositHash, emptyHash) signature
@@ -623,6 +631,7 @@ makeContestationDeadline cperiod ScriptContext{scriptContextTxInfo} =
     _ -> traceError $(errorCode CloseNoUpperBoundDefined)
 {-# INLINEABLE makeContestationDeadline #-}
 
+-- | This is safe only because usually Head transaction only consume one input.
 getHeadInput :: ScriptContext -> TxInInfo
 getHeadInput ctx = case findOwnInput ctx of
   Nothing -> traceError $(errorCode ScriptNotSpendingAHeadInput)

hydra-plutus/src/Hydra/Contract/HeadError.hs

@@ -51,6 +51,8 @@ data HeadError
   | FanoutNoLowerBoundDefined
   | FanoutUTxOToDecommitHashMismatch
   | DepositNotSpent
+  | DepositInputNotFound
+  | HeadInputNotFound
 
 instance ToErrorCode HeadError where
   toErrorCode = \case
@@ -106,3 +108,5 @@ instance ToErrorCode HeadError where
     LowerBoundBeforeContestationDeadline -> "H43"
     FanoutNoLowerBoundDefined -> "H44"
     DepositNotSpent -> "H45"
+    DepositInputNotFound -> "H46"
+    HeadInputNotFound -> "H47"

hydra-tx/src/Hydra/Tx/Increment.hs

@@ -59,7 +59,13 @@ incrementTx scriptRegistry vk headId headParameters (headInput, headOutput) snap
       & setTxMetadata (TxMetadataInEra $ mkHydraHeadV1TxName "IncrementTx")
  where
   headRedeemer =
-    toScriptData $ Head.Increment Head.IncrementRedeemer{signature = toPlutusSignatures sigs, snapshotNumber = fromIntegral number, increment = toPlutusTxOutRef depositIn}
+    toScriptData $
+      Head.Increment
+        Head.IncrementRedeemer
+          { signature = toPlutusSignatures sigs
+          , snapshotNumber = fromIntegral number
+          , increment = toPlutusTxOutRef depositIn
+          }
 
   HeadParameters{parties, contestationPeriod} = headParameters
 
@@ -90,12 +96,12 @@ incrementTx scriptRegistry vk headId headParameters (headInput, headOutput) snap
           , version = toInteger version + 1
           }
 
-  depositedValue = txOutValue depositOut
+  depositedValue = foldMap (txOutValue . snd) (UTxO.pairs (fromMaybe mempty utxoToCommit))
 
   depositScript = fromPlutusScript @PlutusScriptV2 Deposit.validatorScript
 
   -- NOTE: we expect always a single output from a deposit tx
-  (depositIn, depositOut) = List.head $ UTxO.pairs depositScriptUTxO
+  (depositIn, _) = List.head $ UTxO.pairs depositScriptUTxO
 
   depositRedeemer = toScriptData $ Deposit.Claim $ headIdToCurrencySymbol headId
 
@@ -104,4 +110,4 @@ incrementTx scriptRegistry vk headId headParameters (headInput, headOutput) snap
       ScriptWitness scriptWitnessInCtx $
         mkScriptWitness depositScript InlineScriptDatum depositRedeemer
 
-  Snapshot{utxo, version, number} = snapshot
+  Snapshot{utxo, utxoToCommit, version, number} = snapshot

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

@@ -3,11 +3,10 @@ module Hydra.Tx.Contract.Deposit where
 import Hydra.Cardano.Api
 import Hydra.Prelude
 
-import Data.Time (UTCTime (..), secondsToDiffTime)
-import Data.Time.Calendar (fromGregorian)
 import Hydra.Tx (mkHeadId)
 import Hydra.Tx.BlueprintTx (CommitBlueprintTx (..))
 import Hydra.Tx.Deposit (depositTx)
+import System.IO.Unsafe (unsafePerformIO)
 import Test.Hydra.Tx.Fixture (testNetworkId, testPolicyId)
 import Test.Hydra.Tx.Gen (genUTxOAdaOnlyOfSize)
 
@@ -23,7 +22,8 @@ healthyDepositTx =
       depositDeadline
 
 depositDeadline :: UTCTime
-depositDeadline = UTCTime (fromGregorian 2024 15 0) (secondsToDiffTime 0)
+depositDeadline = unsafePerformIO getCurrentTime
+{-# NOINLINE depositDeadline #-}
 
 healthyDepositUTxO :: UTxO
-healthyDepositUTxO = genUTxOAdaOnlyOfSize 5 `generateWith` 42
+healthyDepositUTxO = genUTxOAdaOnlyOfSize 1 `generateWith` 42

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

@@ -41,7 +41,7 @@ import Hydra.Tx.Snapshot (Snapshot (..), SnapshotNumber, SnapshotVersion)
 import Hydra.Tx.Utils (adaOnly)
 import PlutusLedgerApi.V2 qualified as Plutus
 import PlutusTx.Builtins (toBuiltin)
-import Test.Hydra.Tx.Fixture (aliceSk, bobSk, carolSk, slotLength, systemStart, testHeadId, testNetworkId, testPolicyId)
+import Test.Hydra.Tx.Fixture (aliceSk, bobSk, carolSk, slotLength, systemStart, testNetworkId, testPolicyId)
 import Test.Hydra.Tx.Gen (genForParty, genScriptRegistry, genUTxOSized, genValue, genVerificationKey)
 import Test.QuickCheck (arbitrarySizedNatural, elements, oneof, suchThat)
 import Test.QuickCheck.Instances ()
@@ -169,9 +169,9 @@ genIncrementMutation (tx, utxo) =
               txOutDatum $
                 flip modifyInlineDatum (toTxContext depositOut) $ \case
                   DepositDatum (headCS', depositDatumDeadline, commits) ->
-                    DepositDatum (headCS', Plutus.POSIXTime $ Plutus.getPOSIXTime depositDatumDeadline - 1, commits)
+                    DepositDatum (headCS', Plutus.POSIXTime $ Plutus.getPOSIXTime depositDatumDeadline - 1000, commits)
         let newOutput = toCtxUTxOTxOut $ TxOut addr val datum rscript
-        pure $ ChangeInput depositIn newOutput (Just $ toScriptData $ Claim (headIdToCurrencySymbol testHeadId))
+        pure $ ChangeInput depositIn newOutput (Just $ toScriptData $ Claim (toPlutusCurrencySymbol testPolicyId))
     , SomeMutation (pure $ toErrorCode WrongHeadIdInDepositDatum) DepositMutateHeadId <$> do
         otherHeadId <- arbitrary
         let datum =
@@ -180,7 +180,7 @@ genIncrementMutation (tx, utxo) =
                   DepositDatum (_headCS, depositDatumDeadline, commits) ->
                     DepositDatum (otherHeadId, depositDatumDeadline, commits)
         let newOutput = toCtxUTxOTxOut $ TxOut addr val datum rscript
-        pure $ ChangeInput depositIn newOutput (Just $ toScriptData $ Claim (headIdToCurrencySymbol testHeadId))
+        pure $ ChangeInput depositIn newOutput (Just $ toScriptData $ Claim (toPlutusCurrencySymbol testPolicyId))
     , SomeMutation (pure $ toErrorCode ChangedParameters) IncrementMutateParties <$> do
         mutatedParties <- arbitrary `suchThat` (/= healthyOnChainParties)
         pure $ ChangeOutput 0 $ modifyInlineDatum (replaceParties mutatedParties) headTxOut
@@ -202,7 +202,7 @@ genIncrementMutation (tx, utxo) =
     , SomeMutation (pure $ toErrorCode SignerIsNotAParticipant) AlterRequiredSigner <$> do
         newSigner <- verificationKeyHash <$> genVerificationKey `suchThat` (/= somePartyCardanoVerificationKey)
         pure $ ChangeRequiredSigners [newSigner]
-    , SomeMutation (pure $ toErrorCode DepositNotSpent) IncrementDifferentClaimRedeemer . ChangeHeadRedeemer <$> do
+    , SomeMutation (pure $ toErrorCode DepositInputNotFound) IncrementDifferentClaimRedeemer . ChangeHeadRedeemer <$> do
         invalidDepositRef <- genTxIn
         pure $
           Head.Increment