Skip to content

Commit

Permalink
Merge pull request #670 from input-output-hk/ensemble/check-commits-a…
Browse files Browse the repository at this point in the history
…re-reimbursed-in-nu-head

check commits are reimbursed in nu head
  • Loading branch information
v0d1ch authored Jan 13, 2023
2 parents 7f5e25c + dc6d7d0 commit 9cb4e1b
Show file tree
Hide file tree
Showing 7 changed files with 126 additions and 61 deletions.
5 changes: 5 additions & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -20,12 +20,17 @@ changes.

- HeadLogic Outcome is now being trace on every protocol step transition.


- **BREAKING** `hydra-cardano-api` changes:
+ Remove `Hydra.Cardano.Api.SlotNo` module.
+ Replace `fromConsensusPointHF` with `fromConsensusPointInMode` and
`toConsensusPointHF` with `toConsensusPointInMode`.
+ Re-export new `AcquiringFailure` type from `cardano-api`.

- **BREAKING** Addressed short-comings in `hydra-plutus` scripts:
+ Check presence of state token (ST) and that it's consistent against datum.
+ Moved check to reimburse commits to head validator.

- Change the way the internal wallet initializes its state [#621](https://github.com/input-output-hk/hydra/pull/621)
+ The internal wallet does now always query ledger state and parameters at the tip.
+ This should fix the `AcquireFailure` issues.
Expand Down
17 changes: 12 additions & 5 deletions hydra-node/test/Hydra/Chain/Direct/Contract/Abort.hs
Original file line number Diff line number Diff line change
Expand Up @@ -93,14 +93,13 @@ healthyCommits :: [UTxOWithScript]
-- TODO: Refactor this to be an AbortTx generator because we actually want
-- to test healthy abort txs with varied combinations of inital and commit
-- outputs
generateWith (genAbortableOutputs healthyParties `suchThat` thereIsAtLeastOneCommit) 42

thereIsAtLeastOneCommit :: ([UTxOWithScript], [UTxOWithScript]) -> Bool
thereIsAtLeastOneCommit (is, cs) = not (null cs) && not (null is)
generateWith (genAbortableOutputs healthyParties `suchThat` thereIsTwoEach) 42
where
thereIsTwoEach (is, cs) = length is >= 2 && length cs >= 2

healthyParties :: [Party]
healthyParties =
[ generateWith arbitrary i | i <- [1 .. 3]
[ generateWith arbitrary i | i <- [1 .. 4]
]

propHasInitial :: (Tx, UTxO) -> Property
Expand Down Expand Up @@ -136,6 +135,8 @@ data AbortMutation
| -- Spend some abortable output from a different Head
-- e.g. replace a commit by another commit from a different Head.
UseInputFromOtherHead
| -- | Simulate two identical utxos being committed
IdenticalCommits
deriving (Generic, Show, Enum, Bounded)

genAbortMutation :: (Tx, UTxO) -> Gen SomeMutation
Expand Down Expand Up @@ -168,6 +169,12 @@ genAbortMutation (tx, _utxo) =
[ ChangeInput input (replacePolicyIdWith testPolicyId otherHeadId output) (Just $ toScriptData Initial.ViaAbort)
, ChangeMintedValue (removePTFromMintedValue output tx)
]
, SomeMutation IdenticalCommits <$> do
(_input, output, _d) <- elements healthyCommits
newInput <- arbitrary
-- XXX: Ideally we should need to modify the PT to simulate a proper new commit
-- FIXME: this shouldn't be green
pure $ AddInput newInput output
]

removePTFromMintedValue :: TxOut CtxUTxO -> Tx -> Value
Expand Down
55 changes: 34 additions & 21 deletions hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,7 @@ import Hydra.Chain.Direct.Tx (
mkCommitDatum,
mkHeadId,
mkHeadOutput,
mkInitialOutput,
)
import qualified Hydra.Contract.Commit as Commit
import qualified Hydra.Contract.Head as Head
Expand All @@ -54,28 +55,19 @@ healthyCollectComTx =
(tx, lookupUTxO)
where
lookupUTxO =
UTxO.singleton (healthyHeadInput, healthyHeadResolvedInput) <> UTxO (fst <$> commits)
UTxO.singleton (healthyHeadInput, healthyHeadResolvedInput) <> UTxO (txOut <$> healthyCommits)

tx =
collectComTx
testNetworkId
somePartyCardanoVerificationKey
initialThreadOutput
commits
((txOut &&& scriptData) <$> healthyCommits)
(mkHeadId testPolicyId)

somePartyCardanoVerificationKey = flip generateWith 42 $ do
genForParty genVerificationKey <$> elements healthyParties

committedUTxO =
generateWith
(replicateM (length healthyParties) genCommittableTxOut)
42

commits =
(uncurry healthyCommitOutput <$> zip healthyParties committedUTxO)
& Map.fromList

headDatum = fromPlutusData $ toData healthyCollectComInitialDatum

initialThreadOutput =
Expand All @@ -85,6 +77,16 @@ healthyCollectComTx =
, initialContestationPeriod = healthyContestationPeriod
}

