Shuffle functions around because of cyclic dependencies

input-output-hk · Feb 6, 2023 · a1786c6 · a1786c6
1 parent 153409f
commit a1786c6
Show file tree

Hide file tree

Showing 4 changed files with 72 additions and 60 deletions.
diff --git a/hydra-node/src/Hydra/Chain/Direct/State.hs b/hydra-node/src/Hydra/Chain/Direct/State.hs
@@ -86,6 +86,7 @@ import Hydra.Chain.Direct.Tx (
   observeFanoutTx,
   observeInitTx,
  )
+import Hydra.Chain.Direct.Util (addChangeOutput)
 import Hydra.ContestationPeriod (ContestationPeriod)
 import Hydra.Crypto (HydraKey, generateSigningKey)
 import Hydra.Data.ContestationPeriod (posixToUTCTime)
@@ -850,7 +851,7 @@ genCollectComTx = do
   commits <- genCommits ctx txInit
   cctx <- pickChainContext ctx
   let (committedUTxO, stInitialized) = unsafeObserveInitAndCommits cctx txInit commits
-  pure (cctx, committedUTxO, stInitialized, collect cctx stInitialized)
+  pure (cctx, committedUTxO, stInitialized, addChangeOutput $ collect cctx stInitialized)
 
 genCloseTx :: Int -> Gen (ChainContext, OpenState, Tx, ConfirmedSnapshot Tx)
 genCloseTx numParties = do

diff --git a/hydra-node/src/Hydra/Chain/Direct/Util.hs b/hydra-node/src/Hydra/Chain/Direct/Util.hs
@@ -6,18 +6,24 @@ module Hydra.Chain.Direct.Util where
 import Hydra.Prelude
 
 import qualified Cardano.Crypto.DSIGN as Crypto
+import qualified Cardano.Ledger.Alonzo.Data as Ledger
 import Cardano.Ledger.Alonzo.Tx (ValidatedTx (..))
 import Cardano.Ledger.Alonzo.TxWitness (TxWitness (..))
+import qualified Cardano.Ledger.Alonzo.TxWitness as Ledger
+import qualified Cardano.Ledger.Babbage.TxBody as Ledger
 import Cardano.Ledger.Crypto (DSIGN)
 import qualified Cardano.Ledger.SafeHash as SafeHash
+import Cardano.Ledger.Serialization (mkSized)
 import qualified Cardano.Ledger.TxIn as Ledger
 import Control.Tracer (nullTracer)
 import Data.Map.Strict ((!))
 import qualified Data.Map.Strict as Map
+import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
 import Hydra.Cardano.Api hiding (Block, SigningKey, VerificationKey)
 import qualified Hydra.Cardano.Api as Api
 import qualified Hydra.Cardano.Api as Shelley
