Add MutateCommittedAddress mutator

Also adds some helpers to Hydra.Ledger.Cardano
input-output-hk · Jan 26, 2022 · cdf87aa · cdf87aa
1 parent 025593a
commit cdf87aa
Show file tree

Hide file tree

Showing 3 changed files with 55 additions and 34 deletions.
diff --git a/hydra-node/src/Hydra/Ledger/Cardano.hs b/hydra-node/src/Hydra/Ledger/Cardano.hs
@@ -407,6 +407,10 @@ mkTxIn txBody index = TxIn (getTxId txBody) (TxIx index)
 lovelaceToTxOutValue :: Lovelace -> TxOutValue AlonzoEra
 lovelaceToTxOutValue lovelace = TxOutValue MultiAssetInAlonzoEra (lovelaceToValue lovelace)
 
+txOutAddress :: TxOut ctx Era -> AddressInEra Era
+txOutAddress (TxOut addr _ _) =
+  addr
+
 txOutValue :: TxOut ctx Era -> Value
 txOutValue (TxOut _ value _) =
   txOutValueToValue value
@@ -424,12 +428,12 @@ getDatum (TxOut _ _ d) = case d of
   TxOutDatum _ dat -> Just dat
   _ -> Nothing
 
-modifyTxOutDatum ::
-  (TxOutDatum ctx0 Era -> TxOutDatum ctx1 Era) ->
-  TxOut ctx0 Era ->
-  TxOut ctx1 Era
-modifyTxOutDatum fn (TxOut addr value dat) =
-  TxOut addr value (fn dat)
+modifyTxOutAddress ::
+  (AddressInEra Era -> AddressInEra Era) ->
+  TxOut ctx Era ->
+  TxOut ctx Era
+modifyTxOutAddress fn (TxOut addr value dat) =
+  TxOut (fn addr) value dat
 
 modifyTxOutValue ::
   (Value -> Value) ->
@@ -438,6 +442,13 @@ modifyTxOutValue ::
 modifyTxOutValue fn (TxOut addr value dat) =
   TxOut addr (mkTxOutValue $ fn $ txOutValueToValue value) dat
 
+modifyTxOutDatum ::
+  (TxOutDatum ctx0 Era -> TxOutDatum ctx1 Era) ->
+  TxOut ctx0 Era ->
+  TxOut ctx1 Era
+modifyTxOutDatum fn (TxOut addr value dat) =
+  TxOut addr value (fn dat)
+
 -- | Find first 'TxOut' which pays to given address and also return the
 -- corresponding 'TxIn' to reference it.
 findTxOutByAddress :: AddressInEra era -> TxBody era -> Maybe (TxIn, TxOut CtxTx era)
@@ -641,6 +652,9 @@ instance ToTxContext TxOut where
 
 -- * Generators
 
+genVerificationKey :: Gen (VerificationKey PaymentKey)
+genVerificationKey = fst <$> genKeyPair
+
 genKeyPair :: Gen (VerificationKey PaymentKey, SigningKey PaymentKey)
 genKeyPair = do
   -- NOTE: not using 'genKeyDSIGN' purposely here, it is not pure and does not
@@ -745,6 +759,11 @@ genOneUtxoFor vk = do
   output <- scale (const 1) $ genOutput vk
   pure $ Utxo $ Map.singleton (fromLedgerTxIn input) output
 
+-- | NOTE: See note on 'mkVkAddress' about 'NetworkId'.
+genAddressInEra :: NetworkId -> Gen (AddressInEra Era)
+genAddressInEra networkId =
+  mkVkAddress networkId <$> genVerificationKey
+
 genValue :: Gen Value
 genValue = txOutValue <$> (genKeyPair >>= (genOutput . fst))
 

diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Commit.hs
@@ -11,7 +11,6 @@ import Data.Maybe (fromJust)
 import Hydra.Chain.Direct.Contract.Mutation (
   Mutation (..),
   SomeMutation (..),
-  isInitialOutput,
  )
 import qualified Hydra.Chain.Direct.Fixture as Fixture
 import Hydra.Chain.Direct.Tx (commitTx, mkInitialOutput, pubKeyHash)
@@ -25,19 +24,22 @@ import Hydra.Ledger.Cardano (
   Utxo,
   VerificationKey,
   fromLedgerTx,
+  genAddressInEra,
   genOutput,
   genValue,
   getOutputs,
   lovelaceToValue,
   mkTxOutValue,
+  modifyTxOutAddress,
   modifyTxOutValue,
   singletonUtxo,
   toCtxUTxOTxOut,
   toLedgerTxIn,
-  utxoPairs,
+  txOutAddress,
+  txOutValue,
  )
 import Hydra.Party (Party)
-import Test.QuickCheck (elements, oneof, suchThat)
+import Test.QuickCheck (oneof, suchThat)
 
 --
 -- CommitTx