healthyCommits :: Map TxIn HealthyCommit
healthyCommits =
(uncurry healthyCommitOutput <$> zip healthyParties committedUTxO)
& Map.fromList
where
committedUTxO =
generateWith
(replicateM (length healthyParties) genCommittableTxOut)
42

healthyContestationPeriod :: OnChain.ContestationPeriod
healthyContestationPeriod =
arbitrary `generateWith` 42
Expand Down Expand Up @@ -123,21 +125,29 @@ genCommittableTxOut :: Gen (TxIn, TxOut CtxUTxO)
genCommittableTxOut =
Prelude.head . UTxO.pairs <$> (genAdaOnlyUTxO `suchThat` (\u -> length u > 1))

data HealthyCommit = HealthyCommit
{ cardanoKey :: VerificationKey PaymentKey
, txOut :: TxOut CtxUTxO
, scriptData :: ScriptData
}
deriving (Show)

healthyCommitOutput ::
Party ->
(TxIn, TxOut CtxUTxO) ->
(TxIn, (TxOut CtxUTxO, ScriptData))
(TxIn, HealthyCommit)
healthyCommitOutput party committed =
( txIn
,
( toCtxUTxOTxOut (TxOut commitAddress commitValue (mkTxOutDatum commitDatum) ReferenceScriptNone)
, fromPlutusData (toData commitDatum)
)
, HealthyCommit
{ cardanoKey
, txOut = toCtxUTxOTxOut (TxOut commitAddress commitValue (mkTxOutDatum commitDatum) ReferenceScriptNone)
, scriptData = fromPlutusData (toData commitDatum)
}
)
where
txIn = genTxIn `genForParty` party

cardanoVk = genVerificationKey `genForParty` party
cardanoKey = genVerificationKey `genForParty` party

commitScript =
fromPlutusScript Commit.validatorScript
Expand All @@ -147,17 +157,17 @@ healthyCommitOutput party committed =
headValue
<> (txOutValue . snd) committed
<> valueFromList
[ (AssetId testPolicyId (assetNameFromVerificationKey cardanoVk), 1)
[ (AssetId testPolicyId (assetNameFromVerificationKey cardanoKey), 1)
]
commitDatum =
mkCommitDatum party Head.validatorHash (Just committed) (toPlutusCurrencySymbol $ headPolicyId healthyHeadInput)

data CollectComMutation
= MutateOpenUTxOHash
| -- | Test that collectCom cannot collect from an initial UTxO.
MutateCommitToInitial
| MutateHeadTransition
| -- | NOTE: We want to ccheck CollectCom validator checks there's exactly the
-- expected number of commits. This is needed because the Head protocol
-- requires to ensure every party has a chance to commit.
| -- | Test that every party has a chance to commit.
MutateNumberOfParties
| MutateHeadId
| MutateRequiredSigner
Expand Down Expand Up @@ -199,6 +209,9 @@ genCollectComMutation (tx, _utxo) =
, SomeMutation MutateRequiredSigner <$> do
newSigner <- verificationKeyHash <$> genVerificationKey
pure $ ChangeRequiredSigners [newSigner]
, SomeMutation MutateCommitToInitial <$> do
(txIn, HealthyCommit{cardanoKey}) <- elements $ Map.toList healthyCommits
pure $ ChangeInput txIn (toUTxOContext $ mkInitialOutput testNetworkId testPolicyId cardanoKey) Nothing
]
where
headTxOut = fromJust $ txOuts' tx !!? 0
Expand Down
11 changes: 11 additions & 0 deletions hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs
Original file line number Diff line number Diff line change
Expand Up @@ -244,6 +244,8 @@ data Mutation
RemoveOutput Word
| -- | Drops the given input from the transaction's inputs
RemoveInput TxIn
| -- | Adds given UTxO to the transaction's inputs and UTxO context.
AddInput TxIn (TxOut CtxUTxO)
| -- | Change an input's 'TxOut' to something else.
-- This mutation alters the redeemers of the transaction to ensure
-- any matching redeemer for given input matches the new redeemer, otherwise
Expand Down Expand Up @@ -331,6 +333,15 @@ applyMutation mutation (tx@(Tx body wits), utxo) = case mutation of
in if xs' == xs
then error "RemoveInput did not remove any input."
else xs'
AddInput i o ->
( Tx body' wits
, UTxO $ Map.insert i o (UTxO.toMap utxo)
)
where
ShelleyTxBody ledgerBody scripts scriptData mAuxData scriptValidity = body
ledgerInputs' = Ledger.inputs ledgerBody <> Set.singleton (toLedgerTxIn i)
ledgerBody' = ledgerBody{Ledger.inputs = ledgerInputs'}
body' = ShelleyTxBody ledgerBody' scripts scriptData mAuxData scriptValidity
ChangeInput txIn txOut maybeRedeemer ->
( Tx body' wits
, UTxO $ Map.insert txIn txOut (UTxO.toMap utxo)
Expand Down
12 changes: 7 additions & 5 deletions hydra-node/test/Hydra/Chain/Direct/TxSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -154,6 +154,7 @@ withinTxExecutionBudget report =
} = maxTxExecutionUnits