+import Hydra.Ledger.Cardano (genTxOutAdaOnly)
 import Ouroboros.Consensus.Byron.Ledger.Config (CodecConfig (..))
 import Ouroboros.Consensus.Cardano (CardanoBlock)
 import Ouroboros.Consensus.Cardano.Block (
@@ -190,3 +196,64 @@ isMarkedOutput :: TxOut CtxUTxO -> Bool
 isMarkedOutput = \case
   (TxOut _ _ (TxOutDatumHash ha) _) -> ha == markerDatumHash
   _ -> False
+
+-----------------------------------------------------------------------------
+-- TEST RELATED FUNCTIONS
+-----------------------------------------------------------------------------
+
+-- NOTE: Add one output containing 0 ada to make sure we have the right number
+-- of outputs (2). In practise the change should cover the fees and here they
+-- are zero.
+addChangeOutput :: Tx -> Tx
+addChangeOutput transaction =
+  alterTxOuts (\outs -> outs <> [changeOutput{txOutValue = lovelaceToValue 0}]) transaction
+ where
+  changeOutput =
+    generateWith genTxOutAdaOnly 42
+
+-- | Apply some mapping function over a transaction's outputs.
+alterTxOuts ::
+  ([TxOut CtxTx] -> [TxOut CtxTx]) ->
+  Tx ->
+  Tx
+alterTxOuts fn tx =
+  Tx body' wits
+ where
+  body' = ShelleyTxBody ledgerBody' scripts scriptData' mAuxData scriptValidity
+  ledgerBody' = ledgerBody{Ledger.outputs = ledgerOutputs'}
+
+  ledgerOutputs' = StrictSeq.fromList . map (mkSized . toLedgerTxOut . toCtxUTxOTxOut) $ outputs'
+
+  outputs' = fn . fmap fromLedgerTxOut . toList $ Ledger.outputs' ledgerBody
+
+  scriptData' = ensureDatums outputs' scriptData
+
+  ShelleyTxBody ledgerBody scripts scriptData mAuxData scriptValidity = body
+  Tx body wits = tx
+
+  -- Ensures the included datums of given 'TxOut's are included in the transactions' 'TxBodyScriptData'.
+  ensureDatums :: [TxOut CtxTx] -> TxBodyScriptData -> TxBodyScriptData
+  ensureDatums outs scriptData'' =
+    foldr ensureDatum scriptData'' outs
+   where
+    ensureDatum txOut sd =
+      case txOutDatum txOut of
+        d@(TxOutDatumInTx _) -> addDatum d sd
+        _ -> sd
+
+-- | 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.
+addDatum :: TxOutDatum CtxTx -> TxBodyScriptData -> TxBodyScriptData
+addDatum datum scriptData =
+  case datum of
+    TxOutDatumNone -> error "unexpected datum none"
+    TxOutDatumHash _ha -> error "hash only, expected full datum"
+    TxOutDatumInline _sd -> error "not useful for inline datums"
+    TxOutDatumInTx sd ->
+      case scriptData of
+        TxBodyNoScriptData -> error "TxBodyNoScriptData unexpected"
+        TxBodyScriptData (Ledger.TxDats dats) redeemers ->
+          let dat = toLedgerData sd
+              newDats = Ledger.TxDats $ Map.insert (Ledger.hashData dat) dat dats
+           in TxBodyScriptData newDats redeemers
diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/CollectCom.hs
@@ -14,7 +14,6 @@ import Hydra.Chain.Direct.Contract.Gen (genForParty, genHash, genMintedOrBurnedV
 import Hydra.Chain.Direct.Contract.Mutation (
   Mutation (..),
   SomeMutation (..),
-  alterTxOuts,
   changeHeadOutputDatum,
   changeMintedTokens,
  )
@@ -33,13 +32,14 @@ import Hydra.Chain.Direct.Tx (
   mkHeadOutput,
   mkInitialOutput,
  )
+import Hydra.Chain.Direct.Util (addChangeOutput)
 import qualified Hydra.Contract.Commit as Commit
 import qualified Hydra.Contract.Head as Head
 import qualified Hydra.Contract.HeadState as Head
 import Hydra.Contract.HeadTokens (headPolicyId)
 import qualified Hydra.Data.ContestationPeriod as OnChain
 import qualified Hydra.Data.Party as OnChain
-import Hydra.Ledger.Cardano (genAdaOnlyUTxO, genTxIn, genTxOutAdaOnly, genVerificationKey)
+import Hydra.Ledger.Cardano (genAdaOnlyUTxO, genTxIn, genVerificationKey)
 import Hydra.Party (Party, partyToChain)
 import Plutus.Orphans ()
 import Plutus.V2.Ledger.Api (toBuiltin, toData)
@@ -79,14 +79,6 @@ healthyCollectComTx =
       , initialContestationPeriod = healthyContestationPeriod
       }
 
-  -- NOTE: Add one output containing 0 ada to make sure we have the right number of outputs (2).
-  -- In practise the change should cover the fees and here they are zero.
-  addChangeOutput transaction =
-    alterTxOuts (\outs -> outs <> [changeOutput{txOutValue = lovelaceToValue 0}]) transaction
-   where
-    changeOutput =
-      generateWith genTxOutAdaOnly 42
-
 healthyCommits :: Map TxIn HealthyCommit
 healthyCommits =
   (uncurry healthyCommitOutput <$> zip healthyParties committedUTxO)

diff --git a/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs b/hydra-node/test/Hydra/Chain/Direct/Contract/Mutation.hs
@@ -136,14 +136,13 @@ import qualified Cardano.Ledger.Alonzo.Data as Ledger
 import qualified Cardano.Ledger.Alonzo.Scripts as Ledger
 import qualified Cardano.Ledger.Alonzo.TxWitness as Ledger
 import qualified Cardano.Ledger.Babbage.TxBody as Ledger
