Merge pull request #1163 from input-output-hk/abailly-iohk/1104/adjust-inconsistencies

Align minor discrepancies between spec and code

Author: ch1bo

hydra-node/src/Hydra/Ledger/Cardano.hs

@@ -109,6 +109,8 @@ instance IsTx Tx where
 
   txId = getTxId . getTxBody
   balance = foldMap txOutValue
+
+  -- NOTE: See note from `Head.hashTxOuts`.
   hashUTxO = fromBuiltin . Head.hashTxOuts . mapMaybe toPlutusTxOut . toList
 
 instance ToCBOR Tx where

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

@@ -19,6 +19,7 @@ import Hydra.Chain.Direct.Contract.Mutation (
   changeMintedTokens,
   changeMintedValueQuantityFrom,
   isHeadOutput,
+  removePTFromMintedValue,
   replacePolicyIdWith,
  )
 import Hydra.Chain.Direct.Fixture (testNetworkId, testPolicyId, testSeedInput)
@@ -248,22 +249,3 @@ genAbortMutation (tx, utxo) =
     , SomeMutation (Just $ toErrorCode STNotBurned) DoNotBurnSTInitial
         <$> changeMintedTokens tx (valueFromList [(AssetId (headPolicyId testSeedInput) hydraHeadV1AssetName, 1)])
     ]
-
-removePTFromMintedValue :: TxOut CtxUTxO -> Tx -> Value
-removePTFromMintedValue output tx =
-  case txMintValue $ txBodyContent $ txBody tx of
-    TxMintValueNone -> error "expected minted value"
-    TxMintValue v _ -> valueFromList $ filter (not . isPT) $ valueToList v
- where
-  outValue = txOutValue output
-  assetNames =
-    [ (policyId, pkh) | (AssetId policyId pkh, _) <- valueToList outValue, policyId == testPolicyId
-    ]
-  (headId, assetName) =
-    case assetNames of
-      [assetId] -> assetId
-      _ -> error "expected one assetId"
-  isPT = \case
-    (AssetId pid asset, _) ->
-      pid == headId && asset == assetName
-    _ -> False

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

@@ -7,7 +7,7 @@ import Hydra.Cardano.Api
 import Hydra.Prelude hiding (label)
 
 import Cardano.Api.UTxO as UTxO
-import Hydra.Chain.Direct.Contract.Mutation (Mutation (..), SomeMutation (..))
+import Hydra.Chain.Direct.Contract.Mutation (Mutation (..), SomeMutation (..), changeMintedTokens)
 import Hydra.Chain.Direct.Fixture (testNetworkId, testPolicyId, testSeedInput)
 import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
 import Hydra.Chain.Direct.Tx (fanoutTx, mkHeadOutput)
@@ -24,11 +24,11 @@ import Hydra.Ledger.Cardano (
   genValue,
  )
 import Hydra.Ledger.Cardano.Evaluate (slotNoFromUTCTime, slotNoToUTCTime)
-import Hydra.Party (partyToChain)
+import Hydra.Party (Party, partyToChain, vkey)
 import Hydra.Plutus.Extras (posixFromUTCTime)
 import Hydra.Plutus.Orphans ()
 import PlutusTx.Builtins (toBuiltin)
-import Test.QuickCheck (choose, elements, oneof, suchThat, vectorOf)
+import Test.QuickCheck (choose, elements, oneof, suchThat)
 import Test.QuickCheck.Instances ()
 
 healthyFanoutTx :: (Tx, UTxO)
@@ -55,17 +55,15 @@ healthyFanoutTx =
 
   headOutput' = mkHeadOutput testNetworkId testPolicyId (toUTxOContext $ mkTxOutDatumInline healthyFanoutDatum)
 
-  parties = generateWith (vectorOf 3 (arbitrary @(VerificationKey PaymentKey))) 42
-
   headOutput = modifyTxOutValue (<> participationTokens) headOutput'
 
   participationTokens =
     valueFromList $
       map
