Merge pull request #716 from input-output-hk/ensemble/push-deadline-o…

…n-contest

deadline gets "pushed out" on each contest

CHANGELOG.md

@@ -31,7 +31,8 @@ changes.
   + The v_head output must now be the first output of the transaction so that we can make the validator code simpler.
   + Introduce check in head validator to allow contest only once per party.
   + Check that value is preserved in v_head
-  + Introduce a function `(===!)` for strict equality check between serialized `Value`.
+  + Introduce a function `(===)` for strict equality check between serialized `Value`.
+  + Push contestation deadline on contest.
 
 - **BREAKING** Change the way tx validity and contestation deadline is constructed for close transactions:
   + There is a new hydra-node flag `--contestation-period` expressed in seconds

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

@@ -433,14 +433,14 @@ contest ::
   PointInTime ->
   Tx
 contest ctx st confirmedSnapshot pointInTime = do
-  contestTx ownVerificationKey sn sigs pointInTime closedThreadOutput headId
+  contestTx ownVerificationKey sn sigs pointInTime closedThreadOutput headId contestationPeriod
  where
   (sn, sigs) =
     case confirmedSnapshot of
       ConfirmedSnapshot{signatures} -> (getSnapshot confirmedSnapshot, signatures)
       _ -> (getSnapshot confirmedSnapshot, mempty)
 
-  ChainContext{ownVerificationKey} = ctx
+  ChainContext{contestationPeriod, ownVerificationKey} = ctx
 
   ClosedState
     { closedThreadOutput

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

@@ -355,6 +355,7 @@ closeTx vk closing startSlotNo (endSlotNo, utcTime) openThreadOutput headId =
         , utxoHash = toBuiltin utxoHashBytes
         , parties = openParties
         , contestationDeadline
+        , contestationPeriod = openContestationPeriod
         , headId = headIdToCurrencySymbol headId
         , contesters = []
         }
@@ -391,8 +392,9 @@ contestTx ::
   -- | Everything needed to spend the Head state-machine output.
   ClosedThreadOutput ->
   HeadId ->
+  ContestationPeriod ->
   Tx
-contestTx vk Snapshot{number, utxo} sig (slotNo, _) ClosedThreadOutput{closedThreadUTxO = (headInput, headOutputBefore, ScriptDatumForTxIn -> headDatumBefore), closedParties, closedContestationDeadline, closedContesters} headId =
+contestTx vk Snapshot{number, utxo} sig (slotNo, _) ClosedThreadOutput{closedThreadUTxO = (headInput, headOutputBefore, ScriptDatumForTxIn -> headDatumBefore), closedParties, closedContestationDeadline, closedContesters} headId contestationPeriod =
   unsafeBuildTransaction $
     emptyTxBody
       & addInputs [(headInput, headWitness)]
