Guard against non-expected parties during init observation.

hydra-cardano-api/src/Hydra/Cardano/Api/Value.hs

@@ -12,6 +12,16 @@ import qualified Plutus.V1.Ledger.Api as Plutus
 valueSize :: Value -> Int
 valueSize = length . valueToList
 
+-- | Access minted assets of a transaction, as an ordered association list.
+txMintAssets :: Tx era -> [(AssetId, Quantity)]
+txMintAssets =
+  asList . txMintValue . getTxBodyContent . getTxBody
+ where
+  getTxBodyContent (TxBody x) = x
+  asList = \case
+    TxMintNone -> []
+    TxMintValue _ val _ -> valueToList val
+
 -- * Type Conversions
 
 -- | Convert a cardano-ledger's 'Value'  into a cardano-api's 'Value'

hydra-node/src/Hydra/Chain/Direct.hs

@@ -42,6 +42,7 @@ import Control.Monad.Class.MonadSTM (
 import Control.Monad.Class.MonadTimer (timeout)
 import Control.Tracer (nullTracer)
 import Data.Aeson (Value (String), object, (.=))
+import Data.List ((\\))
 import Data.Sequence.Strict (StrictSeq)
 import Hydra.Cardano.Api (
   NetworkId,
@@ -147,7 +148,7 @@ withDirectChain ::
   (VerificationKey PaymentKey, SigningKey PaymentKey) ->
   -- | Hydra party of our hydra node.
   Party ->
-  -- | Cardano keys of all Head participants.
+  -- | Cardano keys of all Head participants (including our key pair).
   [VerificationKey PaymentKey] ->
   ChainComponent Tx IO ()
 withDirectChain tracer networkId iocp socketPath keyPair party cardanoKeys callback action = do
@@ -158,6 +159,7 @@ withDirectChain tracer networkId iocp socketPath keyPair party cardanoKeys callb
         SomeOnChainHeadState $
           idleOnChainHeadState
             networkId
+            (cardanoKeys \\ [verificationKey wallet])
             (verificationKey wallet)
             party
     race_

hydra-node/src/Hydra/Chain/Direct/Context.hs

@@ -4,6 +4,7 @@ module Hydra.Chain.Direct.Context where
 
 import Hydra.Prelude
 
+import Data.List ((\\))
 import Hydra.Cardano.Api (
   NetworkId (..),
   NetworkMagic (..),
@@ -78,7 +79,8 @@ genStIdle ::
 genStIdle HydraContext{ctxVerificationKeys, ctxNetworkId, ctxParties} = do
   ownParty <- elements ctxParties
   ownVerificationKey <- elements ctxVerificationKeys
-  pure $ idleOnChainHeadState ctxNetworkId ownVerificationKey ownParty
+  let peerVerificationKeys = ctxVerificationKeys \\ [ownVerificationKey]
+  pure $ idleOnChainHeadState ctxNetworkId peerVerificationKeys ownVerificationKey ownParty
 
 genStInitialized ::
   HydraContext ->
@@ -102,8 +104,9 @@ genCommits ::
   Tx ->
   Gen [Tx]
 genCommits ctx initTx = do
-  forM (zip (ctxVerificationKeys ctx) (ctxParties ctx)) $ \(p, vk) -> do
-    let stIdle = idleOnChainHeadState (ctxNetworkId ctx) p vk
+  forM (zip (ctxVerificationKeys ctx) (ctxParties ctx)) $ \(vk, p) -> do
+    let peerVerificationKeys = ctxVerificationKeys ctx \\ [vk]
+    let stIdle = idleOnChainHeadState (ctxNetworkId ctx) peerVerificationKeys vk p
     let (_, stInitialized) = unsafeObserveTx @_ @ 'StInitialized initTx stIdle
     utxo <- genCommit
     pure $ unsafeCommit utxo stInitialized

hydra-node/src/Hydra/Chain/Direct/State.hs

@@ -66,6 +66,7 @@ import qualified Text.Show
 -- happening on the layer-1 for a given Hydra head.
 data OnChainHeadState (st :: HeadStateKind) = OnChainHeadState
   { networkId :: NetworkId
+  , peerVerificationKeys :: [VerificationKey PaymentKey]
   , ownVerificationKey :: VerificationKey PaymentKey
   , ownParty :: Party
   , stateMachine :: HydraStateMachine st
@@ -180,12 +181,14 @@ reifyState OnChainHeadState{stateMachine} =
 -- | Initialize a new 'OnChainHeadState'.
 idleOnChainHeadState ::
   NetworkId ->
+  [VerificationKey PaymentKey] ->
   VerificationKey PaymentKey ->
   Party ->
   OnChainHeadState 'StIdle
-idleOnChainHeadState networkId ownVerificationKey ownParty =
+idleOnChainHeadState networkId peerVerificationKeys ownVerificationKey ownParty =
   OnChainHeadState
     { networkId
+    , peerVerificationKeys
     , ownVerificationKey
     , ownParty
     , stateMachine = Idle
@@ -316,14 +319,16 @@ instance HasTransition 'StIdle where
     ]
 
 instance ObserveTx 'StIdle 'StInitialized where
-  observeTx tx OnChainHeadState{networkId, ownParty, ownVerificationKey} = do
-    (event, observation) <- observeInitTx networkId ownParty tx
+  observeTx tx OnChainHeadState{networkId, peerVerificationKeys, ownParty, ownVerificationKey} = do
+    let allVerificationKeys = ownVerificationKey : peerVerificationKeys
+    (event, observation) <- observeInitTx networkId allVerificationKeys ownParty tx
     let InitObservation{threadOutput, initials, commits, headId, headTokenScript} = observation
     let st' =
           OnChainHeadState
             { networkId
             , ownParty
             , ownVerificationKey
+            , peerVerificationKeys
             , stateMachine =
                 Initialized
                   { initialThreadOutput = threadOutput
@@ -370,14 +375,15 @@ instance ObserveTx 'StInitialized 'StInitialized where
       } = stateMachine
 
 instance ObserveTx 'StInitialized 'StOpen where
-  observeTx tx st@OnChainHeadState{networkId, ownVerificationKey, ownParty, stateMachine} = do
+  observeTx tx st@OnChainHeadState{networkId, peerVerificationKeys, ownVerificationKey, ownParty, stateMachine} = do
     let utxo = getKnownUTxO st
     (event, observation) <- observeCollectComTx utxo tx
     let CollectComObservation{threadOutput, headId} = observation
     guard (headId == initialHeadId)
     let st' =
           OnChainHeadState
             { networkId
+            , peerVerificationKeys
             , ownVerificationKey
             , ownParty
             , stateMachine =
@@ -395,12 +401,13 @@ instance ObserveTx 'StInitialized 'StOpen where
       } = stateMachine
 
 instance ObserveTx 'StInitialized 'StIdle where
-  observeTx tx st@OnChainHeadState{networkId, ownVerificationKey, ownParty} = do
+  observeTx tx st@OnChainHeadState{networkId, peerVerificationKeys, ownVerificationKey, ownParty} = do
     let utxo = getKnownUTxO st
     (event, ()) <- observeAbortTx utxo tx
     let st' =
           OnChainHeadState
             { networkId
+            , peerVerificationKeys
             , ownVerificationKey
             , ownParty
             , stateMachine = Idle
@@ -417,14 +424,15 @@ instance HasTransition 'StOpen where
     ]
 
 instance ObserveTx 'StOpen 'StClosed where
-  observeTx tx st@OnChainHeadState{networkId, ownVerificationKey, ownParty, stateMachine} = do
+  observeTx tx st@OnChainHeadState{networkId, peerVerificationKeys, ownVerificationKey, ownParty, stateMachine} = do
     let utxo = getKnownUTxO st
     (event, observation) <- observeCloseTx utxo tx
     let CloseObservation{threadOutput, headId} = observation
     guard (headId == openHeadId)
     let st' =
           OnChainHeadState
             { networkId
+            , peerVerificationKeys
             , ownVerificationKey
             , ownParty
             , stateMachine =
@@ -451,12 +459,13 @@ instance HasTransition 'StClosed where
     ]
 
 instance ObserveTx 'StClosed 'StIdle where
-  observeTx tx st@OnChainHeadState{networkId, ownVerificationKey, ownParty} = do
+  observeTx tx st@OnChainHeadState{networkId, peerVerificationKeys, ownVerificationKey, ownParty} = do
     let utxo = getKnownUTxO st
     (event, ()) <- observeFanoutTx utxo tx
     let st' =
           OnChainHeadState
             { networkId
+            , peerVerificationKeys
             , ownVerificationKey
             , ownParty
             , stateMachine = Idle

hydra-node/src/Hydra/Chain/Direct/Tx.hs

@@ -400,17 +400,21 @@ data InitObservation = InitObservation
 -- only returning a Maybe, i.e. 'Either Reason (OnChainTx tx, OnChainHeadState)'
 observeInitTx ::
   NetworkId ->
+  [VerificationKey PaymentKey] ->
   Party ->
   Tx ->
   Maybe (OnChainTx Tx, InitObservation)
-observeInitTx networkId party tx = do
+observeInitTx networkId cardanoKeys party tx = do
   -- FIXME: This is affected by "same structure datum attacks", we should be
   -- using the Head script address instead.
   (ix, headOut, headData, Head.Initial cp ps) <- findFirst headOutput indexedOutputs
   let parties = map convertParty ps
   let cperiod = contestationPeriodToDiffTime cp
   guard $ party `elem` parties
-  (headTokenPolicyId, _headAssetName) <- findHeadAssetId headOut
+  (headTokenPolicyId, headAssetName) <- findHeadAssetId headOut
+  let expectedNames = assetNameFromVerificationKey <$> cardanoKeys
+  let actualNames = assetNames headAssetName
+  guard $ sort expectedNames == sort actualNames
   headTokenScript <- findScriptMinting tx headTokenPolicyId
   pure
     ( OnInitTx cperiod parties
@@ -451,6 +455,12 @@ observeInitTx networkId party tx = do
 
   initialScript = fromPlutusScript Initial.validatorScript
 
+  assetNames headAssetName =
+    [ assetName
+    | (AssetId _ assetName, _) <- txMintAssets tx
+    , assetName /= headAssetName
+    ]
+
 convertParty :: OnChain.Party -> Party
 convertParty = Party . partyToVerKey
 

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

@@ -6,16 +6,20 @@ import Hydra.Cardano.Api
 import Hydra.Prelude
 
 import qualified Cardano.Api.UTxO as UTxO
+import Data.List ((\\))
 import Hydra.Chain (HeadParameters (..))
 import Hydra.Chain.Direct.Contract.Mutation (
   Mutation (..),
   SomeMutation (..),
   addPTWithQuantity,
+  cardanoCredentialsFor,
   changeMintedValueQuantityFrom,
  )
 import Hydra.Chain.Direct.Fixture (testNetworkId)
-import Hydra.Chain.Direct.Tx (initTx)
-import Hydra.Ledger.Cardano (genOneUTxOFor, genValue)
+import Hydra.Chain.Direct.State (HeadStateKind (..), OnChainHeadState, idleOnChainHeadState)
+import Hydra.Chain.Direct.Tx (hydraHeadV1AssetName, initTx)
+import Hydra.Ledger.Cardano (genOneUTxOFor, genValue, genVerificationKey)
+import Hydra.Party (Party)
 import Test.QuickCheck (choose, elements, oneof, suchThat, vectorOf)
 import qualified Prelude
 
@@ -30,34 +34,49 @@ healthyInitTx =
   tx =
     initTx
       testNetworkId
-      healthyParties
-      parameters
+      healthyCardanoKeys
+      healthyHeadParameters
       healthySeedInput
 
-  parameters =
-    flip generateWith 42 $
-      HeadParameters
-        <$> arbitrary
-        <*> vectorOf (length healthyParties) arbitrary
+healthyHeadParameters :: HeadParameters
+healthyHeadParameters =
+  flip generateWith 42 $
+    HeadParameters
+      <$> arbitrary
+      <*> vectorOf (length healthyParties) arbitrary
 
 healthySeedInput :: TxIn
 healthySeedInput =
   fst . Prelude.head $ UTxO.pairs healthyLookupUTxO
 
-healthyParties :: [VerificationKey PaymentKey]
+healthyParties :: [Party]
 healthyParties =
   generateWith (vectorOf 3 arbitrary) 42
 
+healthyCardanoKeys :: [VerificationKey PaymentKey]
+healthyCardanoKeys =
+  fst . cardanoCredentialsFor <$> healthyParties
+
 healthyLookupUTxO :: UTxO
 healthyLookupUTxO =
-  generateWith (genOneUTxOFor (Prelude.head healthyParties)) 42
+  generateWith (genOneUTxOFor (Prelude.head healthyCardanoKeys)) 42
+
+genHealthyIdleSt :: Gen (OnChainHeadState 'StIdle)
+genHealthyIdleSt = do
+  party <- elements healthyParties
+  let (vk, _sk) = cardanoCredentialsFor party
+  pure $ idleOnChainHeadState testNetworkId (healthyCardanoKeys \\ [vk]) vk party
 
 data InitMutation
   = MutateThreadTokenQuantity
   | MutateAddAnotherPT
-  | MutateInitialOutputValue
   | MutateDropInitialOutput
   | MutateDropSeedInput
+  | MutateInitialOutputValue
+  deriving (Generic, Show, Enum, Bounded)
+
+data ObserveInitMutation
+  = MutateSomePT
   deriving (Generic, Show, Enum, Bounded)
 
 genInitMutation :: (Tx, UTxO) -> Gen SomeMutation
@@ -67,7 +86,7 @@ genInitMutation (tx, _utxo) =
     , SomeMutation MutateAddAnotherPT <$> addPTWithQuantity tx 1
     , SomeMutation MutateInitialOutputValue <$> do
         let outs = txOuts' tx
-        (ix, out) <- elements (zip [1 .. length outs - 1] outs)
+        (ix :: Int, out) <- elements (drop 1 $ zip [0 ..] outs)
         value' <- genValue `suchThat` (/= txOutValue out)
         pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out)
     , SomeMutation MutateDropInitialOutput <$> do
@@ -76,3 +95,29 @@ genInitMutation (tx, _utxo) =
     , SomeMutation MutateDropSeedInput <$> do
         pure $ RemoveInput healthySeedInput
     ]
+
+-- These are mutations we expect to be valid from an on-chain standpoint, yet
+-- invalid for the off-chain observation. There's mainly only the `init`
+-- transaction which is in this situation, because the on-chain parameters are
+-- specified during the init and there's no way to check, on-chain, that they
+-- correspond to what a node expects in terms of configuration.
+genObserveInitMutation :: (Tx, UTxO) -> Gen SomeMutation
+genObserveInitMutation (tx, _utxo) =
+  oneof
+    [ SomeMutation MutateSomePT <$> do
+        let minted = txMintAssets tx
+        vk' <- genVerificationKey `suchThat` (`notElem` healthyCardanoKeys)
+        let minted' = swapTokenName (verificationKeyHash vk') minted
+        pure $ ChangeMintedValue (valueFromList minted')
+    ]
+ where
+  swapTokenName :: Hash PaymentKey -> [(AssetId, Quantity)] -> [(AssetId, Quantity)]
+  swapTokenName vkh = \case
+    [] ->
+      []
+    x@(AdaAssetId, _) : xs ->
+      x : swapTokenName vkh xs
+    x@(AssetId pid assetName, q) : xs ->
+      if assetName == hydraHeadV1AssetName
+        then x : swapTokenName vkh xs
+        else (AssetId pid (AssetName $ serialiseToRawBytes vkh), q) : xs