From cebb6e89e891a23e67604c03ea2ac5c1fb39c52e Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Wed, 14 Feb 2024 19:13:43 +0100 Subject: [PATCH] Make toRealUTxO distributive This should spare us some headaches when we convert multiple UTxOType Payment to UTxOType Tx (actual utxos) in the future. This also checks that toTxOuts is distributive (although that is quite obvious). --- hydra-node/test/Hydra/Model.hs | 92 +++++++++++++----------- hydra-node/test/Hydra/Model/MockChain.hs | 7 -- hydra-node/test/Hydra/Model/Payment.hs | 9 ++- hydra-node/test/Hydra/ModelSpec.hs | 16 +++-- 4 files changed, 67 insertions(+), 57 deletions(-) diff --git a/hydra-node/test/Hydra/Model.hs b/hydra-node/test/Hydra/Model.hs index 4010a46f168..51c13ba2275 100644 --- a/hydra-node/test/Hydra/Model.hs +++ b/hydra-node/test/Hydra/Model.hs @@ -22,6 +22,7 @@ import Hydra.Prelude hiding (Any, label, lookup) import Cardano.Api.UTxO (pairs) import Cardano.Api.UTxO qualified as UTxO +import Cardano.Binary (serialize', unsafeDeserialize') import Control.Concurrent.Class.MonadSTM ( MonadLabelledSTM, labelTQueueIO, @@ -67,7 +68,7 @@ import Hydra.Ledger (IsTx (..)) import Hydra.Ledger.Cardano (cardanoLedger, genSigningKey, mkSimpleTx) import Hydra.Logging (Tracer) import Hydra.Logging.Messages (HydraLog (DirectChain, Node)) -import Hydra.Model.MockChain (mkMockTxIn, mockChainAndNetwork) +import Hydra.Model.MockChain (mockChainAndNetwork) import Hydra.Model.Payment (CardanoSigningKey (..), Payment (..), applyTx, genAdaValue) import Hydra.Node (createNodeState, runHydraNode) import Hydra.Party (Party (..), deriveParty) @@ -484,21 +485,22 @@ instance ) => RunModel WorldState (RunMonad m) where - postcondition (_, st) action _lookup result = + postcondition (_, st) action _lookup result = do + counterexamplePost "Postcondition failed" + counterexamplePost ("Action: " <> show action) + counterexamplePost ("State: " <> show st) + case action of - (Commit _party expectedCommitted) -> do - decorateFailure st action expectedCommitted result - pure $ expectedCommitted == result + (Commit _party expectedCommitted) -> + expectedCommitted === result Fanout{} -> case hydraState st of Final{finalUTxO} -> do -- NOTE: Sort `[TxOut]` by the address and values. We want to make - -- sure that the fannout outputs match what we had in the open Head + -- sure that the fanout outputs match what we had in the open Head -- exactly. - let sortByAddressAndValue = sortOn (\o -> (txOutAddress o, selectLovelace (txOutValue o))) - decorateFailure st action (toTxOuts finalUTxO) (toList result) - pure $ - sortByAddressAndValue (toTxOuts finalUTxO) == sortByAddressAndValue (toList result) + let sorted = sortOn (\o -> (txOutAddress o, selectLovelace (txOutValue o))) + sorted (toTxOuts finalUTxO) === sorted (toList result) _ -> pure False _ -> pure True @@ -634,25 +636,6 @@ performCommit parties party paymentUTxO = do makeAddressFromSigningKey :: CardanoSigningKey -> AddressInEra makeAddressFromSigningKey = mkVkAddress testNetworkId . getVerificationKey . signingKey -toTxOuts :: [(CardanoSigningKey, Value)] -> [TxOut CtxUTxO] -toTxOuts payments = - uncurry mkTxOut <$> payments - where - mkTxOut (CardanoSigningKey sk) val = - TxOut (mkVkAddress testNetworkId (getVerificationKey sk)) val TxOutDatumNone ReferenceScriptNone - --- | NOTE: This function generates input 'Ix' that start from zero so --- can't be used with certainty when want to check equality with some 'UTxO' --- even though the value and the key would match. -toRealUTxO :: [(CardanoSigningKey, Value)] -> UTxO -toRealUTxO paymentUTxO = - UTxO.fromPairs $ - [ (mkMockTxIn vk ix, txOut) - | (ix, (CardanoSigningKey sk, val)) <- zip [0 ..] paymentUTxO - , let vk = getVerificationKey sk - , let txOut = TxOut (mkVkAddress testNetworkId vk) val TxOutDatumNone ReferenceScriptNone - ] - performNewTx :: (MonadThrow m, MonadAsync m, MonadTimer m, MonadDelay m) => Party -> @@ -773,6 +756,36 @@ stopTheWorld = -- ** Utility functions +-- | Convert payment-style utxos into transaction outputs. +toTxOuts :: [(CardanoSigningKey, Value)] -> [TxOut CtxUTxO] +toTxOuts payments = + uncurry mkTxOut <$> payments + +-- | Convert payment-style utxos into real utxos. The 'Payment' tx domain is +-- smaller than UTxO and we map every unique signer + value entry to a mocked +-- 'TxIn' on the real cardano domain. +toRealUTxO :: UTxOType Payment -> UTxOType Tx +toRealUTxO paymentUTxO = + UTxO.fromPairs $ + [ (mkMockTxIn sk ix, mkTxOut sk val) + | (sk, vals) <- Map.toList skMap + , (ix, val) <- zip [0 ..] vals + ] + where + skMap = foldMap (\(sk, v) -> Map.singleton sk [v]) paymentUTxO + +mkTxOut :: CardanoSigningKey -> Value -> TxOut CtxUTxO +mkTxOut (CardanoSigningKey sk) val = + TxOut (mkVkAddress testNetworkId (getVerificationKey sk)) val TxOutDatumNone ReferenceScriptNone + +mkMockTxIn :: CardanoSigningKey -> Word -> TxIn +mkMockTxIn (CardanoSigningKey sk) ix = + TxIn (TxId tid) (TxIx ix) + where + vk = getVerificationKey sk + -- NOTE: Ugly, works because both binary representations are 32-byte long. + tid = unsafeDeserialize' (serialize' vk) + -- | Bring `Show` instance in scope drawing it from the `Action` type. -- -- This is a neat trick to provide `show`able results from action in a context where @@ -794,18 +807,15 @@ showFromAction k = \case StopTheWorld -> k ObserveHeadIsOpen -> k -decorateFailure :: - (Monad m, Show expected, Show actual) => - WorldState -> - Action WorldState a -> - expected -> - actual -> - PostconditionM m () -decorateFailure st action expected actual = do - counterexamplePost ("Action: " <> show action) - counterexamplePost ("State: " <> show st) - counterexamplePost ("Expected: " <> show expected) - counterexamplePost ("Actual: " <> show actual) +-- | Like '===', but works in PostconditionM. +(===) :: (Eq a, Show a, Monad m) => a -> a -> PostconditionM m Bool +x === y = do + counterexamplePost (show x <> "\n" <> interpret res <> "\n" <> show y) + pure res + where + res = x == y + interpret True = "==" + interpret False = "/=" waitForUTxOToSpend :: forall m. diff --git a/hydra-node/test/Hydra/Model/MockChain.hs b/hydra-node/test/Hydra/Model/MockChain.hs index 3e08bd4dc80..421a45369e3 100644 --- a/hydra-node/test/Hydra/Model/MockChain.hs +++ b/hydra-node/test/Hydra/Model/MockChain.hs @@ -6,7 +6,6 @@ import Hydra.Cardano.Api import Hydra.Prelude hiding (Any, label) import Cardano.Api.UTxO (fromPairs, pairs) -import Cardano.Binary (serialize', unsafeDeserialize') import Control.Concurrent.Class.MonadSTM ( MonadLabelledSTM, MonadSTM (newTVarIO, writeTVar), @@ -334,12 +333,6 @@ createMockChain tracer ctx submitTx timeHandle seedInput chainState = chainState submitTx -mkMockTxIn :: VerificationKey PaymentKey -> Word -> TxIn -mkMockTxIn vk ix = TxIn (TxId tid) (TxIx ix) - where - -- NOTE: Ugly, works because both binary representations are 32-byte long. - tid = unsafeDeserialize' (serialize' vk) - -- NOTE: This is a workaround until the upstream PR is merged: -- https://github.com/input-output-hk/io-sim/issues/133 flushQueue :: MonadSTM m => TQueue m a -> STM m [a] diff --git a/hydra-node/test/Hydra/Model/Payment.hs b/hydra-node/test/Hydra/Model/Payment.hs index 13360dd91bc..6be421cc140 100644 --- a/hydra-node/test/Hydra/Model/Payment.hs +++ b/hydra-node/test/Hydra/Model/Payment.hs @@ -17,15 +17,20 @@ import Test.QuickCheck.StateModel (HasVariables) import Test.QuickCheck.StateModel.Variables (HasVariables (..)) import Prelude qualified +-- NOTE: New type wrapper to add Ord and Eq instances to signing keys newtype CardanoSigningKey = CardanoSigningKey {signingKey :: SigningKey PaymentKey} instance Show CardanoSigningKey where show CardanoSigningKey{signingKey} = show . mkVkAddress @Era testNetworkId . getVerificationKey $ signingKey --- NOTE: We need this orphan instance in order to lookup keys in lists. +instance Ord CardanoSigningKey where + CardanoSigningKey ska <= CardanoSigningKey skb = + verificationKeyHash (getVerificationKey ska) <= verificationKeyHash (getVerificationKey skb) + instance Eq CardanoSigningKey where - CardanoSigningKey (PaymentSigningKey skd) == CardanoSigningKey (PaymentSigningKey skd') = skd == skd' + CardanoSigningKey ska == CardanoSigningKey skb = + verificationKeyHash (getVerificationKey ska) == verificationKeyHash (getVerificationKey skb) instance ToJSON CardanoSigningKey where toJSON = error "don't use" diff --git a/hydra-node/test/Hydra/ModelSpec.hs b/hydra-node/test/Hydra/ModelSpec.hs index ee9fa69484f..d7940889c1c 100644 --- a/hydra-node/test/Hydra/ModelSpec.hs +++ b/hydra-node/test/Hydra/ModelSpec.hs @@ -139,6 +139,8 @@ import Hydra.Model ( genPayment, genSeed, runMonad, + toRealUTxO, + toTxOuts, ) import Hydra.Model qualified as Model import Hydra.Model.Payment qualified as Payment @@ -181,14 +183,14 @@ spec = do prop "check conflict-free liveness" prop_checkConflictFreeLiveness prop "check head opens if all participants commit" prop_checkHeadOpensIfAllPartiesCommit prop "fanout contains whole confirmed UTxO" prop_fanoutContainsWholeConfirmedUTxO - -- FIXME: implement toRealUTxO correctly so the distributive property holds - xprop "realUTxO is distributive" $ propIsDistributive Model.toRealUTxO + prop "toRealUTxO is distributive" $ propIsDistributive toRealUTxO + prop "toTxOuts is distributive" $ propIsDistributive toTxOuts -propIsDistributive :: (Show b, Eq b, Semigroup b) => ([a] -> b) -> [a] -> [a] -> Property -propIsDistributive fn as bs = - fn as <> fn bs === fn (as <> bs) - & counterexample ("fn (as <> bs) " <> show (fn (as <> bs))) - & counterexample ("fn as <> fn bs: " <> show (fn as <> fn bs)) +propIsDistributive :: (Show b, Eq b, Semigroup a, Semigroup b) => (a -> b) -> a -> a -> Property +propIsDistributive f x y = + f x <> f y === f (x <> y) + & counterexample ("f (x <> y) " <> show (f (x <> y))) + & counterexample ("f x <> f y: " <> show (f x <> f y)) prop_fanoutContainsWholeConfirmedUTxO :: Property prop_fanoutContainsWholeConfirmedUTxO =