diff --git a/hydra-node/src/Hydra/Events.hs b/hydra-node/src/Hydra/Events.hs index a98f0d729a8..9fbc5d8659a 100644 --- a/hydra-node/src/Hydra/Events.hs +++ b/hydra-node/src/Hydra/Events.hs @@ -6,21 +6,23 @@ module Hydra.Events where import Hydra.Prelude --- TODO: Need to add a concept of identification to 'e' as used in these --- definitions to enable deduplication etc. +-- FIXME(Elaine): we have to figure out a better taxonomy/nomenclature for the events/statechange stuff +-- the eventID here is not the same as the eventID in Queued, that one is more fickle and influenced by non state change events +-- this one is only incremented when we have a new state change event +type EventId = Word64 -newtype EventSource e m = EventSource {getEvents' :: m [e]} +class HasEventId a where + getEventId :: a -> EventId -newtype EventSink e m = EventSink {putEvent' :: e -> m ()} +instance HasEventId (EventId, a) where + getEventId = fst -putEventToSinks :: Monad m => [EventSink e m] -> e -> m () -putEventToSinks sinks e = forM_ sinks (\sink -> putEvent' sink e) +newtype EventSource e m = EventSource {getEvents' :: HasEventId e => m [e]} -putEventsToSinks :: Monad m => [EventSink e m] -> [e] -> m () -putEventsToSinks sinks es = forM_ es (\e -> putEventToSinks sinks e) +newtype EventSink e m = EventSink {putEvent' :: HasEventId e => e -> m ()} -type EventID = Word64 +putEventToSinks :: (Monad m, HasEventId e) => [EventSink e m] -> e -> m () +putEventToSinks sinks e = forM_ sinks (\sink -> putEvent' sink e) --- FIXME(Elaine): we have to figure out a better taxonomy/nomenclature for the events/statechange stuff --- the eventID here is not the same as the eventID in Queued, that one is more fickle and influenced by non state change events --- this one is only incremented when we have a new state change event +putEventsToSinks :: (Monad m, HasEventId e) => [EventSink e m] -> [e] -> m () +putEventsToSinks sinks es = forM_ es (\e -> putEventToSinks sinks e) diff --git a/hydra-node/src/Hydra/HeadLogic/Outcome.hs b/hydra-node/src/Hydra/HeadLogic/Outcome.hs index d1899c671f8..e57a9c1cae5 100644 --- a/hydra-node/src/Hydra/HeadLogic/Outcome.hs +++ b/hydra-node/src/Hydra/HeadLogic/Outcome.hs @@ -8,6 +8,7 @@ import Hydra.Prelude import Hydra.API.ServerOutput (ServerOutput) import Hydra.Chain (ChainStateType, HeadParameters, IsChainState, PostChainTx) import Hydra.Crypto (MultiSignature, Signature) +import Hydra.Events (HasEventId (..)) import Hydra.HeadId (HeadId, HeadSeed) import Hydra.HeadLogic.Error (LogicError) import Hydra.HeadLogic.State (HeadState) @@ -86,24 +87,24 @@ data StateChanged tx | TickObserved {chainSlot :: ChainSlot, stateChangeID :: Word64} deriving stock (Generic) -getStateChangeID :: StateChanged tx -> Word64 -getStateChangeID = \case - HeadInitialized{stateChangeID} -> stateChangeID - CommittedUTxO{stateChangeID} -> stateChangeID - HeadAborted{stateChangeID} -> stateChangeID - HeadOpened{stateChangeID} -> stateChangeID - TransactionAppliedToLocalUTxO{stateChangeID} -> stateChangeID - SnapshotRequestDecided{stateChangeID} -> stateChangeID - SnapshotRequested{stateChangeID} -> stateChangeID - TransactionReceived{stateChangeID} -> stateChangeID - PartySignedSnapshot{stateChangeID} -> stateChangeID - SnapshotConfirmed{stateChangeID} -> stateChangeID - HeadClosed{stateChangeID} -> stateChangeID - HeadContested{stateChangeID} -> stateChangeID - HeadIsReadyToFanout{stateChangeID} -> stateChangeID - HeadFannedOut{stateChangeID} -> stateChangeID - ChainRolledBack{stateChangeID} -> stateChangeID - TickObserved{stateChangeID} -> stateChangeID +instance HasEventId (StateChanged tx) where + getEventId = \case + HeadInitialized{stateChangeID} -> stateChangeID + CommittedUTxO{stateChangeID} -> stateChangeID + HeadAborted{stateChangeID} -> stateChangeID + HeadOpened{stateChangeID} -> stateChangeID + TransactionAppliedToLocalUTxO{stateChangeID} -> stateChangeID + SnapshotRequestDecided{stateChangeID} -> stateChangeID + SnapshotRequested{stateChangeID} -> stateChangeID + TransactionReceived{stateChangeID} -> stateChangeID + PartySignedSnapshot{stateChangeID} -> stateChangeID + SnapshotConfirmed{stateChangeID} -> stateChangeID + HeadClosed{stateChangeID} -> stateChangeID + HeadContested{stateChangeID} -> stateChangeID + HeadIsReadyToFanout{stateChangeID} -> stateChangeID + HeadFannedOut{stateChangeID} -> stateChangeID + ChainRolledBack{stateChangeID} -> stateChangeID + TickObserved{stateChangeID} -> stateChangeID -- FIXME(Elaine): these stateChangeID fields were added in an attempt to make every StateChanged keep track of its ID -- it's not clear how to handle the state for this. but for now the field is kept so that the type of putEvent' can be kept simple, and shouldn't do harm diff --git a/hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs b/hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs index 9249a8b0331..1ad6deeacd0 100644 --- a/hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs +++ b/hydra-node/test/Hydra/HeadLogicSnapshotSpec.hs @@ -24,7 +24,7 @@ import Hydra.HeadLogic ( update, ) import Hydra.HeadLogic.Outcome (collectEffects) -import Hydra.HeadLogicSpec (getState, getStateAndEventID, inOpenState, inOpenState', runEvents, step) +import Hydra.HeadLogicSpec (getState, getStateAndEventId, inOpenState, inOpenState', runEvents, step) import Hydra.Ledger (txId) import Hydra.Ledger.Simple (SimpleTx (..), aValidTx, simpleLedger, utxoRef) import Hydra.Network.Message (Message (..)) @@ -118,7 +118,7 @@ spec = do (actualState, actualEventID) <- runEvents (envFor aliceSk) simpleLedger st stEventID $ do step $ NetworkEvent defaultTTL alice $ ReqTx tx - getStateAndEventID + getStateAndEventId actualState `shouldBe` st' actualEventID `shouldBe` st'EventID @@ -131,7 +131,7 @@ spec = do step (NetworkEvent defaultTTL carol $ ReqTx $ aValidTx 1) step (ackFrom carolSk carol) step (ackFrom aliceSk alice) - getStateAndEventID + getStateAndEventId let outcome = update bobEnv simpleLedger headStateEventID headState $ ackFrom bobSk bob collectEffects outcome `shouldSatisfy` sendReqSn @@ -141,7 +141,7 @@ spec = do step (NetworkEvent defaultTTL alice $ ReqSn 1 []) step (ackFrom carolSk carol) step (ackFrom aliceSk alice) - getStateAndEventID + getStateAndEventId let outcome = update bobEnv simpleLedger headStateEventID headState $ ackFrom bobSk bob collectEffects outcome `shouldNotSatisfy` sendReqSn @@ -160,7 +160,7 @@ spec = do step (ackFrom carolSk carol) newTxBeforeSnapshotAcknowledged step (ackFrom aliceSk alice) - getStateAndEventID + getStateAndEventId let everybodyAcknowleged = update notLeaderEnv simpleLedger headStateEventID headState $ ackFrom bobSk bob collectEffects everybodyAcknowleged `shouldNotSatisfy` sendReqSn diff --git a/hydra-node/test/Hydra/HeadLogicSpec.hs b/hydra-node/test/Hydra/HeadLogicSpec.hs index 4746dde06ee..a1baa5a31e8 100644 --- a/hydra-node/test/Hydra/HeadLogicSpec.hs +++ b/hydra-node/test/Hydra/HeadLogicSpec.hs @@ -28,7 +28,7 @@ import Hydra.Chain.Direct.Fixture qualified as Fixture import Hydra.Chain.Direct.State () import Hydra.Crypto (generateSigningKey, sign) import Hydra.Crypto qualified as Crypto -import Hydra.Events (EventID) +import Hydra.Events (EventId) import Hydra.HeadLogic ( ClosedState (..), CoordinatedHeadState (..), @@ -83,7 +83,7 @@ spec = describe "Coordinated Head Protocol" $ do let ledger = simpleLedger - let initialEventID = 0 + let initialEventId = 0 let coordinatedHeadState = CoordinatedHeadState @@ -118,7 +118,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) initialEventID $ do + snapshotInProgress <- runEvents bobEnv ledger (inOpenState threeParties) initialEventId $ do step reqSn step (ackFrom carolSk carol) step (ackFrom aliceSk alice) @@ -127,7 +127,7 @@ spec = getConfirmedSnapshot snapshotInProgress `shouldBe` Just (testSnapshot 0 mempty []) snapshotConfirmed <- - runEvents bobEnv ledger snapshotInProgress initialEventID $ do + runEvents bobEnv ledger snapshotInProgress initialEventId $ do step (ackFrom bobSk bob) getState getConfirmedSnapshot snapshotConfirmed `shouldBe` Just snapshot1 @@ -137,7 +137,7 @@ spec = let s0 = inOpenState threeParties t1 = SimpleTx 1 mempty (utxoRef 1) - sa <- runEvents bobEnv ledger s0 initialEventID $ do + sa <- runEvents bobEnv ledger s0 initialEventId $ do step $ NetworkEvent defaultTTL alice $ ReqTx t1 getState @@ -150,7 +150,7 @@ spec = t1 = SimpleTx 1 mempty (utxoRef 1) reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 [1] - s1 <- runEvents bobEnv ledger s0 initialEventID $ do + s1 <- runEvents bobEnv ledger s0 initialEventId $ do step $ NetworkEvent defaultTTL alice $ ReqTx t1 step reqSn getState @@ -166,7 +166,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) initialEventID $ do + sa <- runEvents bobEnv ledger (inOpenState threeParties) initialEventId $ do step $ NetworkEvent defaultTTL alice $ ReqTx t1 step reqSn step (ackFrom carolSk carol) @@ -187,13 +187,13 @@ spec = snapshot' = testSnapshot 2 mempty [] ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot) 1 invalidAckFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot') 1 - (waitingForLastAck, waitingForLastAckEventID) <- - runEvents bobEnv ledger (inOpenState threeParties) initialEventID $ do + (waitingForLastAck, waitingForLastAckEventId) <- + runEvents bobEnv ledger (inOpenState threeParties) initialEventId $ do step reqSn step (ackFrom carolSk carol) step (ackFrom aliceSk alice) - getStateAndEventID -- NOTE(Elaine): to me this suggests that every time that HeadState should be aware of the current eventID - update bobEnv ledger waitingForLastAckEventID waitingForLastAck (invalidAckFrom bobSk bob) + getStateAndEventId -- NOTE(Elaine): to me this suggests that every time that HeadState should be aware of the current eventID + update bobEnv ledger waitingForLastAckEventId waitingForLastAck (invalidAckFrom bobSk bob) `shouldSatisfy` \case Error (RequireFailed InvalidMultisignature{vkeys}) -> vkeys == [vkey bob] _ -> False @@ -202,14 +202,14 @@ spec = let reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 [] snapshot = testSnapshot 1 mempty [] ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot) 1 - (waitingForLastAck, waitingForLastAckEventID) <- - runEvents bobEnv ledger (inOpenState threeParties) initialEventID $ do + (waitingForLastAck, waitingForLastAckEventId) <- + runEvents bobEnv ledger (inOpenState threeParties) initialEventId $ do step reqSn step (ackFrom carolSk carol) step (ackFrom aliceSk alice) - getStateAndEventID + getStateAndEventId - update bobEnv ledger waitingForLastAckEventID waitingForLastAck (ackFrom (generateSigningKey "foo") bob) + update bobEnv ledger waitingForLastAckEventId waitingForLastAck (ackFrom (generateSigningKey "foo") bob) `shouldSatisfy` \case Error (RequireFailed InvalidMultisignature{vkeys}) -> vkeys == [vkey bob] _ -> False @@ -221,14 +221,14 @@ spec = invalidAckFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (coerce $ sign sk ("foo" :: ByteString)) 1 - (waitingForLastAck, waitingForLastAckEventID) <- - runEvents bobEnv ledger (inOpenState threeParties) initialEventID $ do + (waitingForLastAck, waitingForLastAckEventId) <- + runEvents bobEnv ledger (inOpenState threeParties) initialEventId $ do step reqSn step (ackFrom carolSk carol) step (invalidAckFrom bobSk bob) - getStateAndEventID + getStateAndEventId - update bobEnv ledger waitingForLastAckEventID waitingForLastAck (ackFrom aliceSk alice) + update bobEnv ledger waitingForLastAckEventId waitingForLastAck (ackFrom aliceSk alice) `shouldSatisfy` \case Error (RequireFailed InvalidMultisignature{vkeys}) -> vkeys == [vkey bob] _ -> False @@ -237,13 +237,13 @@ spec = let reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 [] snapshot1 = testSnapshot 1 mempty [] ackFrom sk vk = NetworkEvent defaultTTL vk $ AckSn (sign sk snapshot1) 1 - (waitingForAck, waitingForAckEventID) <- - runEvents bobEnv ledger (inOpenState threeParties) initialEventID $ do + (waitingForAck, waitingForAckEventId) <- + runEvents bobEnv ledger (inOpenState threeParties) initialEventId $ do step reqSn step (ackFrom carolSk carol) - getStateAndEventID + getStateAndEventId - update bobEnv ledger waitingForAckEventID waitingForAck (ackFrom carolSk carol) + update bobEnv ledger waitingForAckEventId waitingForAck (ackFrom carolSk carol) `shouldSatisfy` \case Error (RequireFailed SnapshotAlreadySigned{receivedSignature}) -> receivedSignature == carol _ -> False @@ -252,26 +252,26 @@ 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, s0EventID) = (inOpenState threeParties, initialEventID) + (s0, s0EventId) = (inOpenState threeParties, initialEventId) - (s2, s2EventID) <- runEvents bobEnv ledger s0 s0EventID $ do + (s2, s2EventId) <- runEvents bobEnv ledger s0 s0EventId $ do step reqTx42 step reqTx1 - getStateAndEventID + getStateAndEventId - update bobEnv ledger s2EventID s2 event + update bobEnv ledger s2EventId s2 event `shouldBe` Error (RequireFailed (SnapshotDoesNotApply 1 1 (ValidationError "cannot apply transaction"))) it "waits if we receive a snapshot with unseen transactions" $ do - let (s0, s0EventID) = (inOpenState threeParties, initialEventID) + let (s0, s0EventId) = (inOpenState threeParties, initialEventId) reqSn = NetworkEvent defaultTTL alice $ ReqSn 1 [1] - update bobEnv ledger s0EventID s0 reqSn + update bobEnv ledger s0EventId s0 reqSn `shouldBe` Wait (WaitOnTxs [1]) 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 initialEventID (inOpenState threeParties) event `shouldBe` Wait WaitOnSeenSnapshot + update bobEnv ledger initialEventId (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 @@ -279,33 +279,33 @@ spec = it "rejects if we receive a too far future snapshot" $ do let event = NetworkEvent defaultTTL bob $ ReqSn 2 [] - (st, stEventID) = (inOpenState threeParties, initialEventID) - update bobEnv ledger stEventID st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 0) + (st, stEventId) = (inOpenState threeParties, initialEventId) + update bobEnv ledger stEventId 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, stEventID) <- - runEvents bobEnv ledger (inOpenState threeParties) initialEventID $ do + (st, stEventId) <- + runEvents bobEnv ledger (inOpenState threeParties) initialEventId $ do step reqSn1 - getStateAndEventID + getStateAndEventId - update bobEnv ledger stEventID st reqSn2 `shouldBe` Wait (WaitOnSnapshotNumber 1) + update bobEnv ledger stEventId st reqSn2 `shouldBe` Wait (WaitOnSnapshotNumber 1) it "acks signed snapshot from the constant leader" $ do let leader = alice snapshot = testSnapshot 1 mempty [] event = NetworkEvent defaultTTL leader $ ReqSn (number snapshot) [] sig = sign bobSk snapshot - (st, stEventID) = (inOpenState threeParties, initialEventID) + (st, stEventId) = (inOpenState threeParties, initialEventId) ack = AckSn sig (number snapshot) - update bobEnv ledger stEventID st event `hasEffect` NetworkEffect ack + update bobEnv ledger stEventId st event `hasEffect` NetworkEffect ack it "does not ack snapshots from non-leaders" $ do let event = NetworkEvent defaultTTL notTheLeader $ ReqSn 1 [] notTheLeader = bob - (st, stEventID) = (inOpenState threeParties, initialEventID) - update bobEnv ledger stEventID st event `shouldSatisfy` \case + (st, stEventId) = (inOpenState threeParties, initialEventId) + update bobEnv ledger stEventId st event `shouldSatisfy` \case Error (RequireFailed ReqSnNotLeader{requestedSn = 1, leader}) -> leader == notTheLeader _ -> False @@ -313,30 +313,30 @@ spec = let event = NetworkEvent defaultTTL theLeader $ ReqSn 2 [] theLeader = alice snapshot = testSnapshot 2 mempty [] - stEventID = initialEventID + stEventId = initialEventId st = inOpenState' threeParties $ coordinatedHeadState{confirmedSnapshot = ConfirmedSnapshot snapshot (Crypto.aggregate [])} - update bobEnv ledger stEventID st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 0) + update bobEnv ledger stEventId st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 0) it "rejects too-old snapshots when collecting signatures" $ do let event = NetworkEvent defaultTTL theLeader $ ReqSn 2 [] theLeader = alice snapshot = testSnapshot 2 mempty [] - stEventID = initialEventID + stEventId = initialEventId st = inOpenState' threeParties $ coordinatedHeadState { confirmedSnapshot = ConfirmedSnapshot snapshot (Crypto.aggregate []) , seenSnapshot = SeenSnapshot (testSnapshot 3 mempty []) mempty } - update bobEnv ledger stEventID st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 3) + update bobEnv ledger stEventId st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 2 3) it "rejects too-new snapshots from the leader" $ do let event = NetworkEvent defaultTTL theLeader $ ReqSn 3 [] theLeader = carol - (st, stEventID) = (inOpenState threeParties, stEventID) - update bobEnv ledger stEventID st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 3 0) + (st, stEventId) = (inOpenState threeParties, stEventId) + update bobEnv ledger stEventId st event `shouldBe` Error (RequireFailed $ ReqSnNumberInvalid 3 0) it "rejects overlapping snapshot requests from the leader" $ do let theLeader = alice @@ -346,59 +346,59 @@ spec = secondReqTx = NetworkEvent defaultTTL alice $ ReqTx (aValidTx 51) secondReqSn = NetworkEvent defaultTTL theLeader $ ReqSn nextSN [51] - (s3, s3EventID) <- runEvents bobEnv ledger (inOpenState threeParties) initialEventID $ do + (s3, s3EventId) <- runEvents bobEnv ledger (inOpenState threeParties) initialEventId $ do step firstReqTx step firstReqSn step secondReqTx - getStateAndEventID + getStateAndEventId - update bobEnv ledger s3EventID s3 secondReqSn `shouldSatisfy` \case + update bobEnv ledger s3EventId s3 secondReqSn `shouldSatisfy` \case Error RequireFailed{} -> True _ -> False it "ignores in-flight ReqTx when closed" $ do - let (s0, s0EventID) = (inClosedState threeParties, initialEventID) + let (s0, s0EventId) = (inClosedState threeParties, initialEventId) event = NetworkEvent defaultTTL alice $ ReqTx (aValidTx 42) - update bobEnv ledger s0EventID s0 event `shouldBe` Error (InvalidEvent event s0) + update bobEnv ledger s0EventId s0 event `shouldBe` Error (InvalidEvent event s0) it "everyone does collect on last commit after collect com" $ do let aliceCommit = OnCommitTx testHeadId alice (utxoRef 1) bobCommit = OnCommitTx testHeadId bob (utxoRef 2) carolCommit = OnCommitTx testHeadId carol (utxoRef 3) - (waitingForLastCommit, waitingForLastCommitEventID) <- - runEvents bobEnv ledger (inInitialState threeParties) initialEventID $ do + (waitingForLastCommit, waitingForLastCommitEventId) <- + runEvents bobEnv ledger (inInitialState threeParties) initialEventId $ do step (observeEventAtSlot 1 aliceCommit) step (observeEventAtSlot 2 bobCommit) - getStateAndEventID + getStateAndEventId -- Bob is not the last party, but still does post a collect - update bobEnv ledger waitingForLastCommitEventID waitingForLastCommit (observeEventAtSlot 3 carolCommit) + update bobEnv ledger waitingForLastCommitEventId waitingForLastCommit (observeEventAtSlot 3 carolCommit) `hasEffectSatisfying` \case OnChainEffect{postChainTx = CollectComTx{}} -> True _ -> False it "cannot observe abort after collect com" $ do - (afterCollectCom, afterCollectComEventID) <- - runEvents bobEnv ledger (inInitialState threeParties) initialEventID $ do + (afterCollectCom, afterCollectComEventId) <- + runEvents bobEnv ledger (inInitialState threeParties) initialEventId $ do step (observationEvent $ OnCollectComTx testHeadId) - getStateAndEventID + getStateAndEventId let invalidEvent = observationEvent OnAbortTx{headId = testHeadId} - update bobEnv ledger afterCollectComEventID afterCollectCom invalidEvent + update bobEnv ledger afterCollectComEventId afterCollectCom invalidEvent `shouldBe` Error (InvalidEvent invalidEvent afterCollectCom) it "cannot observe collect com after abort" $ do - (afterAbort, afterAbortEventID) <- - runEvents bobEnv ledger (inInitialState threeParties) initialEventID $ do + (afterAbort, afterAbortEventId) <- + runEvents bobEnv ledger (inInitialState threeParties) initialEventId $ do step (observationEvent OnAbortTx{headId = testHeadId}) - getStateAndEventID + getStateAndEventId let invalidEvent = observationEvent (OnCollectComTx testHeadId) - update bobEnv ledger afterAbortEventID afterAbort invalidEvent + update bobEnv ledger afterAbortEventId afterAbort invalidEvent `shouldBe` Error (InvalidEvent invalidEvent afterAbort) it "notifies user on head closing and when passing the contestation deadline" $ do - let (s0, s0EventID) = (inOpenState threeParties, initialEventID) + let (s0, s0EventId) = (inOpenState threeParties, initialEventId) snapshotNumber = 0 contestationDeadline = arbitrary `generateWith` 42 observeCloseTx = @@ -409,7 +409,7 @@ spec = , contestationDeadline } clientEffect = ClientEffect HeadIsClosed{headId = testHeadId, snapshotNumber, contestationDeadline} - runEvents bobEnv ledger s0 s0EventID $ do + runEvents bobEnv ledger s0 s0EventId $ do outcome1 <- step observeCloseTx lift $ do outcome1 `hasEffect` clientEffect @@ -427,7 +427,7 @@ spec = it "contests when detecting close with old snapshot" $ do let snapshot = testSnapshot 2 mempty [] latestConfirmedSnapshot = ConfirmedSnapshot snapshot (Crypto.aggregate []) - s0EventID = initialEventID + s0EventId = initialEventId s0 = inOpenState' threeParties $ coordinatedHeadState{confirmedSnapshot = latestConfirmedSnapshot} @@ -435,7 +435,7 @@ spec = closeTxEvent = observationEvent $ OnCloseTx testHeadId 0 deadline params = fromMaybe (HeadParameters defaultContestationPeriod threeParties) (getHeadParameters s0) contestTxEffect = chainEffect $ ContestTx testHeadId params latestConfirmedSnapshot - runEvents bobEnv ledger s0 s0EventID $ do + runEvents bobEnv ledger s0 s0EventId $ do o1 <- step closeTxEvent lift $ o1 `hasEffect` contestTxEffect s1 <- getState @@ -447,11 +447,12 @@ spec = it "re-contests when detecting contest with old snapshot" $ do let snapshot2 = testSnapshot 2 mempty [] latestConfirmedSnapshot = ConfirmedSnapshot snapshot2 (Crypto.aggregate []) - (s0, s0EventID) = (inClosedState' threeParties latestConfirmedSnapshot, initialEventID) + (s0, s0EventId) = (inClosedState' threeParties latestConfirmedSnapshot, initialEventId) + deadline = arbitrary `generateWith` 42 contestSnapshot1Event = observationEvent $ OnContestTx testHeadId 1 deadline params = fromMaybe (HeadParameters defaultContestationPeriod threeParties) (getHeadParameters s0) contestTxEffect = chainEffect $ ContestTx testHeadId params latestConfirmedSnapshot - s1 = update bobEnv ledger s0EventID s0 contestSnapshot1Event + s1 = update bobEnv ledger s0EventId s0 contestSnapshot1Event s1 `hasEffect` contestTxEffect assertEffects s1 @@ -459,28 +460,28 @@ spec = prop "ignores abortTx of another head" $ \otherHeadId -> do let abortOtherHead = observationEvent $ OnAbortTx{headId = otherHeadId} - update bobEnv ledger initialEventID (inInitialState threeParties) abortOtherHead + update bobEnv ledger initialEventId (inInitialState threeParties) abortOtherHead `shouldBe` Error (NotOurHead{ourHeadId = testHeadId, otherHeadId}) prop "ignores collectComTx of another head" $ \otherHeadId -> do let collectOtherHead = observationEvent $ OnCollectComTx{headId = otherHeadId} - update bobEnv ledger initialEventID (inInitialState threeParties) collectOtherHead + update bobEnv ledger initialEventId (inInitialState threeParties) collectOtherHead `shouldBe` Error (NotOurHead{ourHeadId = testHeadId, otherHeadId}) prop "ignores closeTx of another head" $ \otherHeadId snapshotNumber contestationDeadline -> do - let (openState, openStateHeadID) = (inOpenState threeParties, initialEventID) + let (openState, openStateHeadID) = (inOpenState threeParties, initialEventId) let closeOtherHead = observationEvent $ OnCloseTx{headId = otherHeadId, snapshotNumber, contestationDeadline} update bobEnv ledger openStateHeadID openState closeOtherHead `shouldBe` Error (NotOurHead{ourHeadId = testHeadId, otherHeadId}) prop "ignores contestTx of another head" $ \otherHeadId snapshotNumber contestationDeadline -> do let contestOtherHead = observationEvent $ OnContestTx{headId = otherHeadId, snapshotNumber, contestationDeadline} - update bobEnv ledger initialEventID (inClosedState threeParties) contestOtherHead + update bobEnv ledger initialEventId (inClosedState threeParties) contestOtherHead `shouldBe` Error (NotOurHead{ourHeadId = testHeadId, otherHeadId}) prop "ignores fanoutTx of another head" $ \otherHeadId -> do let collectOtherHead = observationEvent $ OnFanoutTx{headId = otherHeadId} - update bobEnv ledger initialEventID (inClosedState threeParties) collectOtherHead + update bobEnv ledger initialEventId (inClosedState threeParties) collectOtherHead `shouldBe` Error (NotOurHead{ourHeadId = testHeadId, otherHeadId}) describe "Coordinated Head Protocol using real Tx" $ @@ -601,7 +602,7 @@ runEvents :: Environment -> Ledger tx -> HeadState tx -> - EventID -> + EventId -> StateT (StepState tx) m a -> m a runEvents env ledger headState lastStateChangeId = (`evalStateT` StepState{env, ledger, headState, lastStateChangeId}) @@ -737,8 +738,8 @@ data StepState tx = StepState getState :: MonadState (StepState tx) m => m (HeadState tx) getState = headState <$> get -getStateAndEventID :: MonadState (StepState tx) m => m (HeadState tx, EventID) -getStateAndEventID = do +getStateAndEventId :: MonadState (StepState tx) m => m (HeadState tx, EventId) +getStateAndEventId = do StepState{headState, lastStateChangeId} <- get pure (headState, lastStateChangeId) diff --git a/hydra-node/test/Hydra/PersistenceSpec.hs b/hydra-node/test/Hydra/PersistenceSpec.hs index a7d8c9f936c..3b44859e8bb 100644 --- a/hydra-node/test/Hydra/PersistenceSpec.hs +++ b/hydra-node/test/Hydra/PersistenceSpec.hs @@ -8,7 +8,7 @@ import Test.Hydra.Prelude import Data.Aeson (Value (..)) import Data.Aeson qualified as Aeson import Data.Text qualified as Text -import Hydra.Events (getEvents', putEventsToSinks) +import Hydra.Events (EventId, getEvents', putEventsToSinks) import Hydra.Persistence (Persistence (..), PersistenceException (..), PersistenceIncremental (..), createPersistence, createPersistenceIncremental, eventPairFromPersistenceIncremental) import Test.QuickCheck (checkCoverage, cover, elements, oneof, suchThat, (===)) import Test.QuickCheck.Gen (listOf) @@ -75,7 +75,7 @@ spec = do it "re-delivers events on EventSource load, to all EventSinks" $ checkCoverage $ monadicIO $ do - items <- pick $ listOf genPersistenceItem + items <- pick $ zip [(0 :: EventId) ..] <$> listOf genPersistenceItem run $ withTempDir "hydra-persistence" $ \tmpDir -> do -- FIXME(Elaine): swap for createEventPairIncremental only once nothing is using eventPairFromPersistenceIncremental