Fix state-machine in hydra scripts

CHANGELOG.md

@@ -46,6 +46,13 @@ changes.
   + View the transactions in the server output encoded as CBOR
   + Prevent utxo display in `SnapshotConfirmed` server outputs
 
+- **BREAKING** Changed the `hydra-plutus` scripts to address short-comings:
+  + Check contract continuity of state machine, i.e. that the output with the
+    state datum and ST is actually owned by vHead.
+  + Collect the right value in `collect` transactions (had been dropped for cost
+    reasons, but found a constant cost way to do it).
+  + The right `headId` is enforced in `commit` transactions.
+
 - Replaced existing websocket server with production-grade one
 
 - Removed `Greetings` messages from hydra-node history

hydra-node/src/Hydra/HeadLogic.hs

@@ -625,11 +625,7 @@ onOpenNetworkReqTx env ledger st ttl tx =
               { coordinatedHeadState =
                   coordinatedHeadState
                     { seenTxs = seenTxs <> [tx]
-                    , -- FIXME: This is never reset otherwise. For example if
-                      -- some other party was not up for some txs, but is up
-                      -- again later and we would not agree with them on the
-                      -- seen ledger.
-                      seenUTxO = utxo'
+                    , seenUTxO = utxo'
                     }
               }
         )
@@ -674,7 +670,7 @@ onOpenNetworkReqSn env ledger st otherParty sn requestedTxs =
   requireReqSn $
     -- Spec: wait s̅ = ŝ
     waitNoSnapshotInFlight $
-      -- Spec: wait U̅ ◦ T ̸= ⊥ combined with Û ← Ū̅ ◦ T
+      -- Spec: wait U̅ ◦ T /= ⊥ combined with Û ← Ū̅ ◦ T
       waitApplyTxs $ \u -> do
         -- NOTE: confSn == seenSn == sn here
         let nextSnapshot = Snapshot (confSn + 1) u requestedTxs
@@ -705,11 +701,12 @@ onOpenNetworkReqSn env ledger st otherParty sn requestedTxs =
       then continue
       else Wait $ WaitOnSnapshotNumber seenSn
 
+  -- XXX: Wait for these transactions to apply is actually not needed. They must
+  -- be applicable already. This is a bit of a precursor for only submitting
+  -- transaction ids/hashes .. which we really should do.
   waitApplyTxs cont =
     case applyTransactions ledger confirmedUTxO requestedTxs of
       Left (_, err) ->
-        -- FIXME: this will not happen, as we are always comparing against the
-        -- confirmed snapshot utxo in NewTx?
         Wait $ WaitOnNotApplicableTx err
       Right u -> cont u
 

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

@@ -40,7 +40,7 @@ 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)
+import Hydra.Ledger.Cardano (genAddressInEra, genOneUTxOFor, genValue, genVerificationKey)
 import Hydra.Ledger.Cardano.Evaluate (genValidityBoundsFromContestationPeriod)
 import Hydra.Party (Party, deriveParty, partyToChain)
 import Hydra.Snapshot (Snapshot (..), SnapshotNumber)
@@ -212,7 +212,9 @@ healthyClosedUTxO =
   genOneUTxOFor somePartyCardanoVerificationKey `generateWith` 42
 
 data CloseMutation
-  = -- | Ensures the snapshot signature is multisigned by all valid Head
+  = -- | Ensures collectCom does not allow any output address but νHead.
+    NotContinueContract
+  | -- | Ensures the snapshot signature is multisigned by all valid Head
     -- participants.
     --
     -- Invalidates the tx by changing the redeemer signature
@@ -287,7 +289,10 @@ data CloseMutation
 genCloseMutation :: (Tx, UTxO) -> Gen SomeMutation
 genCloseMutation (tx, _utxo) =
   oneof