-        ( \vk ->
-            (AssetId testPolicyId (AssetName . serialiseToRawBytes . verificationKeyHash $ vk), 1)
+        ( \party ->
+            (AssetId testPolicyId (AssetName . serialiseToRawBytes . verificationKeyHash . vkey $ party), 1)
         )
-        parties
+        healthyParties
 
 healthyFanoutUTxO :: UTxO
 healthyFanoutUTxO =
@@ -84,7 +82,8 @@ healthyFanoutDatum =
   Head.Closed
     { snapshotNumber = 1
     , utxoHash = toBuiltin $ hashUTxO @Tx healthyFanoutUTxO
-    , parties = partyToChain <$> arbitrary `generateWith` 42
+    , parties =
+        partyToChain <$> healthyParties
     , contestationDeadline = posixFromUTCTime healthyContestationDeadline
     , contestationPeriod = healthyContestationPeriod
     , headId = toPlutusCurrencySymbol testPolicyId
@@ -95,10 +94,17 @@ healthyFanoutDatum =
 
   healthyContestationPeriod = OnChain.contestationPeriodFromDiffTime $ fromInteger healthyContestationPeriodSeconds
 
+healthyParties :: [Party]
+healthyParties =
+  [ generateWith arbitrary i | i <- [1 .. 3]
+  ]
+
 data FanoutMutation
   = MutateAddUnexpectedOutput
   | MutateChangeOutputValue
   | MutateValidityBeforeDeadline
+  | -- | Meant to test that the minting policy is burning all PTs and ST present in tx
+    MutateThreadTokenQuantity
   deriving stock (Generic, Show, Enum, Bounded)
 
 genFanoutMutation :: (Tx, UTxO) -> Gen SomeMutation
@@ -117,6 +123,14 @@ genFanoutMutation (tx, _utxo) =
     , SomeMutation (Just $ toErrorCode LowerBoundBeforeContestationDeadline) MutateValidityBeforeDeadline . ChangeValidityInterval <$> do
         lb <- genSlotBefore $ slotNoFromUTCTime healthyContestationDeadline
         pure (TxValidityLowerBound lb, TxValidityNoUpperBound)
+    , SomeMutation (Just $ toErrorCode BurntTokenNumberMismatch) MutateThreadTokenQuantity <$> do
+        (token, _) <- elements burntTokens
+        changeMintedTokens tx (valueFromList [(token, 1)])
     ]
  where
+  burntTokens =
+    case txMintValue $ txBodyContent $ txBody tx of
+      TxMintValueNone -> error "expected minted value"
+      TxMintValue v _ -> valueToList v
+
   genSlotBefore (SlotNo slot) = SlotNo <$> choose (0, slot)

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

@@ -872,3 +872,22 @@ replaceContesters contesters = \case
       , Head.contesters = contesters
       }
   otherState -> otherState
+
+removePTFromMintedValue :: TxOut CtxUTxO -> Tx -> Value
+removePTFromMintedValue output tx =
+  case txMintValue $ txBodyContent $ txBody tx of
+    TxMintValueNone -> error "expected minted value"
+    TxMintValue v _ -> valueFromList $ filter (not . isPT) $ valueToList v
+ where
+  outValue = txOutValue output
+  assetNames =
+    [ (policyId, pkh) | (AssetId policyId pkh, _) <- valueToList outValue, policyId == testPolicyId
+    ]
+  (headId, assetName) =
+    case assetNames of
+      [assetId] -> assetId
+      _ -> error "expected one assetId"
+  isPT = \case
+    (AssetId pid asset, _) ->
+      pid == headId && asset == assetName
+    _ -> False

hydra-plutus/scripts/mHead.plutus

@@ -17,7 +17,7 @@ import Hydra.Contract.Commit (Commit (..))
 import Hydra.Contract.Commit qualified as Commit
 import Hydra.Contract.HeadError (HeadError (..), errorCode)
 import Hydra.Contract.HeadState (Input (..), Signature, SnapshotNumber, State (..))
-import Hydra.Contract.Util (hasST, mustNotMintOrBurn, (===))
+import Hydra.Contract.Util (hasST, mustBurnAllHeadTokens, mustNotMintOrBurn, (===))
 import Hydra.Data.ContestationPeriod (ContestationPeriod, addContestationPeriod, milliseconds)
 import Hydra.Data.Party (Party (vkey))
 import Hydra.Plutus.Extras (ValidatorType, scriptValidatorHash, wrapValidator)
@@ -44,7 +44,7 @@ import PlutusLedgerApi.V2 (
   TxOut (..),
   TxOutRef (..),
   UpperBound (..),
-  Value (Value, getValue),
+  Value (Value),
   adaSymbol,
   adaToken,
  )
@@ -77,8 +77,8 @@ headValidator oldState input ctx =
       checkClose ctx parties initialUtxoHash signature contestationPeriod headId
     (Closed{parties, snapshotNumber = closedSnapshotNumber, contestationDeadline, contestationPeriod, headId, contesters}, Contest{signature}) ->
       checkContest ctx contestationDeadline contestationPeriod parties closedSnapshotNumber signature contesters headId
-    (Closed{utxoHash, contestationDeadline}, Fanout{numberOfFanoutOutputs}) ->
-      checkFanout utxoHash contestationDeadline numberOfFanoutOutputs ctx
+    (Closed{parties, utxoHash, contestationDeadline, headId}, Fanout{numberOfFanoutOutputs}) ->
+      checkFanout utxoHash contestationDeadline numberOfFanoutOutputs ctx headId parties
     _ ->
       traceError $(errorCode InvalidHeadStateTransition)
 
@@ -96,20 +96,11 @@ checkAbort ::
   [Party] ->
   Bool
 checkAbort ctx@ScriptContext{scriptContextTxInfo = txInfo} headCurrencySymbol parties =
