Merge pull request #382 from input-output-hk/ensemble/abort-validators

Abort validator checking PTs

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

@@ -4,9 +4,7 @@ import Hydra.Cardano.Api.Prelude
 
 import qualified Cardano.Ledger.Credential as Ledger
 
--- | Extract the payment part of an address, as a script hash. If any
---
--- Used: Hydra.Ledger.Cardano#findScriptOutput L621
+-- | Extract the payment part of an address, as a script hash.
 getPaymentScriptHash :: AddressInEra era -> Maybe ScriptHash
 getPaymentScriptHash = \case
   AddressInEra _ (ShelleyAddress _ (Ledger.ScriptHashObj h) _) ->

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+
 module Hydra.Cardano.Api.TxOut where
 
 import Hydra.Cardano.Api.MultiAssetSupportedInEra (HasMultiAsset (..))
@@ -69,16 +71,6 @@ findTxOutByScript utxo script =
        in scriptHash == scriptHash'
     _ ->
       False
-
-findScriptOutput ::
-  forall lang.
-  (HasPlutusScriptVersion lang) =>
-  UTxO ->
-  PlutusScript lang ->
-  Maybe (TxIn, TxOut CtxUTxO Era)
-findScriptOutput =
-  findTxOutByScript
-
 -- * Type Conversions
 
 -- | Convert a cardano-api's 'TxOut' into a cardano-ledger 'TxOut'

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

@@ -675,14 +675,14 @@ observeCollectComTx ::
   Tx ->
   Maybe CollectComObservation
 observeCollectComTx utxo tx = do
-  (headInput, headOutput) <- findScriptOutput @PlutusScriptV1 utxo headScript
+  (headInput, headOutput) <- findTxOutByScript @PlutusScriptV1 utxo headScript
   redeemer <- findRedeemerSpending tx headInput
   oldHeadDatum <- lookupScriptData tx headOutput
   datum <- fromData $ toPlutusData oldHeadDatum
   headId <- findStateToken headOutput
   case (datum, redeemer) of
     (Head.Initial{parties, contestationPeriod}, Head.CollectCom) -> do
-      (newHeadInput, newHeadOutput) <- findScriptOutput @PlutusScriptV1 (utxoFromTx tx) headScript
+      (newHeadInput, newHeadOutput) <- findTxOutByScript @PlutusScriptV1 (utxoFromTx tx) headScript
       newHeadDatum <- lookupScriptData tx newHeadOutput
       utxoHash <- decodeUtxoHash newHeadDatum
       pure
@@ -723,14 +723,14 @@ observeCloseTx ::
   Tx ->
   Maybe CloseObservation
 observeCloseTx utxo tx = do
-  (headInput, headOutput) <- findScriptOutput @PlutusScriptV1 utxo headScript
+  (headInput, headOutput) <- findTxOutByScript @PlutusScriptV1 utxo headScript
   redeemer <- findRedeemerSpending tx headInput
   oldHeadDatum <- lookupScriptData tx headOutput
   datum <- fromData $ toPlutusData oldHeadDatum
   headId <- findStateToken headOutput
   case (datum, redeemer) of
     (Head.Open{parties}, Head.Close{snapshotNumber = onChainSnapshotNumber}) -> do
-      (newHeadInput, newHeadOutput) <- findScriptOutput @PlutusScriptV1 (utxoFromTx tx) headScript
+      (newHeadInput, newHeadOutput) <- findTxOutByScript @PlutusScriptV1 (utxoFromTx tx) headScript
       newHeadDatum <- lookupScriptData tx newHeadOutput
       closeContestationDeadline <- case fromData (toPlutusData newHeadDatum) of
         Just Head.Closed{contestationDeadline} -> pure contestationDeadline
@@ -770,14 +770,14 @@ observeContestTx ::
   Tx ->
   Maybe ContestObservation
 observeContestTx utxo tx = do
-  (headInput, headOutput) <- findScriptOutput @PlutusScriptV1 utxo headScript
+  (headInput, headOutput) <- findTxOutByScript @PlutusScriptV1 utxo headScript
   redeemer <- findRedeemerSpending tx headInput
   oldHeadDatum <- lookupScriptData tx headOutput
   datum <- fromData $ toPlutusData oldHeadDatum
   headId <- findStateToken headOutput
   case (datum, redeemer) of
     (Head.Closed{}, Head.Contest{snapshotNumber = onChainSnapshotNumber}) -> do