@@ -414,13 +416,21 @@ contestTx vk Snapshot{number, utxo} sig (slotNo, _) ClosedThreadOutput{closedThr
 
   contester = toPlutusKeyHash (verificationKeyHash vk)
 
+  onChainConstestationPeriod = toChain contestationPeriod
+
+  newContestationDeadline =
+    if length (contester : closedContesters) == length closedParties
+      then closedContestationDeadline
+      else addContestationPeriod closedContestationDeadline onChainConstestationPeriod
+
   headDatumAfter =
     mkTxOutDatum
       Head.Closed
         { snapshotNumber = toInteger number
         , utxoHash
         , parties = closedParties
-        , contestationDeadline = closedContestationDeadline
+        , contestationDeadline = newContestationDeadline
+        , contestationPeriod = onChainConstestationPeriod
         , headId = headIdToCurrencySymbol headId
         , contesters = contester : closedContesters
         }

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

@@ -17,6 +17,8 @@ import Hydra.Chain.Direct.Contract.Mutation (
   addParticipationTokens,
   changeHeadOutputDatum,
   changeMintedTokens,
+  replaceContestationDeadline,
+  replaceContestationPeriod,
   replaceContesters,
   replaceParties,
   replacePolicyIdWith,
@@ -25,10 +27,12 @@ import Hydra.Chain.Direct.Contract.Mutation (
  )
 import Hydra.Chain.Direct.Fixture (testNetworkId, testPolicyId)
 import Hydra.Chain.Direct.Tx (ClosedThreadOutput (..), contestTx, mkHeadId, mkHeadOutput)
+import Hydra.ContestationPeriod (ContestationPeriod, fromChain)
 import qualified Hydra.Contract.HeadState as Head
 import Hydra.Contract.HeadTokens (headPolicyId)
 import Hydra.Crypto (HydraKey, MultiSignature, aggregate, sign, toPlutusSignatures)
 import Hydra.Data.ContestationPeriod (posixFromUTCTime)
+import qualified Hydra.Data.ContestationPeriod as OnChain
 import qualified Hydra.Data.Party as OnChain
 import Hydra.Ledger (hashUTxO)
 import Hydra.Ledger.Cardano (genOneUTxOFor, genValue, genVerificationKey)
@@ -39,26 +43,29 @@ import Plutus.Orphans ()
 import Plutus.V2.Ledger.Api (BuiltinByteString, toBuiltin, toData)
 import qualified Plutus.V2.Ledger.Api as Plutus
 import Test.Hydra.Fixture (aliceSk, bobSk, carolSk)
-import Test.QuickCheck (elements, listOf, oneof, suchThat)
+import Test.QuickCheck (elements, listOf, oneof, suchThat, vectorOf)
 import Test.QuickCheck.Gen (choose)
 import Test.QuickCheck.Instances ()
 
 --
 -- ContestTx
 --
 
+-- | Healthy contest tx where the contester is the first one to contest and
+-- correctly pushing out the deadline by the contestation period.
 healthyContestTx :: (Tx, UTxO)
 healthyContestTx =
   (tx, lookupUTxO)
  where
   tx =
     contestTx
-      somePartyCardanoVerificationKey
+      healthyContesterVerificationKey
       healthyContestSnapshot
       (healthySignature healthyContestSnapshotNumber)
       (healthySlotNo, slotNoToUTCTime healthySlotNo)
       closedThreadOutput
       (mkHeadId testPolicyId)
+      healthyContestationPeriod
 
   headDatum = fromPlutusData $ toData healthyClosedState
 
@@ -96,7 +103,7 @@ healthyContestSnapshotNumber = 4
 
 healthyContestUTxO :: UTxO
 healthyContestUTxO =
-  (genOneUTxOFor somePartyCardanoVerificationKey `suchThat` (/= healthyClosedUTxO))
+  (genOneUTxOFor healthyContesterVerificationKey `suchThat` (/= healthyClosedUTxO))
     `generateWith` 42
 
 healthyContestUTxOHash :: BuiltinByteString
@@ -110,6 +117,7 @@ healthyClosedState =
     , utxoHash = healthyClosedUTxOHash
     , parties = healthyOnChainParties
     , contestationDeadline = posixFromUTCTime healthyContestationDeadline
+    , contestationPeriod = healthyOnChainContestationPeriod
     , headId = toPlutusCurrencySymbol testPolicyId
     , contesters = []
     }
@@ -123,6 +131,12 @@ healthyContestationDeadline =
     (fromInteger healthyContestationPeriodSeconds)
     (slotNoToUTCTime healthySlotNo)
 
+healthyOnChainContestationPeriod :: OnChain.ContestationPeriod
+healthyOnChainContestationPeriod = OnChain.contestationPeriodFromDiffTime $ fromInteger healthyContestationPeriodSeconds
+
+healthyContestationPeriod :: ContestationPeriod
+healthyContestationPeriod = fromChain healthyOnChainContestationPeriod
+
 healthyContestationPeriodSeconds :: Integer
 healthyContestationPeriodSeconds = 10
 
@@ -135,10 +149,10 @@ healthyClosedUTxOHash =
 
 healthyClosedUTxO :: UTxO
 healthyClosedUTxO =
-  genOneUTxOFor somePartyCardanoVerificationKey `generateWith` 42
+  genOneUTxOFor healthyContesterVerificationKey `generateWith` 42
 
-somePartyCardanoVerificationKey :: VerificationKey PaymentKey
-somePartyCardanoVerificationKey = flip generateWith 42 $ do
+healthyContesterVerificationKey :: VerificationKey PaymentKey
+healthyContesterVerificationKey = flip generateWith 42 $ do
   genForParty genVerificationKey <$> elements healthyParties
 
 healthySigningKeys :: [SigningKey HydraKey]
@@ -181,6 +195,15 @@ data ContestMutation
     MutateContesters
   | -- | See spec: 5.5. rule 6 -> value is preserved
     MutateValueInOutput
+  | -- | Change the 'ContestationDeadline' in the 'Closed' output datum such that deadline is pushed away
+    NotUpdateDeadlineAlthoughItShould
+  | -- | Pushes the deadline although this is the last contest. Instead of
+    -- creating another healthy case and mutate that one, this mutation just
+    -- changes the starting situation so that everyone else already contested.
+    -- Remember the 'healthyContestTx' is already pushing out the deadline.
+    PushDeadlineAlthoughItShouldNot
+  | -- | Change the contestation period to test parameters not changed in output.
+    MutateOutputContestationPeriod
   deriving (Generic, Show, Enum, Bounded)
 
 genContestMutation :: (Tx, UTxO) -> Gen SomeMutation
@@ -238,7 +261,7 @@ genContestMutation
       , SomeMutation (Just "minting or burning is forbidden") MutateTokenMintingOrBurning
           <$> (changeMintedTokens tx =<< genMintedOrBurnedValue)
       , SomeMutation (Just "signer already contested") MutateInputContesters . ChangeInputHeadDatum <$> do
-          let contester = toPlutusKeyHash (verificationKeyHash somePartyCardanoVerificationKey)
+          let contester = toPlutusKeyHash (verificationKeyHash healthyContesterVerificationKey)
               contesterAndSomeOthers = do
                 contesters <- listOf $ Plutus.PubKeyHash . toBuiltin <$> genHash
                 pure (contester : contesters)
@@ -256,6 +279,21 @@ genContestMutation
       , SomeMutation (Just "head value is not preserved") MutateValueInOutput <$> do
           newValue <- genValue
           pure $ ChangeOutput 0 (headTxOut{txOutValue = newValue})
+      , SomeMutation (Just "must push deadline") NotUpdateDeadlineAlthoughItShould . ChangeOutput 0 <$> do
+          let deadline = posixFromUTCTime healthyContestationDeadline
+          -- Here we are replacing the contestationDeadline using the previous so we are not _pushing it_ further
+          pure $ headTxOut & changeHeadOutputDatum (replaceContestationDeadline deadline)
+      , SomeMutation (Just "must not push deadline") PushDeadlineAlthoughItShouldNot <$> do
+          alreadyContested <- vectorOf (length healthyParties - 1) $ Plutus.PubKeyHash . toBuiltin <$> genHash
+          let contester = toPlutusKeyHash $ verificationKeyHash healthyContesterVerificationKey
+          pure $
+            Changes
+              [ ChangeOutput 0 (headTxOut & changeHeadOutputDatum (replaceContesters (contester : alreadyContested)))
+              , ChangeInputHeadDatum (healthyClosedState & replaceContesters alreadyContested)
+              ]
+      , SomeMutation (Just "changed parameters") MutateOutputContestationPeriod <$> do
+          randomCP <- arbitrary `suchThat` (/= healthyOnChainContestationPeriod)
+          pure $ ChangeOutput 0 (headTxOut & changeHeadOutputDatum (replaceContestationPeriod randomCP))
       ]
    where
     headTxOut = fromJust $ txOuts' tx !!? 0

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

