From cd5b10ab7ecbba6a4e39fc7c488c516401c4c1fd Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 13 Mar 2023 10:24:30 +0100 Subject: [PATCH] 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. --- .../test/Hydra/Chain/Direct/Contract/Close.hs | 2 +- .../Hydra/Chain/Direct/Contract/CollectCom.hs | 2 +- .../Hydra/Chain/Direct/Contract/Contest.hs | 2 +- hydra-plutus/src/Hydra/Contract/Head.hs | 18 ++++++++++-------- hydra-plutus/src/Hydra/Contract/HeadError.hs | 2 ++ 5 files changed, 15 insertions(+), 11 deletions(-) diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Close.hs index e81f78cafc3..0e4fe6bdad7 100644 --- 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 index 77854ae9a94..975f761781a 100644 --- 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 index 5c238450708..d7c9e6cb07d 100644 --- 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 index 5a558662566..3c02a4f4dcf 100644 --- 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 index 049f2834ced..67b0f52a8c4 100644 --- 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"