-      (newHeadInput, newHeadOutput) <- findScriptOutput @PlutusScriptV1 (utxoFromTx tx) headScript
+      (newHeadInput, newHeadOutput) <- findTxOutByScript @PlutusScriptV1 (utxoFromTx tx) headScript
       newHeadDatum <- lookupScriptData tx newHeadOutput
       snapshotNumber <- integerToNatural onChainSnapshotNumber
       pure
@@ -804,7 +804,7 @@ observeFanoutTx ::
   Tx ->
   Maybe FanoutObservation
 observeFanoutTx utxo tx = do
-  headInput <- fst <$> findScriptOutput @PlutusScriptV1 utxo headScript
+  headInput <- fst <$> findTxOutByScript @PlutusScriptV1 utxo headScript
   findRedeemerSpending tx headInput
     >>= \case
       Head.Fanout{} -> pure FanoutObservation
@@ -824,7 +824,7 @@ observeAbortTx ::
   Tx ->
   Maybe AbortObservation
 observeAbortTx utxo tx = do
-  headInput <- fst <$> findScriptOutput @PlutusScriptV1 utxo headScript
+  headInput <- fst <$> findTxOutByScript @PlutusScriptV1 utxo headScript
   findRedeemerSpending tx headInput >>= \case
     Head.Abort -> pure AbortObservation
     _ -> Nothing

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

@@ -20,7 +20,14 @@ import Hydra.Chain.Direct.Contract.Mutation (
   headTxIn,
  )
 import Hydra.Chain.Direct.Fixture (genForParty, testNetworkId, testPolicyId, testSeedInput)
-import Hydra.Chain.Direct.Tx (UTxOWithScript, abortTx, mkHeadOutputInitial, mkHeadTokenScript)
+import Hydra.Chain.Direct.Tx (
+  UTxOWithScript,
+  abortTx,
+  headPolicyId,
+  headValue,
+  mkHeadOutputInitial,
+  mkHeadTokenScript,
+ )
 import Hydra.Chain.Direct.TxSpec (drop3rd, genAbortableOutputs)
 import qualified Hydra.Contract.Commit as Commit
 import qualified Hydra.Contract.HeadState as Head
@@ -39,33 +46,25 @@ healthyAbortTx =
   (tx, lookupUTxO)
  where
   lookupUTxO =
-    UTxO.singleton (headInput, toUTxOContext headOutput)
+    UTxO.singleton (healthyHeadInput, toUTxOContext headOutput)
       <> UTxO (Map.fromList (drop3rd <$> healthyInitials))
       <> UTxO (Map.fromList (drop3rd <$> healthyCommits))
 
   tx =
     either (error . show) id $
       abortTx
         somePartyCardanoVerificationKey
-        (headInput, toUTxOContext headOutput, headDatum)
+        (healthyHeadInput, toUTxOContext headOutput, headDatum)
         headTokenScript
         (Map.fromList (tripleToPair <$> healthyInitials))
         (Map.fromList (tripleToPair <$> healthyCommits))
 
   somePartyCardanoVerificationKey = flip generateWith 42 $ do
     genForParty genVerificationKey <$> elements healthyParties
 
-  headInput = generateWith arbitrary 42
-
   headTokenScript = mkHeadTokenScript testSeedInput
 
-  headOutput = mkHeadOutputInitial testNetworkId testPolicyId headParameters
-
-  headParameters =
-    HeadParameters
-      { contestationPeriod = 10
-      , parties = healthyParties
-      }
+  headOutput = mkHeadOutputInitial testNetworkId testPolicyId healthyHeadParameters
 
   headDatum = unsafeGetDatum headOutput
 
@@ -75,6 +74,16 @@ healthyAbortTx =
 
   tripleToPair (a, b, c) = (a, (b, c))
 
+healthyHeadInput :: TxIn
+healthyHeadInput = generateWith arbitrary 42
+
+healthyHeadParameters :: HeadParameters
+healthyHeadParameters =
+  HeadParameters
+    { contestationPeriod = 10
+    , parties = healthyParties
+    }
+
 healthyInitials :: [UTxOWithScript]
 healthyCommits :: [UTxOWithScript]
 (healthyInitials, healthyCommits) =