-    [ SomeMutation (Just $ toErrorCode InvalidSnapshotSignature) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do
+    [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do
+        mutatedAddress <- genAddressInEra testNetworkId
+        pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut)
+    , SomeMutation (Just $ toErrorCode InvalidSnapshotSignature) MutateSignatureButNotSnapshotNumber . ChangeHeadRedeemer <$> do
         Head.Close . toPlutusSignatures <$> (arbitrary :: Gen (MultiSignature (Snapshot Tx)))
     , SomeMutation (Just $ toErrorCode ClosedWithNonInitialHash) MutateSnapshotNumberToLessThanEqualZero <$> do
         mutatedSnapshotNumber <- arbitrary `suchThat` (<= 0)

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

@@ -42,11 +42,11 @@ import Hydra.Contract.HeadTokens (headPolicyId)
 import Hydra.Contract.Util (UtilError (MintingOrBurningIsForbidden))
 import qualified Hydra.Data.ContestationPeriod as OnChain
 import qualified Hydra.Data.Party as OnChain
-import Hydra.Ledger.Cardano (genAdaOnlyUTxO, genTxIn, genVerificationKey)
+import Hydra.Ledger.Cardano (genAdaOnlyUTxO, genAddressInEra, genTxIn, genVerificationKey)
 import Hydra.Party (Party, partyToChain)
 import Plutus.Orphans ()
 import Plutus.V2.Ledger.Api (toBuiltin, toData)
-import Test.QuickCheck (elements, oneof, suchThat)
+import Test.QuickCheck (choose, elements, oneof, suchThat)
 import Test.QuickCheck.Instances ()
 import qualified Prelude
 
@@ -173,7 +173,11 @@ healthyCommitOutput party committed =
     mkCommitDatum party (Just committed) (toPlutusCurrencySymbol $ headPolicyId healthyHeadInput)
 
 data CollectComMutation
-  = MutateOpenUTxOHash
+  = -- | Ensures collectCom does not allow any output address but νHead.
+    NotContinueContract
+  | -- | Needs to prevent that not all value is collected into the head output.
+    ExtractSomeValue
+  | MutateOpenUTxOHash
   | -- | Ensures collectCom cannot collect from an initial UTxO.
     MutateCommitToInitial
   | -- | Every party should have commited and been taken into account for the
@@ -192,7 +196,31 @@ data CollectComMutation
 genCollectComMutation :: (Tx, UTxO) -> Gen SomeMutation
 genCollectComMutation (tx, _utxo) =
   oneof
-    [ SomeMutation (Just $ toErrorCode IncorrectUtxoHash) MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash
+    [ SomeMutation (Just $ toErrorCode NotPayingToHead) NotContinueContract <$> do
+        mutatedAddress <- genAddressInEra testNetworkId
+        pure $ ChangeOutput 0 (modifyTxOutAddress (const mutatedAddress) headTxOut)
+    , SomeMutation (Just $ toErrorCode NotAllValueCollected) ExtractSomeValue <$> do
+        -- Remove a random asset and quantity from headOutput
+        removedValue <- do
+          let allAssets = valueToList $ txOutValue headTxOut
+              nonPTs = flip filter allAssets $ \case
+                (AssetId pid _, _) -> pid /= testPolicyId
+                _ -> True
+          (assetId, Quantity n) <- elements nonPTs
+          q <- Quantity <$> choose (0, n)
+          pure $ valueFromList [(assetId, q)]
+        -- Add another output which would extract the 'removedValue'. The ledger
+        -- would check for this, and this is needed because the way we implement
+        -- collectCom checks.
+        extractionTxOut <- do
+          someAddress <- genAddressInEra testNetworkId
+          pure $ TxOut someAddress removedValue TxOutDatumNone ReferenceScriptNone
+        pure $
+          Changes
+            [ ChangeOutput 0 $ modifyTxOutValue (\v -> v <> negateValue removedValue) headTxOut
+            , AppendOutput extractionTxOut
+            ]
+    , SomeMutation (Just $ toErrorCode IncorrectUtxoHash) MutateOpenUTxOHash . ChangeOutput 0 <$> mutateUTxOHash
     , SomeMutation (Just $ toErrorCode MissingCommits) MutateNumberOfParties <$> do
         moreParties <- (: healthyOnChainParties) <$> arbitrary
         pure $
@@ -201,6 +229,9 @@ genCollectComMutation (tx, _utxo) =
             , ChangeOutput 0 $ mutatedPartiesHeadTxOut moreParties headTxOut
             ]
     , SomeMutation (Just $ toErrorCode STNotSpent) MutateHeadId <$> do
+        -- XXX: This mutation is unrealistic. It would only change the headId in
+        -- the value, but not in the datum. This is not allowed by the protocol
+        -- prior to this transaction.
         illedHeadResolvedInput <-
           mkHeadOutput
             <$> pure testNetworkId

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

@@ -20,18 +20,19 @@ import Hydra.Chain.Direct.Contract.Mutation (
 import qualified Hydra.Chain.Direct.Fixture as Fixture
 import Hydra.Chain.Direct.ScriptRegistry (genScriptRegistry, registryUTxO)
 import Hydra.Chain.Direct.Tx (commitTx, mkHeadId, mkInitialOutput)
+import qualified Hydra.Contract.Commit as Commit
 import Hydra.Contract.Error (toErrorCode)
 import Hydra.Contract.HeadTokens (headPolicyId)
 import qualified Hydra.Contract.Initial as Initial
 import Hydra.Contract.InitialError (InitialError (..))
-import Hydra.Contract.Util (UtilError (MintingOrBurningIsForbidden))
 import Hydra.Ledger.Cardano (
   genAddressInEra,
   genOutput,
   genValue,
   genVerificationKey,
  )
 import Hydra.Party (Party)
+import Plutus.V2.Ledger.Api (fromData, toData)
 import Test.QuickCheck (oneof, scale, suchThat)
 
 --
@@ -79,14 +80,17 @@ healthyCommittedUTxO = flip generateWith 42 $ do
   pure (txIn, txOut)
 
 data CommitMutation
-  = -- | Invalidates the tx by changing the commit output value.
+  = -- | The headId in the output datum must match the one from the input datum.
+    NonContinuousHeadId
+  | -- | Invalidates the tx by changing the commit output value.
     --
     -- Ensures the committed value is consistent with the locked value by the
     -- commit validator.
     MutateCommitOutputValue
   | -- | Invalidates the tx by changing the value of the input committed utxo.
     --
-    -- Ensures the output committed utxo value is consistent with the input committed utxo value.
+    -- Ensures the output committed utxo value is consistent with the input
+    -- committed utxo value.
     MutateCommittedValue
   | -- | Invalidates the tx by changing the address of the input out-ref.
     --
@@ -99,15 +103,25 @@ data CommitMutation
     -- a different head. The signer shows a correct signature but from a
     -- different head. This will cause the signer to not be present in the
     -- participation tokens.
-    CommitFromDifferentHead
+    UsePTFromDifferentHead
   | -- | Minting or burning of the tokens should not be possible in commit.
     MutateTokenMintingOrBurning
   deriving (Generic, Show, Enum, Bounded)
 
 genCommitMutation :: (Tx, UTxO) -> Gen SomeMutation
 genCommitMutation (tx, _utxo) =
   oneof
-    [ SomeMutation (Just $ toErrorCode LockedValueDoesNotMatch) MutateCommitOutputValue . ChangeOutput 0 <$> do
+    [ SomeMutation (Just $ toErrorCode WrongHeadIdInCommitDatum) NonContinuousHeadId <$> do
+        otherHeadId <- fmap headPolicyId (arbitrary `suchThat` (/= healthyIntialTxIn))
+        let mutateHeadId = modifyTxOutDatum $ \case
+              TxOutDatumInTx sd ->
+                case fromData $ toPlutusData sd of
+                  Just ((party, mCommit, _headId) :: Commit.DatumType) ->
+                    TxOutDatumInTx $ fromPlutusData $ toData (party, mCommit, toPlutusCurrencySymbol otherHeadId)
+                  Nothing -> error "Not a commit datum"
+              _ -> error "expected datum in tx"
+        pure $ ChangeOutput 0 $ mutateHeadId commitTxOut
+    , SomeMutation (Just $ toErrorCode LockedValueDoesNotMatch) MutateCommitOutputValue . ChangeOutput 0 <$> do
         mutatedValue <- scale (`div` 2) genValue `suchThat` (/= commitOutputValue)
         pure $ commitTxOut{txOutValue = mutatedValue}
     , SomeMutation (Just $ toErrorCode LockedValueDoesNotMatch) MutateCommittedValue <$> do
@@ -123,7 +137,7 @@ genCommitMutation (tx, _utxo) =
         pure $ ChangeRequiredSigners [newSigner]
     , -- XXX: This is a bit confusing and not giving much value. Maybe we can remove this.
       -- This also seems to be covered by MutateRequiredSigner
-      SomeMutation (Just $ toErrorCode CouldNotFindTheCorrectCurrencySymbolInTokens) CommitFromDifferentHead <$> do
+      SomeMutation (Just $ toErrorCode CouldNotFindTheCorrectCurrencySymbolInTokens) UsePTFromDifferentHead <$> do
         otherHeadId <- fmap headPolicyId (arbitrary `suchThat` (/= healthyIntialTxIn))
         pure $
           Changes