-import Cardano.Ledger.Serialization (mkSized)
 import qualified Data.Map as Map
-import qualified Data.Sequence.Strict as StrictSeq
 import qualified Data.Set as Set
 import Hydra.Chain.Direct.Contract.Gen (genForParty)
 import Hydra.Chain.Direct.Fixture (testPolicyId)
 import qualified Hydra.Chain.Direct.Fixture as Fixture
 import Hydra.Chain.Direct.Tx (assetNameFromVerificationKey)
+import Hydra.Chain.Direct.Util (addDatum, alterTxOuts)
 import qualified Hydra.Contract.Head as Head
 import qualified Hydra.Contract.HeadState as Head
 import qualified Hydra.Data.Party as Data (Party)
@@ -430,23 +429,6 @@ isHeadOutput TxOut{txOutAddress = addr} = addr == headAddress
   headAddress = mkScriptAddress @PlutusScriptV2 Fixture.testNetworkId headScript
   headScript = fromPlutusScript Head.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.
-addDatum :: TxOutDatum CtxTx -> TxBodyScriptData -> TxBodyScriptData
-addDatum datum scriptData =
-  case datum of
-    TxOutDatumNone -> error "unexpected datum none"
-    TxOutDatumHash _ha -> error "hash only, expected full datum"
-    TxOutDatumInline _sd -> error "not useful for inline datums"
-    TxOutDatumInTx sd ->
-      case scriptData of
-        TxBodyNoScriptData -> error "TxBodyNoScriptData unexpected"
-        TxBodyScriptData (Ledger.TxDats dats) redeemers ->
-          let dat = toLedgerData sd
-              newDats = Ledger.TxDats $ Map.insert (Ledger.hashData dat) dat dats
-           in TxBodyScriptData newDats redeemers
-
 changeHeadOutputDatum :: (Head.State -> Head.State) -> TxOut CtxTx -> TxOut CtxTx
 changeHeadOutputDatum fn txOut =
   case txOutDatum txOut of
@@ -474,16 +456,6 @@ addParticipationTokens parties txOut =
         | cardanoVk <- genForParty genVerificationKey <$> parties
         ]
 
--- | Ensures the included datums of given 'TxOut's are included in the transactions' 'TxBodyScriptData'.
-ensureDatums :: [TxOut CtxTx] -> TxBodyScriptData -> TxBodyScriptData
-ensureDatums outs scriptData =
-  foldr ensureDatum scriptData outs
- where
-  ensureDatum txOut sd =
-    case txOutDatum txOut of
-      d@(TxOutDatumInTx _) -> addDatum d sd
-      _ -> sd
-
 -- | Alter a transaction's  redeemers map given some mapping function.
 alterRedeemers ::
   ( Ledger.RdmrPtr ->
@@ -551,26 +523,6 @@ alterTxIns fn tx =
 
   Tx body wits = tx
 
--- | Apply some mapping function over a transaction's outputs.
-alterTxOuts ::
-  ([TxOut CtxTx] -> [TxOut CtxTx]) ->
-  Tx ->
-  Tx
-alterTxOuts fn tx =
-  Tx body' wits
- where
-  body' = ShelleyTxBody ledgerBody' scripts scriptData' mAuxData scriptValidity
-  ledgerBody' = ledgerBody{Ledger.outputs = ledgerOutputs'}
-
-  ledgerOutputs' = StrictSeq.fromList . map (mkSized . toLedgerTxOut . toCtxUTxOTxOut) $ outputs'
-
-  outputs' = fn . fmap fromLedgerTxOut . toList $ Ledger.outputs' ledgerBody
-
-  scriptData' = ensureDatums outputs' scriptData
-
-  ShelleyTxBody ledgerBody scripts scriptData mAuxData scriptValidity = body
-  Tx body wits = tx
-
 -- | Generates an output that pays to some arbitrary pubkey.
 anyPayToPubKeyTxOut :: Gen (TxOut ctx)
 anyPayToPubKeyTxOut = genKeyPair >>= genOutput . fst