@@ -116,9 +125,15 @@ data AbortMutation
   | DropOneCommitOutput
   | MutateHeadScriptInput
   | BurnOneTokenMore
-  | MutateThreadTokenQuantity
+  | -- | Meant to test that the minting policy is burning all PTs present in tx
+    MutateThreadTokenQuantity
   | DropCollectedInput
   | MutateRequiredSigner
+  | -- | Simply change the currency symbol of the ST.
+    MutateHeadId
+  | -- Spend some abortable output from a different Head
+    -- e.g. replace a commit by another commit from a different Head.
+    UseInputFromOtherHead
   deriving (Generic, Show, Enum, Bounded)
 
 genAbortMutation :: (Tx, UTxO) -> Gen SomeMutation
@@ -138,4 +153,41 @@ genAbortMutation (tx, utxo) =
     , SomeMutation MutateRequiredSigner <$> do
         newSigner <- verificationKeyHash <$> genVerificationKey
         pure $ ChangeRequiredSigners [newSigner]
+    , SomeMutation MutateHeadId <$> do
+        illedHeadResolvedInput <-
+          mkHeadOutputInitial testNetworkId
+            <$> fmap headPolicyId (arbitrary `suchThat` (/= testSeedInput))
+            <*> pure healthyHeadParameters
+        return $ ChangeInput healthyHeadInput (toUTxOContext illedHeadResolvedInput) (Just $ toScriptData Head.Abort)
+    , SomeMutation UseInputFromOtherHead <$> do
+        (input, output, _) <- elements healthyInitials
+        otherHeadId <- fmap headPolicyId (arbitrary `suchThat` (/= testSeedInput))
+
+        let TxOut addr value datum = output
+            assetNames =
+              [ (policyId, pkh) | (AssetId policyId pkh, _) <- valueToList value, policyId == testPolicyId
+              ]
+            (originalPolicyId, assetName) =
+              case assetNames of
+                [assetId] -> assetId
+                _ -> error "expected one assetId"
+
+            newValue = headValue <> valueFromList [(AssetId otherHeadId assetName, 1)]
+
+            ptForAssetName = \case
+              (AssetId pid asset, _) ->
+                pid == originalPolicyId && asset == assetName
+              _ -> False
+
+            mintedValue' = case txMintValue $ txBodyContent $ txBody tx of
+              TxMintValueNone -> error "expected minted value"
+              TxMintValue v _ -> valueFromList $ filter (not . ptForAssetName) $ valueToList v
+
+            output' = TxOut addr newValue datum
+
+        pure $
+          Changes
+            [ ChangeInput input output' (Just $ toScriptData Initial.Abort)
+            , ChangeMintedValue mintedValue'
+            ]
     ]

hydra-node/test/Hydra/Chain/Direct/StateSpec.hs

