Ensure head scripts pay to head

By checking for the address when we ind the head output datum, we ensure we only consider the first output which must be addressed to vHead.
input-output-hk · Mar 17, 2023 · cd5b10a · cd5b10a
1 parent 11d8139
commit cd5b10a
Show file tree

Hide file tree

Showing 5 changed files with 15 additions and 11 deletions.
diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs
@@ -289,7 +289,7 @@ data CloseMutation
 genCloseMutation :: (Tx, UTxO) -> Gen SomeMutation
 genCloseMutation (tx, _utxo) =
   oneof
-    [ SomeMutation Nothing NotContinueContract <$> do
+    [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do
         mutatedAddress <- genAddressInEra testNetworkId
         pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut)
     , SomeMutation (Just $ toErrorCode InvalidSnapshotSignature) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do

diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs
@@ -194,7 +194,7 @@ data CollectComMutation
 genCollectComMutation :: (Tx, UTxO) -> Gen SomeMutation
 genCollectComMutation (tx, _utxo) =
   oneof
-    [ SomeMutation Nothing NotContinueContract <$> do
+    [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do
         mutatedAddress <- genAddressInEra testNetworkId
         pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut)
     , SomeMutation (Just $ toErrorCode IncorrectUtxoHash) MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash

diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Contest.hs
@@ -262,7 +262,7 @@ data ContestMutation
 genContestMutation :: (Tx, UTxO) -> Gen SomeMutation
 genContestMutation (tx, _utxo) =
   oneof
-    [ SomeMutation Nothing NotContinueContract <$> do
+    [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do
         mutatedAddress <- genAddressInEra testNetworkId
         pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut)
     , SomeMutation (Just $ toErrorCode SignatureVerificationFailed) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do

diff --git a/hydra-plutus/src/Hydra/Contract/Head.hs b/hydra-plutus/src/Hydra/Contract/Head.hs
@@ -158,7 +158,6 @@ checkCollectCom ::
   (ContestationPeriod, [Party], CurrencySymbol) ->
   Bool
 checkCollectCom ctx@ScriptContext{scriptContextTxInfo = txInfo} (contestationPeriod, parties, headId) =
-  -- FIXME: does not ensure contract continuity
   mustNotMintOrBurn txInfo
     && mustCollectUtxoHash
     && mustNotChangeParameters
@@ -190,7 +189,7 @@ checkCollectCom ctx@ScriptContext{scriptContextTxInfo = txInfo} (contestationPer
           (p, h, cp, hId)
       _ -> traceError $(errorCode WrongStateInOutputDatum)
 
-  headAddress = mkHeadAddress ctx
+  headAddress = getHeadAddress ctx
 
   val =
     maybe mempty (txOutValue . txInInfoResolved) $ findOwnInput ctx
@@ -256,7 +255,6 @@ checkClose ::
   CurrencySymbol ->
   Bool
 checkClose ctx parties initialUtxoHash sig cperiod headPolicyId =
-  -- FIXME: does not ensure contract continuity
   mustNotMintOrBurn txInfo
     && hasBoundedValidity
     && checkDeadline
@@ -365,7 +363,6 @@ checkContest ::
   CurrencySymbol ->
   Bool
 checkContest ctx contestationDeadline contestationPeriod parties closedSnapshotNumber sig contesters headId =
-  -- FIXME: does not ensure contract continuity
   mustNotMintOrBurn txInfo
     && mustBeNewer
     && mustBeMultiSigned
@@ -498,14 +495,14 @@ makeContestationDeadline cperiod ScriptContext{scriptContextTxInfo} =
     _ -> traceError $(errorCode CloseNoUpperBoundDefined)
 {-# INLINEABLE makeContestationDeadline #-}
 
-mkHeadAddress :: ScriptContext -> Address
-mkHeadAddress ctx =
+getHeadAddress :: ScriptContext -> Address
+getHeadAddress ctx =
   let headInput =
         fromMaybe
           (traceError $(errorCode ScriptNotSpendingAHeadInput))
           (findOwnInput ctx)
    in txOutAddress (txInInfoResolved headInput)
-{-# INLINEABLE mkHeadAddress #-}
+{-# INLINEABLE getHeadAddress #-}
 
 -- XXX: We might not need to distinguish between the three cases here.
 mustBeSignedByParticipant ::
@@ -540,8 +537,13 @@ findParticipationTokens headCurrency (Value val) =
 
 headOutputDatum :: ScriptContext -> Datum
 headOutputDatum ctx =
-  findTxOutDatum txInfo (head $ txInfoOutputs txInfo)
+  case txInfoOutputs txInfo of
+    (o : _)
+      | txOutAddress o == headAddress -> findTxOutDatum txInfo o
+    _ -> traceError $(errorCode NotPayingToHead)
  where
+  headAddress = getHeadAddress ctx
+
   ScriptContext{scriptContextTxInfo = txInfo} = ctx
 {-# INLINEABLE headOutputDatum #-}
 

diff --git a/hydra-plutus/src/Hydra/Contract/HeadError.hs b/hydra-plutus/src/Hydra/Contract/HeadError.hs
@@ -43,6 +43,7 @@ data HeadError
   | DatumNotFound
   | SignatureVerificationFailed
   | PartySignatureVerificationFailed
+  | NotPayingToHead
   deriving (Show)
 
 instance ToErrorCode HeadError where
@@ -85,3 +86,4 @@ instance ToErrorCode HeadError where
     DatumNotFound -> "H34"
     SignatureVerificationFailed -> "H35"
     PartySignatureVerificationFailed -> "H36"
+    NotPayingToHead -> "H37"