@@ -15,6 +15,7 @@ import Hydra.Chain.Direct.Tx (fanoutTx, mkHeadOutput)
 import qualified Hydra.Contract.HeadState as Head
 import Hydra.Contract.HeadTokens (mkHeadTokenScript)
 import Hydra.Data.ContestationPeriod (posixFromUTCTime)
+import qualified Hydra.Data.ContestationPeriod as OnChain
 import Hydra.Ledger (IsTx (hashUTxO))
 import Hydra.Ledger.Cardano (
   adaOnly,
@@ -81,9 +82,14 @@ healthyFanoutDatum =
     , utxoHash = toBuiltin $ hashUTxO @Tx healthyFanoutUTxO
     , parties = partyToChain <$> arbitrary `generateWith` 42
     , contestationDeadline = posixFromUTCTime healthyContestationDeadline
+    , contestationPeriod = healthyContestationPeriod
     , headId = toPlutusCurrencySymbol testPolicyId
     , contesters = []
     }
+ where
+  healthyContestationPeriodSeconds = 10
+
+  healthyContestationPeriod = OnChain.contestationPeriodFromDiffTime $ fromInteger healthyContestationPeriodSeconds
 
 data FanoutMutation
   = MutateAddUnexpectedOutput

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

@@ -146,6 +146,7 @@ import qualified Hydra.Chain.Direct.Fixture as Fixture
 import Hydra.Chain.Direct.Tx (assetNameFromVerificationKey)
 import qualified Hydra.Contract.Head as Head
 import qualified Hydra.Contract.HeadState as Head
+import Hydra.Data.ContestationPeriod
 import qualified Hydra.Data.Party as Data (Party)
 import Hydra.Ledger.Cardano (genKeyPair, genOutput, genVerificationKey, renderTxWithUTxO)
 import Hydra.Ledger.Cardano.Evaluate (evaluateTx)
@@ -644,12 +645,13 @@ replacePolicyIdWith originalPolicyId otherPolicyId output =
 
 replaceSnapshotNumber :: Head.SnapshotNumber -> Head.State -> Head.State
 replaceSnapshotNumber snapshotNumber = \case