-  mustBurnAllHeadTokens
+  mustBurnAllHeadTokens minted headCurrencySymbol parties
     && mustBeSignedByParticipant ctx headCurrencySymbol
     && mustReimburseCommittedUTxO
  where
-  mustBurnAllHeadTokens =
-    traceIfFalse $(errorCode BurntTokenNumberMismatch) $
-      burntTokens == length parties + 1
-
-  minted = getValue $ txInfoMint txInfo
-
-  burntTokens =
-    case AssocMap.lookup headCurrencySymbol minted of
-      Nothing -> 0
-      Just tokenMap -> negate $ sum tokenMap
+  minted = txInfoMint txInfo
 
   mustReimburseCommittedUTxO =
     traceIfFalse $(errorCode ReimbursedOutputsDontMatch) $
@@ -451,10 +442,16 @@ checkFanout ::
   POSIXTime ->
   Integer ->
   ScriptContext ->
+  CurrencySymbol ->
+  [Party] ->
   Bool
-checkFanout utxoHash contestationDeadline numberOfFanoutOutputs ScriptContext{scriptContextTxInfo = txInfo} =
-  hasSameUTxOHash && afterContestationDeadline
+checkFanout utxoHash contestationDeadline numberOfFanoutOutputs ScriptContext{scriptContextTxInfo = txInfo} currencySymbol parties =
+  mustBurnAllHeadTokens minted currencySymbol parties
+    && hasSameUTxOHash
+    && afterContestationDeadline
  where
+  minted = txInfoMint txInfo
+
   hasSameUTxOHash =
     traceIfFalse $(errorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) $
       fannedOutUtxoHash == utxoHash
@@ -556,6 +553,8 @@ getTxOutDatum o =
 
 -- | Hash a potentially unordered list of commits by sorting them, concatenating
 -- their 'preSerializedOutput' bytes and creating a SHA2_256 digest over that.
+--
+-- NOTE: See note from `hashTxOuts`.
 hashPreSerializedCommits :: [Commit] -> BuiltinByteString
 hashPreSerializedCommits commits =
   sha2_256 . foldMap preSerializedOutput $
@@ -565,6 +564,13 @@ hashPreSerializedCommits commits =
 -- | Hash a pre-ordered list of transaction outputs by serializing each
 -- individual 'TxOut', concatenating all bytes together and creating a SHA2_256
 -- digest over that.
+--
+-- NOTE: In general, from asserting that `hash(x || y) = hash (x' || y')` it is
+-- not safe to conclude that `(x,y) = (x', y')` as the same hash could be
+-- obtained by moving one or more bytes from the end of `x` to the beginning of
+-- `y`, but in the context of Hydra validators it seems impossible to exploit
+-- this property without breaking other logic or verification (eg. producing a
+-- valid and meaningful `TxOut`).
 hashTxOuts :: [TxOut] -> BuiltinByteString
 hashTxOuts =
   sha2_256 . foldMap (Builtins.serialiseData . toBuiltinData)

hydra-plutus/scripts/vHead.plutus

@@ -1,8 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-specialize #-}
 
 module Hydra.Contract.Util where
 
 import Hydra.Contract.Error (ToErrorCode (..))
+import Hydra.Contract.HeadError (HeadError (..), errorCode)
+import Hydra.Data.Party (Party)
 import Hydra.Prelude (Show)
 import PlutusLedgerApi.V1.Value (isZero)
 import PlutusLedgerApi.V2 (
@@ -29,6 +32,20 @@ hasST headPolicyId v =
     pure $ quantity == 1
 {-# INLINEABLE hasST #-}
 
+-- | Checks all tokens related to some specific `CurrencySymbol`.
+--
+-- This checks both PTs and ST are burnt.
+mustBurnAllHeadTokens :: Value -> CurrencySymbol -> [Party] -> Bool
+mustBurnAllHeadTokens minted headCurrencySymbol parties =
+  traceIfFalse $(errorCode BurntTokenNumberMismatch) $
+    burntTokens == length parties + 1
+ where
+  burntTokens =
+    case AssocMap.lookup headCurrencySymbol (getValue minted) of
+      Nothing -> 0
+      Just tokenMap -> negate $ sum tokenMap
+{-# INLINEABLE mustBurnAllHeadTokens #-}
+
 -- | Checks if the state token (ST) for list of parties containing specific
 -- 'CurrencySymbol' are burnt.
 mustBurnST :: Value -> CurrencySymbol -> Bool

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

@@ -108,7 +108,7 @@ \subsection{Init transaction}\label{sec:init-tx}
 	      \end{menumerate}
 	\item When evaluated with the $\mathsf{burn}$ redeemer,
 	      \begin{menumerate}
-		      \item All tokens in $\txMint$ need to be of negative quantity
+		      \item All tokens for this policy in $\txMint$ need to be of negative quantity
 		      $\forall \{\cid \mapsto \cdot \mapsto q\} \in \txMint : q < 0$.
 	      \end{menumerate}
 \end{itemize}