@@ -51,13 +53,13 @@ healthyCommitTx =
  where
   lookupUtxo =
     singletonUtxo (initialInput, toCtxUTxOTxOut initialOutput)
-      <> singletonUtxo committedUtxo
+      <> singletonUtxo healthyCommittedUtxo
 
   tx =
     commitTx
       Fixture.testNetworkId
       commitParty
-      (Just committedUtxo)
+      (Just healthyCommittedUtxo)
       (toLedgerTxIn initialInput, initialPubKeyHash)
 
   initialInput = generateWith arbitrary 42
@@ -66,40 +68,46 @@ healthyCommitTx =
 
   initialPubKeyHash = pubKeyHash commitVerificationKey
 
-  -- NOTE: An 8₳ output which is currently addressed to some arbitrary key.
-  committedUtxo :: (TxIn, TxOut CtxUTxO Era)
-  committedUtxo = flip generateWith 42 $ do
-    txIn <- arbitrary
-    txOut <- modifyTxOutValue (const $ lovelaceToValue 8_000_000) <$> (genOutput =<< arbitrary)
-    pure (txIn, txOut)
-
   commitVerificationKey :: VerificationKey PaymentKey
   commitVerificationKey = generateWith arbitrary 42
 
   commitParty :: Party
   commitParty = generateWith arbitrary 42
 
+-- NOTE: An 8₳ output which is currently addressed to some arbitrary key.
+healthyCommittedUtxo :: (TxIn, TxOut CtxUTxO Era)
+healthyCommittedUtxo = flip generateWith 42 $ do
+  txIn <- arbitrary
+  txOut <- modifyTxOutValue (const $ lovelaceToValue 8_000_000) <$> (genOutput =<< arbitrary)
+  pure (txIn, txOut)
+
 data CommitMutation
   = MutateCommitOutputValue
-  | MutateComittedValue
+  | MutateCommittedValue
+  | MutateCommittedAddress
   deriving (Generic, Show, Enum, Bounded)
 
 genCommitMutation :: (CardanoTx, Utxo) -> Gen SomeMutation
-genCommitMutation (tx, utxo) =
+genCommitMutation (tx, _utxo) =
   oneof
     [ SomeMutation MutateCommitOutputValue . ChangeOutput 0 <$> do
         mutatedValue <- (mkTxOutValue <$> genValue) `suchThat` (/= commitOutputValue)
         pure $ TxOut commitOutputAddress mutatedValue commitOutputDatum
-    , SomeMutation MutateComittedValue <$> do
-        (comittedTxIn, _) <- elements comittedTxIns
-        newResolvedTxIn <- genOutput =<< arbitrary
-        pure $ ChangeInput comittedTxIn newResolvedTxIn
+    , SomeMutation MutateCommittedValue <$> do
+        mutatedValue <- genValue `suchThat` (/= committedOutputValue)
+        let mutatedOutput = modifyTxOutValue (const mutatedValue) committedTxOut
+        pure $ ChangeInput committedTxIn mutatedOutput
+    , SomeMutation MutateCommittedAddress <$> do
+        mutatedAddress <- genAddressInEra Fixture.testNetworkId `suchThat` (/= committedAddress)
+        let mutatedOutput = modifyTxOutAddress (const mutatedAddress) committedTxOut
+        pure $ ChangeInput committedTxIn mutatedOutput
     ]
  where
   TxOut commitOutputAddress commitOutputValue commitOutputDatum =
     fromJust $ getOutputs tx !!? 0
 
-  -- NOTE: This filtering will also yield any input added for fees, but we don't
-  -- have any in our test scenario so far.
-  comittedTxIns =
-    filter (not . isInitialOutput . snd) . utxoPairs $ utxo
+  (committedTxIn, committedTxOut) = healthyCommittedUtxo
+
+  committedAddress = txOutAddress committedTxOut
+
+  committedOutputValue = txOutValue committedTxOut
diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs
@@ -256,12 +256,6 @@ isHeadOutput (TxOut addr _ _) = addr == headAddress
   headAddress = Api.mkScriptAddress @Api.PlutusScriptV1 Fixture.testNetworkId headScript
   headScript = Api.fromPlutusScript $ Head.validatorScript policyId
 
-isInitialOutput :: TxOut CtxUTxO Era -> Bool
-isInitialOutput (TxOut addr _ _) = addr == initialAddress
- where
-  initialAddress = Api.mkScriptAddress @Api.PlutusScriptV1 Fixture.testNetworkId initialScript
-  initialScript = Api.fromPlutusScript Initial.validatorScript
-
 -- | Adds given 'Datum' and corresponding hash to the transaction's scripts.
 -- TODO: As we are creating the `TxOutDatum` from a known datum, passing a `TxOutDatum` is
 -- pointless and requires more work than needed to check impossible variants.