@@ -105,13 +105,16 @@ import Test.QuickCheck (
   checkCoverage,
   choose,
   classify,
+  conjoin,
   counterexample,
   elements,
   forAll,
   forAllBlind,
   forAllShow,
   label,
   sublistOf,
+  (=/=),
+  (===),
   (==>),
  )
 import Test.QuickCheck.Monadic (
@@ -177,6 +180,20 @@ spec = parallel $ do
   describe "abort" $ do
     propBelowSizeLimit (2 * maxTxSize) forAllAbort
 
+    prop "ignore aborts of other heads" $ do
+      let twoDistinctHeads = do
+            ctx <- genHydraContext 1
+            st1 <- genStInitialized ctx
+            st2 <- genStInitialized ctx -- TODO: ensure they are distinct
+            pure (st1, st2)
+      forAll twoDistinctHeads $ \(stHead1, stHead2) ->
+        let observedIn1 = observeTx @StInitialized @StIdle (abort stHead1) stHead1
+            observedIn2 = observeTx @StInitialized @StIdle (abort stHead1) stHead2
+         in conjoin
+              [ observedIn1 =/= Nothing
+              , observedIn2 === Nothing
+              ]
+
   describe "collectCom" $ do
     propBelowSizeLimit maxTxSize forAllCollectCom
     propIsValid maxTxExecutionUnits forAllCollectCom

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

@@ -47,6 +47,11 @@ PlutusTx.unstableMakeIsData ''SerializedTxOut
 type DatumType = (Party, ValidatorHash, Maybe SerializedTxOut)
 type RedeemerType = CommitRedeemer
 
+-- | The v_commit validator verifies that:
+--
+--   * spent in a transaction also consuming a v_head output
+--
+--   * on abort, redistribute comitted utxo
 validator :: DatumType -> RedeemerType -> ScriptContext -> Bool
 validator (_party, headScriptHash, commit) consumer ScriptContext{scriptContextTxInfo = txInfo} =
   case txInInfoResolved <$> findHeadScript of

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

@@ -45,7 +45,7 @@ import Plutus.V1.Ledger.Api (
   UpperBound (..),
   Validator (getValidator),
   ValidatorHash,
-  Value (Value),
+  Value (Value, getValue),
   adaSymbol,
   adaToken,
   mkValidatorScript,
@@ -150,42 +150,43 @@ mkHeadContext context initialAddress commitAddress =
           _ -> symbol : loop rest
 {-# INLINEABLE mkHeadContext #-}
 
--- | On-Chain Validation for 'Abort' transition.
--- It must verify that:
---  * All PTs have been burnt
---  * It has collected inputs for all parties, either from `Initial` or `Commit` script.
+-- | On-Chain verification for 'Abort' transition. It verifies that:
 --
--- FIXME: This seems not to validate whether the right head is aborted, i.e. the
--- collected inputs are from a Head with the same policyId.
+--  * All PTs have been burnt: The right number of Head tokens, both PT for parties
+--    and thread token, with the correct head id, are burnt,
+--
+--  * All committed funds have been redistributed. This is done via v_commit and
+--    it only needs to ensure that we have spent all comitted outputs, which
+--    follows from burning all the PTs.
 checkAbort ::
   ScriptContext ->
   HeadContext ->
   [Party] ->
   Bool
 checkAbort context@ScriptContext{scriptContextTxInfo = txInfo} headContext parties =
-  consumeInputsForAllParties
+  mustBurnAllHeadTokens
     && mustBeSignedByParticipant context headContext
  where
-  HeadContext{initialAddress, commitAddress} = headContext
+  HeadContext{headCurrencySymbol} = headContext
 
-  consumeInputsForAllParties =
+  mustBurnAllHeadTokens =
     traceIfFalse "number of inputs do not match number of parties" $
-      length parties == length initialAndCommitInputs
-  initialAndCommitInputs =
-    filter
-      ( \TxInInfo{txInInfoResolved} ->
-          let addr = txOutAddress txInInfoResolved
-           in addr == commitAddress || addr == initialAddress
-      )
-      (txInfoInputs txInfo)
+      burntTokens == length parties + 1
+
+  minted = getValue $ txInfoMint txInfo
+
+  burntTokens =
+    case Map.lookup headCurrencySymbol minted of
+      Nothing -> 0
+      Just tokenMap -> negate $ sum tokenMap
 
 -- | On-Chain Validation for the 'CollectCom' transition.
 --
 -- The 'CollectCom' transition must verify that:
 --
 -- - All participants have committed (even empty commits)
 -- - All commits are properly collected and locked into the contract as a hash
---   of serialized tx outputss in the same sequence as commit inputs!
+--   of serialized tx outputs in the same sequence as commit inputs!
 -- - The transaction is performed (i.e. signed) by one of the head participants
 --
 -- It must also Initialize the on-chain state η* with a snapshot number and a

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

@@ -89,6 +89,10 @@ validateTokensMinting initialValidator headValidator seedInput context =
 
   seedInputIsConsumed = seedInput `elem` (txInInfoOutRef <$> txInfoInputs txInfo)
 
+-- TODO: does this even make sense to check? Shouldn't we check that we are
+-- doing an abort of fanout (terminal transitions) of the v_head? Or is this
+-- even 'const True' as one need to be able to spend tokens to burn them. If we
+-- only distribute them to v_initial on minting, that should be fine?
 validateTokensBurning :: ScriptContext -> Bool
 validateTokensBurning context =
   traceIfFalse "burnt wrong" checkAllPTsAreBurnt

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

@@ -49,7 +49,9 @@ PlutusTx.unstableMakeIsData ''InitialRedeemer
 type DatumType = ()
 type RedeemerType = InitialRedeemer
 
--- | The initial validator has two responsibilities:
+-- | The v_initial validator verifies that:
+--
+--   * FIXME: spent in a transaction also consuming a v_head output
 --
 --   * ensures the committed value is recorded correctly in the output datum
 --