From 5418da9c96e79a032343284f749ba3441d9117fe Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 19 Feb 2024 18:14:21 +0100 Subject: [PATCH] Remove initUTxO from Ledger handle This was not really used anywhere and is redundant to the Monoid (UTxOType tx) constraint. --- hydra-node/src/Hydra/Ledger.hs | 8 +-- hydra-node/src/Hydra/Ledger/Cardano.hs | 5 +- hydra-node/src/Hydra/Ledger/Simple.hs | 17 +++---- .../test/Hydra/HeadLogicSnapshotSpec.hs | 20 ++++---- hydra-node/test/Hydra/HeadLogicSpec.hs | 49 +++++++++---------- hydra-node/test/Hydra/Model/MockChain.hs | 18 +++---- hydra-node/test/Hydra/Model/MockChainSpec.hs | 25 +++++----- 7 files changed, 62 insertions(+), 80 deletions(-) diff --git a/hydra-node/src/Hydra/Ledger.hs b/hydra-node/src/Hydra/Ledger.hs index 5d05db9179d..9aca27ad15a 100644 --- a/hydra-node/src/Hydra/Ledger.hs +++ b/hydra-node/src/Hydra/Ledger.hs @@ -68,7 +68,7 @@ nextChainSlot (ChainSlot n) = ChainSlot (n + 1) -- | An abstract interface for a 'Ledger'. Allows to define mock / simpler -- implementation for testing as well as limiting feature-envy from the business -- logic by forcing a closed interface. -data Ledger tx = Ledger +newtype Ledger tx = Ledger { applyTransactions :: ChainSlot -> UTxOType tx -> @@ -78,12 +78,6 @@ data Ledger tx = Ledger -- validation failures returned from the ledger. -- TODO: 'ValidationError' should also include the UTxO, which is not -- necessarily the same as the given UTxO after some transactions - , initUTxO :: UTxOType tx - -- ^ Generates an initial UTxO set. This is only temporary as it does not - -- allow to initialize the UTxO. - -- - -- TODO: This seems redundant with the `Monoid (UTxOType tx)` constraints - -- coming with `IsTx`. We probably want to dry this out. } canApply :: Ledger tx -> ChainSlot -> UTxOType tx -> tx -> ValidationResult diff --git a/hydra-node/src/Hydra/Ledger/Cardano.hs b/hydra-node/src/Hydra/Ledger/Cardano.hs index d266c0ec50d..fe6e6bda207 100644 --- a/hydra-node/src/Hydra/Ledger/Cardano.hs +++ b/hydra-node/src/Hydra/Ledger/Cardano.hs @@ -60,10 +60,7 @@ import Test.QuickCheck ( -- | Use the cardano-ledger as an in-hydra 'Ledger'. cardanoLedger :: Ledger.Globals -> Ledger.LedgerEnv LedgerEra -> Ledger Tx cardanoLedger globals ledgerEnv = - Ledger - { applyTransactions - , initUTxO = mempty - } + Ledger{applyTransactions} where -- NOTE(SN): See full note on 'applyTx' why we only have a single transaction -- application here. diff --git a/hydra-node/src/Hydra/Ledger/Simple.hs b/hydra-node/src/Hydra/Ledger/Simple.hs index e165922a0a1..dd7eef8c52d 100644 --- a/hydra-node/src/Hydra/Ledger/Simple.hs +++ b/hydra-node/src/Hydra/Ledger/Simple.hs @@ -118,15 +118,14 @@ instance FromCBOR SimpleTxIn where simpleLedger :: Ledger SimpleTx simpleLedger = - Ledger - { -- NOTE: _slot is unused as SimpleTx transactions don't have a notion of time. - applyTransactions = \_slot -> - foldlM $ \utxo tx@(SimpleTx _ ins outs) -> - if ins `Set.isSubsetOf` utxo && utxo `Set.disjoint` outs - then Right $ (utxo Set.\\ ins) `Set.union` outs - else Left (tx, ValidationError "cannot apply transaction") - , initUTxO = mempty - } + Ledger{applyTransactions} + where + -- NOTE: _slot is unused as SimpleTx transactions don't have a notion of time. + applyTransactions _slot = + foldlM $ \utxo tx@(SimpleTx _ ins outs) -> + if ins `Set.isSubsetOf` utxo && utxo `Set.disjoint` outs + then Right $ (utxo Set.\\ ins) `Set.union` outs + else Left (tx, ValidationError "cannot apply transaction") -- -- Builders diff --git a/hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs b/hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs index a4e243d6fc6..8e585ab3895 100644 --- a/hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs +++ b/hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs @@ -25,7 +25,7 @@ import Hydra.HeadLogic ( ) import Hydra.HeadLogic.Outcome (collectEffects) import Hydra.HeadLogicSpec (getState, inOpenState, inOpenState', runEvents, step) -import Hydra.Ledger (Ledger (..), txId) +import Hydra.Ledger (txId) import Hydra.Ledger.Simple (SimpleTx (..), aValidTx, simpleLedger, utxoRef) import Hydra.Network.Message (Message (..)) import Hydra.Options (defaultContestationPeriod) @@ -39,7 +39,7 @@ spec :: Spec spec = do parallel $ do let threeParties = [alice, bob, carol] - Ledger{initUTxO} = simpleLedger + u0 = mempty envFor signingKey = let party = deriveParty signingKey otherParties = List.delete party threeParties @@ -53,10 +53,10 @@ spec = do let coordinatedHeadState = CoordinatedHeadState - { localUTxO = initUTxO + { localUTxO = u0 , allTxs = mempty , localTxs = mempty - , confirmedSnapshot = InitialSnapshot testHeadId initUTxO + , confirmedSnapshot = InitialSnapshot testHeadId u0 , seenSnapshot = NoSeenSnapshot } let sendReqSn = @@ -92,7 +92,7 @@ spec = do it "does NOT send ReqSn when we are the leader but snapshot in flight" $ do let tx = aValidTx 1 - sn1 = Snapshot testHeadId 1 initUTxO mempty :: Snapshot SimpleTx + sn1 = Snapshot testHeadId 1 u0 mempty :: Snapshot SimpleTx st = coordinatedHeadState{seenSnapshot = SeenSnapshot sn1 mempty} outcome = update (envFor aliceSk) simpleLedger (inOpenState' [alice, bob] st) $ NetworkEvent defaultTTL alice $ ReqTx tx @@ -107,7 +107,7 @@ spec = do coordinatedHeadState { localTxs = [tx] , allTxs = Map.singleton (txId tx) tx - , localUTxO = initUTxO <> utxoRef (txId tx) + , localUTxO = u0 <> utxoRef (txId tx) , seenSnapshot = RequestedSnapshot{lastSeen = 0, requested = 1} } @@ -120,7 +120,7 @@ spec = do let bobEnv = envFor bobSk it "sends ReqSn when leader and there are seen transactions" $ do - headState <- runEvents bobEnv simpleLedger (inOpenState threeParties simpleLedger) $ do + headState <- runEvents bobEnv simpleLedger (inOpenState threeParties) $ do step (NetworkEvent defaultTTL alice $ ReqSn 1 []) step (NetworkEvent defaultTTL carol $ ReqTx $ aValidTx 1) step (ackFrom carolSk carol) @@ -131,7 +131,7 @@ spec = do collectEffects outcome `shouldSatisfy` sendReqSn it "does NOT send ReqSn when we are the leader but there are NO seen transactions" $ do - headState <- runEvents bobEnv simpleLedger (inOpenState threeParties simpleLedger) $ do + headState <- runEvents bobEnv simpleLedger (inOpenState threeParties) $ do step (NetworkEvent defaultTTL alice $ ReqSn 1 []) step (ackFrom carolSk carol) step (ackFrom aliceSk alice) @@ -149,7 +149,7 @@ spec = do newTxBeforeSnapshotAcknowledged = step (NetworkEvent defaultTTL carol $ ReqTx $ aValidTx 1) - headState <- runEvents notLeaderEnv simpleLedger (inOpenState threeParties simpleLedger) $ do + headState <- runEvents notLeaderEnv simpleLedger (inOpenState threeParties) $ do initiateSigningASnapshot alice step (ackFrom carolSk carol) newTxBeforeSnapshotAcknowledged @@ -160,7 +160,7 @@ spec = do collectEffects everybodyAcknowleged `shouldNotSatisfy` sendReqSn it "updates seenSnapshot state when sending ReqSn" $ do - headState <- runEvents bobEnv simpleLedger (inOpenState threeParties simpleLedger) $ do + headState <- runEvents bobEnv simpleLedger (inOpenState threeParties) $ do step (NetworkEvent defaultTTL alice $ ReqSn 1 []) step (NetworkEvent defaultTTL carol $ ReqTx $ aValidTx 1) step (ackFrom carolSk carol) diff --git a/hydra-node/test/Hydra/HeadLogicSpec.hs b/hydra-node/test/Hydra/HeadLogicSpec.hs index f5baec3addb..c26844e5446 100644 --- a/hydra-node/test/Hydra/HeadLogicSpec.hs +++ b/hydra-node/test/Hydra/HeadLogicSpec.hs @@ -97,7 +97,7 @@ spec = tx = SimpleTx 2 inputs mempty ttl = 0 reqTx = NetworkEvent ttl alice $ ReqTx tx - s0 = inOpenState threeParties ledger + s0 = inOpenState threeParties update bobEnv ledger s0 reqTx `hasEffectSatisfying` \case ClientEffect TxInvalid{transaction} -> transaction == tx @@ -106,7 +106,7 @@ spec = it "waits if a requested tx is not (yet) applicable" $ do let reqTx = NetworkEvent defaultTTL alice $ ReqTx $ SimpleTx 2 inputs mempty inputs = utxoRef 1 - s0 = inOpenState threeParties ledger + s0 = inOpenState threeParties update bobEnv ledger s0 reqTx `hasWait` WaitOnNotApplicableTx (ValidationError "cannot apply transaction") @@ -115,7 +115,7 @@ spec = let reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 [] snapshot1 = Snapshot testHeadId 1 mempty [] ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot1) 1 - snapshotInProgress <- runEvents bobEnv ledger (inOpenState threeParties ledger) $ do + snapshotInProgress <- runEvents bobEnv ledger (inOpenState threeParties) $ do step reqSn step (ackFrom carolSk carol) step (ackFrom aliceSk alice) @@ -131,7 +131,7 @@ spec = describe "Tracks Transaction Ids" $ do it "keeps transactions in allTxs given it receives a ReqTx" $ do - let s0 = inOpenState threeParties ledger + let s0 = inOpenState threeParties t1 = SimpleTx 1 mempty (utxoRef 1) sa <- runEvents bobEnv ledger s0 $ do @@ -143,7 +143,7 @@ spec = _ -> False it "removes transactions in allTxs given it receives a ReqSn" $ do - let s0 = inOpenState threeParties ledger + let s0 = inOpenState threeParties t1 = SimpleTx 1 mempty (utxoRef 1) reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 [1] @@ -163,7 +163,7 @@ spec = snapshot1 = testSnapshot 1 (utxoRefs [1]) [1] ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot1) 1 - sa <- runEvents bobEnv ledger (inOpenState threeParties ledger) $ do + sa <- runEvents bobEnv ledger (inOpenState threeParties) $ do step $ NetworkEvent defaultTTL alice $ ReqTx t1 step reqSn step (ackFrom carolSk carol) @@ -185,7 +185,7 @@ spec = ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot) 1 invalidAckFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot') 1 waitingForLastAck <- - runEvents bobEnv ledger (inOpenState threeParties ledger) $ do + runEvents bobEnv ledger (inOpenState threeParties) $ do step reqSn step (ackFrom carolSk carol) step (ackFrom aliceSk alice) @@ -201,7 +201,7 @@ spec = snapshot = testSnapshot 1 mempty [] ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot) 1 waitingForLastAck <- - runEvents bobEnv ledger (inOpenState threeParties ledger) $ do + runEvents bobEnv ledger (inOpenState threeParties) $ do step reqSn step (ackFrom carolSk carol) step (ackFrom aliceSk alice) @@ -220,7 +220,7 @@ spec = NetworkEvent defaultTTL vk $ AckSn (coerce $ sign sk ("foo" :: ByteString)) 1 waitingForLastAck <- - runEvents bobEnv ledger (inOpenState threeParties ledger) $ do + runEvents bobEnv ledger (inOpenState threeParties) $ do step reqSn step (ackFrom carolSk carol) step (invalidAckFrom bobSk bob) @@ -236,7 +236,7 @@ spec = snapshot1 = testSnapshot 1 mempty [] ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot1) 1 waitingForAck <- - runEvents bobEnv ledger (inOpenState threeParties ledger) $ do + runEvents bobEnv ledger (inOpenState threeParties) $ do step reqSn step (ackFrom carolSk carol) getState @@ -250,7 +250,7 @@ spec = let reqTx42 = NetworkEvent defaultTTL alice $ ReqTx (SimpleTx 42 mempty (utxoRef 1)) reqTx1 = NetworkEvent defaultTTL alice $ ReqTx (SimpleTx 1 (utxoRef 1) (utxoRef 2)) event = NetworkEvent defaultTTL alice $ ReqSn 1 [1] - s0 = inOpenState threeParties ledger + s0 = inOpenState threeParties s2 <- runEvents bobEnv ledger s0 $ do step reqTx42 @@ -261,7 +261,7 @@ spec = `shouldBe` Error (RequireFailed (SnapshotDoesNotApply 1 1 (ValidationError "cannot apply transaction"))) it "waits if we receive a snapshot with unseen transactions" $ do - let s0 = inOpenState threeParties ledger + let s0 = inOpenState threeParties reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 [1] update bobEnv ledger s0 reqSn `shouldBe` Wait (WaitOnTxs [1]) @@ -269,7 +269,7 @@ spec = it "waits if we receive an AckSn for an unseen snapshot" $ do let snapshot = testSnapshot 1 mempty [] event = NetworkEvent defaultTTL alice $ AckSn (sign aliceSk snapshot) 1 - update bobEnv ledger (inOpenState threeParties ledger) event `shouldBe` Wait WaitOnSeenSnapshot + update bobEnv ledger (inOpenState threeParties) event `shouldBe` Wait WaitOnSeenSnapshot -- TODO: Write property tests for various future / old snapshot behavior. -- That way we could cover variations of snapshot numbers and state of @@ -277,14 +277,14 @@ spec = it "rejects if we receive a too far future snapshot" $ do let event = NetworkEvent defaultTTL bob $ ReqSn 2 [] - st = inOpenState threeParties ledger + st = inOpenState threeParties update bobEnv ledger st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 0) it "waits if we receive a future snapshot while collecting signatures" $ do let reqSn1 = NetworkEvent defaultTTL alice $ ReqSn 1 [] reqSn2 = NetworkEvent defaultTTL bob $ ReqSn 2 [] st <- - runEvents bobEnv ledger (inOpenState threeParties ledger) $ do + runEvents bobEnv ledger (inOpenState threeParties) $ do step reqSn1 getState @@ -295,14 +295,14 @@ spec = snapshot = testSnapshot 1 mempty [] event = NetworkEvent defaultTTL leader $ ReqSn (number snapshot) [] sig = sign bobSk snapshot - st = inOpenState threeParties ledger + st = inOpenState threeParties ack = AckSn sig (number snapshot) update bobEnv ledger st event `hasEffect` NetworkEffect ack it "does not ack snapshots from non-leaders" $ do let event = NetworkEvent defaultTTL notTheLeader $ ReqSn 1 [] notTheLeader = bob - st = inOpenState threeParties ledger + st = inOpenState threeParties update bobEnv ledger st event `shouldSatisfy` \case Error (RequireFailed ReqSnNotLeader{requestedSn = 1, leader}) -> leader == notTheLeader _ -> False @@ -331,7 +331,7 @@ spec = it "rejects too-new snapshots from the leader" $ do let event = NetworkEvent defaultTTL theLeader $ ReqSn 3 [] theLeader = carol - st = inOpenState threeParties ledger + st = inOpenState threeParties update bobEnv ledger st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 3 0) it "rejects overlapping snapshot requests from the leader" $ do @@ -342,7 +342,7 @@ spec = secondReqTx = NetworkEvent defaultTTL alice $ ReqTx (aValidTx 51) secondReqSn = NetworkEvent defaultTTL theLeader $ ReqSn nextSN [51] - s3 <- runEvents bobEnv ledger (inOpenState threeParties ledger) $ do + s3 <- runEvents bobEnv ledger (inOpenState threeParties) $ do step firstReqTx step firstReqSn step secondReqTx @@ -394,7 +394,7 @@ spec = `shouldBe` Error (InvalidEvent invalidEvent afterAbort) it "notifies user on head closing and when passing the contestation deadline" $ do - let s0 = inOpenState threeParties ledger + let s0 = inOpenState threeParties snapshotNumber = 0 contestationDeadline = arbitrary `generateWith` 42 observeCloseTx = @@ -463,7 +463,7 @@ spec = `shouldBe` Error (NotOurHead{ourHeadId = testHeadId, otherHeadId}) prop "ignores closeTx of another head" $ \otherHeadId snapshotNumber contestationDeadline -> do - let openState = inOpenState threeParties ledger + let openState = inOpenState threeParties let closeOtherHead = observationEvent $ OnCloseTx{headId = otherHeadId, snapshotNumber, contestationDeadline} update bobEnv ledger openState closeOtherHead `shouldBe` Error (NotOurHead{ourHeadId = testHeadId, otherHeadId}) @@ -647,9 +647,8 @@ inInitialState parties = -- XXX: This is always called with threeParties and simpleLedger inOpenState :: [Party] -> - Ledger SimpleTx -> HeadState SimpleTx -inOpenState parties Ledger{initUTxO} = +inOpenState parties = inOpenState' parties $ CoordinatedHeadState { localUTxO = u0 @@ -659,7 +658,7 @@ inOpenState parties Ledger{initUTxO} = , seenSnapshot = NoSeenSnapshot } where - u0 = initUTxO + u0 = mempty confirmedSnapshot = InitialSnapshot testHeadId u0 inOpenState' :: @@ -685,8 +684,8 @@ inOpenState' parties coordinatedHeadState = inClosedState :: [Party] -> HeadState SimpleTx inClosedState parties = inClosedState' parties snapshot0 where - u0 = initUTxO simpleLedger snapshot0 = InitialSnapshot testHeadId u0 + u0 = mempty inClosedState' :: [Party] -> ConfirmedSnapshot SimpleTx -> HeadState SimpleTx inClosedState' parties confirmedSnapshot = diff --git a/hydra-node/test/Hydra/Model/MockChain.hs b/hydra-node/test/Hydra/Model/MockChain.hs index b073a70ce4a..6dd3954504c 100644 --- a/hydra-node/test/Hydra/Model/MockChain.hs +++ b/hydra-node/test/Hydra/Model/MockChain.hs @@ -107,14 +107,13 @@ mockChainAndNetwork tr seedKeys commits = do , simulateCommit = simulateCommit nodes } where - initialUTxO = initUTxO <> commits <> registryUTxO scriptRegistry + initialUTxO = seedUTxO <> commits <> registryUTxO scriptRegistry - seedInput = genTxIn `generateWith` 42 + seedUTxO = fromPairs [(seedInput, (arbitrary >>= genTxOutAdaOnly) `generateWith` 42)] - -- TODO: why not use the full 'cardanoLedger'? - ledger = scriptLedger seedInput + seedInput = genTxIn `generateWith` 42 - Ledger{initUTxO} = ledger + ledger = scriptLedger scriptRegistry = genScriptRegistry `generateWith` 42 @@ -286,16 +285,11 @@ fixedTimeHandleIndefiniteHorizon = do -- | A trimmed down ledger whose only purpose is to validate -- on-chain scripts. --- --- The initial UTxO set is primed with a dedicated UTxO for the `seedInput` and scriptLedger :: - TxIn -> Ledger Tx -scriptLedger seedInput = - Ledger{applyTransactions, initUTxO} +scriptLedger = + Ledger{applyTransactions} where - initUTxO = fromPairs [(seedInput, (arbitrary >>= genTxOutAdaOnly) `generateWith` 42)] - applyTransactions !slot utxo = \case [] -> Right utxo (tx : txs) -> diff --git a/hydra-node/test/Hydra/Model/MockChainSpec.hs b/hydra-node/test/Hydra/Model/MockChainSpec.hs index 608a3e60ef7..a8d01a1e9c3 100644 --- a/hydra-node/test/Hydra/Model/MockChainSpec.hs +++ b/hydra-node/test/Hydra/Model/MockChainSpec.hs @@ -9,7 +9,7 @@ import Hydra.Ledger.Cardano (genSequenceOfSimplePaymentTransactions) import Hydra.Model.MockChain (scriptLedger) import Hydra.Prelude import Test.Hydra.Prelude -import Test.QuickCheck (Property, Testable (property), counterexample, forAll, forAllBlind, (===)) +import Test.QuickCheck (Property, Testable (property), counterexample, forAllBlind, (===)) spec :: Spec spec = @@ -17,18 +17,17 @@ spec = appliesValidTransaction :: Property appliesValidTransaction = - forAll arbitrary $ \txin -> - forAllBlind genSequenceOfSimplePaymentTransactions $ \(utxo, txs) -> - let result = applyTransactions (scriptLedger txin) (ChainSlot 0) utxo txs - in case result of - Right u -> - isOutputOfLastTransaction txs u - Left (tx, err) -> - property False - & counterexample ("Error: " <> show err) - & counterexample ("Failing tx: " <> renderTx tx) - & counterexample ("All txs: " <> unpack (decodeUtf8With lenientDecode $ prettyPrintJSON txs)) - & counterexample ("Initial UTxO: " <> unpack (decodeUtf8With lenientDecode $ prettyPrintJSON utxo)) + forAllBlind genSequenceOfSimplePaymentTransactions $ \(utxo, txs) -> + let result = applyTransactions scriptLedger (ChainSlot 0) utxo txs + in case result of + Right u -> + isOutputOfLastTransaction txs u + Left (tx, err) -> + property False + & counterexample ("Error: " <> show err) + & counterexample ("Failing tx: " <> renderTx tx) + & counterexample ("All txs: " <> unpack (decodeUtf8With lenientDecode $ prettyPrintJSON txs)) + & counterexample ("Initial UTxO: " <> unpack (decodeUtf8With lenientDecode $ prettyPrintJSON utxo)) isOutputOfLastTransaction :: [Tx] -> UTxO -> Property isOutputOfLastTransaction txs utxo =