-- | Generate a UTXO representing /commit/ outputs for a given list of `Party`.
-- NOTE: Uses 'testPolicyId' for the datum.
-- FIXME: This function is very complicated and it's hard to understand it after a while
generateCommitUTxOs :: [Party] -> Gen (Map.Map TxIn (TxOut CtxUTxO, ScriptData, UTxO))
generateCommitUTxOs parties = do
Expand All @@ -178,9 +179,9 @@ generateCommitUTxOs parties = do
TxOut
(mkScriptAddress @PlutusScriptV2 testNetworkId commitScript)
commitValue
(mkTxOutDatum $ commitDatum utxo)
(mkTxOutDatum commitDatum)
ReferenceScriptNone
, fromPlutusData (toData $ commitDatum utxo)
, fromPlutusData (toData commitDatum)
, maybe mempty (UTxO.fromPairs . pure) utxo
)
where
Expand All @@ -192,10 +193,10 @@ generateCommitUTxOs parties = do
[ (AssetId testPolicyId (assetNameFromVerificationKey vk), 1)
]
]

commitScript = fromPlutusScript Commit.validatorScript
commitDatum = \case
(Just (_input, _)) -> mkCommitDatum party Head.validatorHash utxo (toPlutusCurrencySymbol testPolicyId)
Nothing -> error "Missing utxo"

commitDatum = mkCommitDatum party Head.validatorHash utxo (toPlutusCurrencySymbol testPolicyId)

prettyEvaluationReport :: EvaluationReport -> String
prettyEvaluationReport (Map.toList -> xs) =
Expand All @@ -206,6 +207,7 @@ prettyEvaluationReport (Map.toList -> xs) =
prettyResult =
either (T.replace "\n" " " . show) show

-- NOTE: Uses 'testPolicyId' for the datum.
genAbortableOutputs :: [Party] -> Gen ([UTxOWithScript], [UTxOWithScript])
genAbortableOutputs parties =
go `suchThat` notConflict
Expand Down
20 changes: 7 additions & 13 deletions hydra-plutus/src/Hydra/Contract/Commit.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ import Plutus.V2.Ledger.Api (
Datum (..),
Redeemer (Redeemer),
Script,
ScriptContext (ScriptContext, scriptContextTxInfo),
ScriptContext (scriptContextTxInfo),
TxInfo (txInfoMint, txInfoOutputs),
TxOutRef,
Validator (getValidator),
Expand All @@ -30,7 +30,6 @@ import Plutus.V2.Ledger.Api (
)
import PlutusTx (CompiledCode, fromData, toBuiltinData, toData)
import qualified PlutusTx
import qualified PlutusTx.Builtins as Builtins
import qualified Prelude as Haskell

data CommitRedeemer
Expand Down Expand Up @@ -88,21 +87,16 @@ type RedeemerType = CommitRedeemer
--
-- * spent in a transaction also consuming a v_head output
--
-- * on abort, redistribute comitted utxo
-- * ST is burned if the redeemer is 'ViaAbort'
--
-- * ST is present in the output if the redeemer is 'ViaCollectCom'
validator :: DatumType -> RedeemerType -> ScriptContext -> Bool
validator (_party, _headScriptHash, commit, headId) r ctx@ScriptContext{scriptContextTxInfo = txInfo} =
validator (_party, _headScriptHash, _commit, headId) r ctx =
case r of
-- NOTE: The reimbursement of the committed output 'commit' is
-- delegated to the 'head' script who has more information to do it.
ViaAbort ->
traceIfFalse "ST not burned" (mustBurnST (txInfoMint $ scriptContextTxInfo ctx) headId)
&& case commit of
Nothing -> True
Just Commit{preSerializedOutput} ->
traceIfFalse
"cannot find committed output"
-- There should be an output in the transaction corresponding to this preSerializedOutput
(preSerializedOutput `elem` (Builtins.serialiseData . toBuiltinData <$> txInfoOutputs txInfo))
-- NOTE: In the Collectcom case the inclusion of the committed output 'commit' is
-- delegated to the 'CollectCom' script who has more information to do it.
ViaCollectCom ->
traceIfFalse "ST is missing in the output" (hasST headId outputs)
where
Expand Down
Loading

0 comments on commit 9cb4e1b

Please sign in to comment.