-  Head.Closed{parties, utxoHash, contestationDeadline, headId, contesters} ->
+  Head.Closed{parties, utxoHash, contestationDeadline, headId, contesters, contestationPeriod} ->
     Head.Closed
       { Head.parties = parties
       , Head.snapshotNumber = snapshotNumber
       , Head.utxoHash = utxoHash
       , Head.contestationDeadline = contestationDeadline
+      , Head.contestationPeriod = contestationPeriod
       , Head.headId = headId
       , Head.contesters = contesters
       }
@@ -670,12 +672,13 @@ replaceParties parties = \case
       , Head.utxoHash = utxoHash
       , Head.headId = headId
       }
-  Head.Closed{snapshotNumber, utxoHash, contestationDeadline, headId, contesters} ->
+  Head.Closed{snapshotNumber, utxoHash, contestationDeadline, headId, contesters, contestationPeriod} ->
     Head.Closed
       { Head.parties = parties
       , Head.snapshotNumber = snapshotNumber
       , Head.utxoHash = utxoHash
       , Head.contestationDeadline = contestationDeadline
+      , Head.contestationPeriod = contestationPeriod
       , Head.headId = headId
       , Head.contesters = contesters
       }
@@ -690,25 +693,41 @@ replaceUtxoHash utxoHash = \case
       , Head.utxoHash = utxoHash
       , Head.headId = headId
       }
-  Head.Closed{parties, snapshotNumber, contestationDeadline, headId, contesters} ->
+  Head.Closed{parties, snapshotNumber, contestationDeadline, headId, contesters, contestationPeriod} ->
     Head.Closed
       { Head.parties = parties
       , Head.snapshotNumber = snapshotNumber
       , Head.utxoHash = utxoHash
       , Head.contestationDeadline = contestationDeadline
+      , Head.contestationPeriod = contestationPeriod
       , Head.headId = headId
       , Head.contesters = contesters
       }
   otherState -> otherState
 
 replaceContestationDeadline :: POSIXTime -> Head.State -> Head.State
 replaceContestationDeadline contestationDeadline = \case
-  Head.Closed{snapshotNumber, utxoHash, parties, headId, contesters} ->
+  Head.Closed{snapshotNumber, utxoHash, parties, headId, contesters, contestationPeriod} ->
     Head.Closed
       { snapshotNumber
       , utxoHash
       , parties
       , contestationDeadline
+      , contestationPeriod
+      , headId
+      , contesters
+      }
+  otherState -> otherState
+
+replaceContestationPeriod :: ContestationPeriod -> Head.State -> Head.State
+replaceContestationPeriod contestationPeriod = \case
+  Head.Closed{snapshotNumber, utxoHash, parties, headId, contesters, contestationDeadline} ->
+    Head.Closed
+      { snapshotNumber
+      , utxoHash
+      , parties
+      , contestationDeadline
+      , contestationPeriod
       , headId
       , contesters
       }
@@ -729,25 +748,27 @@ replaceHeadId headId = \case
       , Head.utxoHash = utxoHash
       , Head.headId = headId
       }
-  Head.Closed{snapshotNumber, utxoHash, contestationDeadline, parties, contesters} ->
+  Head.Closed{snapshotNumber, utxoHash, contestationDeadline, parties, contesters, contestationPeriod} ->
     Head.Closed
       { Head.parties = parties
       , Head.snapshotNumber = snapshotNumber
       , Head.utxoHash = utxoHash
       , Head.contestationDeadline = contestationDeadline
+      , Head.contestationPeriod = contestationPeriod
       , Head.headId = headId
       , Head.contesters = contesters
       }
   otherState -> otherState
 
 replaceContesters :: [Plutus.PubKeyHash] -> Head.State -> Head.State
 replaceContesters contesters = \case
-  Head.Closed{snapshotNumber, utxoHash, contestationDeadline, parties, headId} ->
+  Head.Closed{snapshotNumber, utxoHash, contestationDeadline, parties, headId, contestationPeriod} ->
     Head.Closed
       { Head.parties = parties
       , Head.snapshotNumber = snapshotNumber
       , Head.utxoHash = utxoHash
       , Head.contestationDeadline = contestationDeadline
+      , Head.contestationPeriod = contestationPeriod
       , Head.headId = headId
       , Head.contesters = contesters
       }

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

@@ -398,7 +398,7 @@ forAllFanout action =
        in action utxo tx
             & label ("Fanout size: " <> prettyLength (countAssets $ txOuts' tx))
  where
-  maxSupported = 45
+  maxSupported = 38
 
   countAssets = getSum . foldMap (Sum . valueSize . txOutValue)