Add mutation on initial output address #243

cardano-scaling · Apr 5, 2022 · f13d00b · f13d00b
1 parent 51546e9
commit f13d00b
Showing 1 changed file with 30 additions and 12 deletions.
diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Init.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-unused-imports #-}
+
 -- | Mutation-based script validator tests for the init transaction where a
 -- 'healthyInitTx' gets mutated by an arbitrary 'InitMutation'.
 module Hydra.Chain.Direct.Contract.Init where
@@ -15,7 +17,7 @@ import Hydra.Chain.Direct.Contract.Mutation (
  )
 import Hydra.Chain.Direct.Fixture (testNetworkId)
 import Hydra.Chain.Direct.Tx (initTx)
-import Hydra.Ledger.Cardano (genOneUTxOFor, genValue)
+import Hydra.Ledger.Cardano (genOneUTxOFor, genValue, genVerificationKey)
 import Test.QuickCheck (choose, elements, oneof, suchThat, vectorOf)
 import qualified Prelude
 
@@ -55,24 +57,40 @@ healthyLookupUTxO =
 data InitMutation
   = MutateThreadTokenQuantity
   | MutateAddAnotherPT
-  | MutateInitialOutputValue
+  | MutateSomePT
   | MutateDropInitialOutput
   | MutateDropSeedInput
+  | MutateInitialOutputAddress
   deriving (Generic, Show, Enum, Bounded)
 
 genInitMutation :: (Tx, UTxO) -> Gen SomeMutation
 genInitMutation (tx, _utxo) =
   oneof
-    [ SomeMutation MutateThreadTokenQuantity <$> changeMintedValueQuantityFrom tx 1
-    , SomeMutation MutateAddAnotherPT <$> addPTWithQuantity tx 1
-    , SomeMutation MutateInitialOutputValue <$> do
+    [ -- SomeMutation MutateThreadTokenQuantity <$> changeMintedValueQuantityFrom tx 1
+      -- , SomeMutation MutateAddAnotherPT <$> addPTWithQuantity tx 1
+      -- , SomeMutation MutateInitialOutputValue <$> do
+      --     let outs = txOuts' tx
+      --     (ix, out) <- elements (zip [1 .. length outs - 1] outs)
+      --     value' <- genValue `suchThat` (/= txOutValue out)
+      --     pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out)
+      -- ,
+      SomeMutation MutateInitialOutputAddress <$> do
         let outs = txOuts' tx
         (ix, out) <- elements (zip [1 .. length outs - 1] outs)
-        value' <- genValue `suchThat` (/= txOutValue out)
-        pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (const value') out)
-    , SomeMutation MutateDropInitialOutput <$> do
-        ix <- choose (1, length (txOuts' tx) - 1)
-        pure $ RemoveOutput (fromIntegral ix)
-    , SomeMutation MutateDropSeedInput <$> do
-        pure $ RemoveInput healthySeedInput
+        vk' <- genVerificationKey `suchThat` (`notElem` healthyParties)
+        pure $ ChangeOutput (fromIntegral ix) (modifyTxOutValue (swapTokenName $ verificationKeyHash vk') out)
+        -- , SomeMutation MutateDropInitialOutput <$> do
+        --     ix <- choose (1, length (txOuts' tx) - 1)
+        --     pure $ RemoveOutput (fromIntegral ix)
+        -- , SomeMutation MutateDropSeedInput <$> do
+        --     pure $ RemoveInput healthySeedInput
     ]
+
+swapTokenName :: Hash PaymentKey -> Value -> Value
+swapTokenName vkh val =
+  valueFromList $ fmap swapPT $ valueToList val
+ where
+  swapPT :: (AssetId, Quantity) -> (AssetId, Quantity)
+  swapPT adas@(AdaAssetId, _) = adas
+  swapPT (AssetId pid _an, 1) = (AssetId pid (AssetName $ serialiseToRawBytes vkh), 1)
+  swapPT v = error $ "supernumerary value :" <> show v