{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State ( ChainSyncClientHandle (..) , ChainSyncJumpingJumperState (..) , ChainSyncJumpingState (..) , ChainSyncState (..) , DisengagedInitState (..) , DynamoInitState (..) , JumpInfo (..) , JumperInitState (..) , ObjectorInitState (..) ) where import Cardano.Slotting.Slot (SlotNo, WithOrigin) import Data.Function (on) import Data.Maybe.Strict (StrictMaybe (..)) import Data.Typeable (Proxy (..), typeRep) import GHC.Generics (Generic) import Ouroboros.Consensus.Block (HasHeader, Header, Point) import Ouroboros.Consensus.HeaderStateHistory (HeaderStateHistory) import Ouroboros.Consensus.Ledger.SupportsProtocol (LedgerSupportsProtocol) import Ouroboros.Consensus.Node.GsmState (GsmState) import Ouroboros.Consensus.Util.IOLike (IOLike, NoThunks (..), STM, StrictTVar, Time) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, headPoint) -- | A ChainSync client's state that's used by other components, like the GDD or -- the jumping governor. data ChainSyncState blk = ChainSyncState { -- | The current candidate fragment. forall blk. ChainSyncState blk -> AnchoredFragment (Header blk) csCandidate :: !(AnchoredFragment (Header blk)) -- | Whether the last message sent by the peer was MsgAwaitReply. -- -- This ChainSync client should ensure that its peer sets this flag while -- and only while both of the following conditions are satisfied: the -- peer's latest message has been fully processed (especially that its -- candidate has been updated; previous argument) and its latest message -- did not claim that it already has headers that extend its candidate. -- -- It's more important that the flag is unset promptly than it is for the -- flag to be set promptly, because of how this is used by the GSM to -- determine that the node is done syncing. , forall blk. ChainSyncState blk -> Bool csIdling :: !Bool -- | When the client receives a new header, it updates this field before -- processing it further, and the latest slot may refer to a header beyond -- the forecast horizon while the candidate fragment isn't extended yet, to -- signal to GDD that the density is known up to this slot. , forall blk. ChainSyncState blk -> StrictMaybe (WithOrigin SlotNo) csLatestSlot :: !(StrictMaybe (WithOrigin SlotNo)) } deriving stock ((forall x. ChainSyncState blk -> Rep (ChainSyncState blk) x) -> (forall x. Rep (ChainSyncState blk) x -> ChainSyncState blk) -> Generic (ChainSyncState blk) forall x. Rep (ChainSyncState blk) x -> ChainSyncState blk forall x. ChainSyncState blk -> Rep (ChainSyncState blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall blk x. Rep (ChainSyncState blk) x -> ChainSyncState blk forall blk x. ChainSyncState blk -> Rep (ChainSyncState blk) x $cfrom :: forall blk x. ChainSyncState blk -> Rep (ChainSyncState blk) x from :: forall x. ChainSyncState blk -> Rep (ChainSyncState blk) x $cto :: forall blk x. Rep (ChainSyncState blk) x -> ChainSyncState blk to :: forall x. Rep (ChainSyncState blk) x -> ChainSyncState blk Generic) deriving anyclass instance ( HasHeader blk, NoThunks (Header blk) ) => NoThunks (ChainSyncState blk) -- | An interface to a ChainSync client that's used by other components, like -- the GDD governor. data ChainSyncClientHandle m blk = ChainSyncClientHandle { -- | Disconnects from the peer when the GDD considers it adversarial forall (m :: * -> *) blk. ChainSyncClientHandle m blk -> m () cschGDDKill :: !(m ()) -- | Callback called by the GSM when the GSM state changes. They take the -- current time and should execute rapidly. Used to enable/disable the LoP. , forall (m :: * -> *) blk. ChainSyncClientHandle m blk -> GsmState -> Time -> STM m () cschOnGsmStateChanged :: !(GsmState -> Time -> STM m ()) -- | Data shared between the client and external components like GDD. , forall (m :: * -> *) blk. ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncState blk) cschState :: !(StrictTVar m (ChainSyncState blk)) -- | The state of the peer with respect to ChainSync jumping. , forall (m :: * -> *) blk. ChainSyncClientHandle m blk -> StrictTVar m (ChainSyncJumpingState m blk) cschJumping :: !(StrictTVar m (ChainSyncJumpingState m blk)) -- | ChainSync state needed to jump to the tip of the candidate fragment of -- the peer. , forall (m :: * -> *) blk. ChainSyncClientHandle m blk -> StrictTVar m (Maybe (JumpInfo blk)) cschJumpInfo :: !(StrictTVar m (Maybe (JumpInfo blk))) } deriving stock ((forall x. ChainSyncClientHandle m blk -> Rep (ChainSyncClientHandle m blk) x) -> (forall x. Rep (ChainSyncClientHandle m blk) x -> ChainSyncClientHandle m blk) -> Generic (ChainSyncClientHandle m blk) forall x. Rep (ChainSyncClientHandle m blk) x -> ChainSyncClientHandle m blk forall x. ChainSyncClientHandle m blk -> Rep (ChainSyncClientHandle m blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall (m :: * -> *) blk x. Rep (ChainSyncClientHandle m blk) x -> ChainSyncClientHandle m blk forall (m :: * -> *) blk x. ChainSyncClientHandle m blk -> Rep (ChainSyncClientHandle m blk) x $cfrom :: forall (m :: * -> *) blk x. ChainSyncClientHandle m blk -> Rep (ChainSyncClientHandle m blk) x from :: forall x. ChainSyncClientHandle m blk -> Rep (ChainSyncClientHandle m blk) x $cto :: forall (m :: * -> *) blk x. Rep (ChainSyncClientHandle m blk) x -> ChainSyncClientHandle m blk to :: forall x. Rep (ChainSyncClientHandle m blk) x -> ChainSyncClientHandle m blk Generic) deriving anyclass instance ( IOLike m, HasHeader blk, LedgerSupportsProtocol blk, NoThunks (Header blk) ) => NoThunks (ChainSyncClientHandle m blk) data DynamoInitState blk = -- | The dynamo has not yet started jumping and we first need to jump to the -- given jump info to set the intersection of the ChainSync server. DynamoStarting !(JumpInfo blk) | DynamoStarted deriving ((forall x. DynamoInitState blk -> Rep (DynamoInitState blk) x) -> (forall x. Rep (DynamoInitState blk) x -> DynamoInitState blk) -> Generic (DynamoInitState blk) forall x. Rep (DynamoInitState blk) x -> DynamoInitState blk forall x. DynamoInitState blk -> Rep (DynamoInitState blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall blk x. Rep (DynamoInitState blk) x -> DynamoInitState blk forall blk x. DynamoInitState blk -> Rep (DynamoInitState blk) x $cfrom :: forall blk x. DynamoInitState blk -> Rep (DynamoInitState blk) x from :: forall x. DynamoInitState blk -> Rep (DynamoInitState blk) x $cto :: forall blk x. Rep (DynamoInitState blk) x -> DynamoInitState blk to :: forall x. Rep (DynamoInitState blk) x -> DynamoInitState blk Generic) deriving anyclass instance ( HasHeader blk, LedgerSupportsProtocol blk, NoThunks (Header blk) ) => NoThunks (DynamoInitState blk) data ObjectorInitState = -- | The objector still needs to set the intersection of the ChainSync -- server before resuming retrieval of headers. Starting | Started deriving ((forall x. ObjectorInitState -> Rep ObjectorInitState x) -> (forall x. Rep ObjectorInitState x -> ObjectorInitState) -> Generic ObjectorInitState forall x. Rep ObjectorInitState x -> ObjectorInitState forall x. ObjectorInitState -> Rep ObjectorInitState x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cfrom :: forall x. ObjectorInitState -> Rep ObjectorInitState x from :: forall x. ObjectorInitState -> Rep ObjectorInitState x $cto :: forall x. Rep ObjectorInitState x -> ObjectorInitState to :: forall x. Rep ObjectorInitState x -> ObjectorInitState Generic, Int -> ObjectorInitState -> ShowS [ObjectorInitState] -> ShowS ObjectorInitState -> String (Int -> ObjectorInitState -> ShowS) -> (ObjectorInitState -> String) -> ([ObjectorInitState] -> ShowS) -> Show ObjectorInitState forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> ObjectorInitState -> ShowS showsPrec :: Int -> ObjectorInitState -> ShowS $cshow :: ObjectorInitState -> String show :: ObjectorInitState -> String $cshowList :: [ObjectorInitState] -> ShowS showList :: [ObjectorInitState] -> ShowS Show, Context -> ObjectorInitState -> IO (Maybe ThunkInfo) Proxy ObjectorInitState -> String (Context -> ObjectorInitState -> IO (Maybe ThunkInfo)) -> (Context -> ObjectorInitState -> IO (Maybe ThunkInfo)) -> (Proxy ObjectorInitState -> String) -> NoThunks ObjectorInitState forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a $cnoThunks :: Context -> ObjectorInitState -> IO (Maybe ThunkInfo) noThunks :: Context -> ObjectorInitState -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> ObjectorInitState -> IO (Maybe ThunkInfo) wNoThunks :: Context -> ObjectorInitState -> IO (Maybe ThunkInfo) $cshowTypeOf :: Proxy ObjectorInitState -> String showTypeOf :: Proxy ObjectorInitState -> String NoThunks) data DisengagedInitState = -- | The node is being disengaged and for that we need to restart the -- ChainSync protocol. Disengaging | DisengagedDone deriving ((forall x. DisengagedInitState -> Rep DisengagedInitState x) -> (forall x. Rep DisengagedInitState x -> DisengagedInitState) -> Generic DisengagedInitState forall x. Rep DisengagedInitState x -> DisengagedInitState forall x. DisengagedInitState -> Rep DisengagedInitState x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cfrom :: forall x. DisengagedInitState -> Rep DisengagedInitState x from :: forall x. DisengagedInitState -> Rep DisengagedInitState x $cto :: forall x. Rep DisengagedInitState x -> DisengagedInitState to :: forall x. Rep DisengagedInitState x -> DisengagedInitState Generic, Int -> DisengagedInitState -> ShowS [DisengagedInitState] -> ShowS DisengagedInitState -> String (Int -> DisengagedInitState -> ShowS) -> (DisengagedInitState -> String) -> ([DisengagedInitState] -> ShowS) -> Show DisengagedInitState forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> DisengagedInitState -> ShowS showsPrec :: Int -> DisengagedInitState -> ShowS $cshow :: DisengagedInitState -> String show :: DisengagedInitState -> String $cshowList :: [DisengagedInitState] -> ShowS showList :: [DisengagedInitState] -> ShowS Show, Context -> DisengagedInitState -> IO (Maybe ThunkInfo) Proxy DisengagedInitState -> String (Context -> DisengagedInitState -> IO (Maybe ThunkInfo)) -> (Context -> DisengagedInitState -> IO (Maybe ThunkInfo)) -> (Proxy DisengagedInitState -> String) -> NoThunks DisengagedInitState forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a $cnoThunks :: Context -> DisengagedInitState -> IO (Maybe ThunkInfo) noThunks :: Context -> DisengagedInitState -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> DisengagedInitState -> IO (Maybe ThunkInfo) wNoThunks :: Context -> DisengagedInitState -> IO (Maybe ThunkInfo) $cshowTypeOf :: Proxy DisengagedInitState -> String showTypeOf :: Proxy DisengagedInitState -> String NoThunks) data JumperInitState = -- | The jumper hasn't been requested to jump yet FreshJumper | StartedJumper deriving ((forall x. JumperInitState -> Rep JumperInitState x) -> (forall x. Rep JumperInitState x -> JumperInitState) -> Generic JumperInitState forall x. Rep JumperInitState x -> JumperInitState forall x. JumperInitState -> Rep JumperInitState x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cfrom :: forall x. JumperInitState -> Rep JumperInitState x from :: forall x. JumperInitState -> Rep JumperInitState x $cto :: forall x. Rep JumperInitState x -> JumperInitState to :: forall x. Rep JumperInitState x -> JumperInitState Generic, Int -> JumperInitState -> ShowS [JumperInitState] -> ShowS JumperInitState -> String (Int -> JumperInitState -> ShowS) -> (JumperInitState -> String) -> ([JumperInitState] -> ShowS) -> Show JumperInitState forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: Int -> JumperInitState -> ShowS showsPrec :: Int -> JumperInitState -> ShowS $cshow :: JumperInitState -> String show :: JumperInitState -> String $cshowList :: [JumperInitState] -> ShowS showList :: [JumperInitState] -> ShowS Show, Context -> JumperInitState -> IO (Maybe ThunkInfo) Proxy JumperInitState -> String (Context -> JumperInitState -> IO (Maybe ThunkInfo)) -> (Context -> JumperInitState -> IO (Maybe ThunkInfo)) -> (Proxy JumperInitState -> String) -> NoThunks JumperInitState forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a $cnoThunks :: Context -> JumperInitState -> IO (Maybe ThunkInfo) noThunks :: Context -> JumperInitState -> IO (Maybe ThunkInfo) $cwNoThunks :: Context -> JumperInitState -> IO (Maybe ThunkInfo) wNoThunks :: Context -> JumperInitState -> IO (Maybe ThunkInfo) $cshowTypeOf :: Proxy JumperInitState -> String showTypeOf :: Proxy JumperInitState -> String NoThunks) -- | State of a peer with respect to ChainSync jumping. data ChainSyncJumpingState m blk = -- | The dynamo, of which there is exactly one unless there are no peers, -- runs the normal ChainSync protocol and is morally supposed to give us -- _the_ chain. This might not be true and the dynamo might be not be -- honest, but the goal of the algorithm is to eventually have an honest, -- alert peer as dynamo. Dynamo !(DynamoInitState blk) -- | The last slot at which we triggered jumps for the jumpers. !(WithOrigin SlotNo) | -- | The objector, of which there is at most one, also runs normal -- ChainSync. It is a former jumper that disagreed with the dynamo. When -- that happened, we spun it up to let normal ChainSync and Genesis decide -- which one to disconnect from. Objector !ObjectorInitState -- | The youngest point where the objector agrees with the dynamo. !(JumpInfo blk) -- | The point where the objector dissented with the dynamo when it was a -- jumper. !(Point (Header blk)) | -- | Headers continue to be downloaded from 'Disengaged' peers. They -- are not requested to jump, nor elected as dynamos or objectors. Disengaged DisengagedInitState | -- | The jumpers can be in arbitrary numbers. They are queried regularly to -- see if they agree with the chain that the dynamo is serving; otherwise, -- they become candidates to be the objector. See -- 'ChainSyncJumpingJumperState' for more details. Jumper -- | A TVar containing the next jump to be executed. !(StrictTVar m (Maybe (JumpInfo blk))) -- | More precisely, the state of the jumper. !(ChainSyncJumpingJumperState blk) deriving ((forall x. ChainSyncJumpingState m blk -> Rep (ChainSyncJumpingState m blk) x) -> (forall x. Rep (ChainSyncJumpingState m blk) x -> ChainSyncJumpingState m blk) -> Generic (ChainSyncJumpingState m blk) forall x. Rep (ChainSyncJumpingState m blk) x -> ChainSyncJumpingState m blk forall x. ChainSyncJumpingState m blk -> Rep (ChainSyncJumpingState m blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall (m :: * -> *) blk x. Rep (ChainSyncJumpingState m blk) x -> ChainSyncJumpingState m blk forall (m :: * -> *) blk x. ChainSyncJumpingState m blk -> Rep (ChainSyncJumpingState m blk) x $cfrom :: forall (m :: * -> *) blk x. ChainSyncJumpingState m blk -> Rep (ChainSyncJumpingState m blk) x from :: forall x. ChainSyncJumpingState m blk -> Rep (ChainSyncJumpingState m blk) x $cto :: forall (m :: * -> *) blk x. Rep (ChainSyncJumpingState m blk) x -> ChainSyncJumpingState m blk to :: forall x. Rep (ChainSyncJumpingState m blk) x -> ChainSyncJumpingState m blk Generic) deriving anyclass instance ( IOLike m, HasHeader blk, LedgerSupportsProtocol blk, NoThunks (Header blk) ) => NoThunks (ChainSyncJumpingState m blk) -- | The ChainSync state required for jumps -- -- The jump info is mostly a snapshot of the @KnownIntersectionState@ of the -- dynamo, with the difference that 'jTheirFragment' might be a proper prefix of -- the original candidate fragment. -- -- This can happen if we need to look for an intersection when the jumper -- rejects a jump. data JumpInfo blk = JumpInfo { forall blk. JumpInfo blk -> Point blk jMostRecentIntersection :: !(Point blk) , forall blk. JumpInfo blk -> AnchoredFragment (Header blk) jOurFragment :: !(AnchoredFragment (Header blk)) , forall blk. JumpInfo blk -> AnchoredFragment (Header blk) jTheirFragment :: !(AnchoredFragment (Header blk)) , forall blk. JumpInfo blk -> HeaderStateHistory blk jTheirHeaderStateHistory :: !(HeaderStateHistory blk) } deriving ((forall x. JumpInfo blk -> Rep (JumpInfo blk) x) -> (forall x. Rep (JumpInfo blk) x -> JumpInfo blk) -> Generic (JumpInfo blk) forall x. Rep (JumpInfo blk) x -> JumpInfo blk forall x. JumpInfo blk -> Rep (JumpInfo blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall blk x. Rep (JumpInfo blk) x -> JumpInfo blk forall blk x. JumpInfo blk -> Rep (JumpInfo blk) x $cfrom :: forall blk x. JumpInfo blk -> Rep (JumpInfo blk) x from :: forall x. JumpInfo blk -> Rep (JumpInfo blk) x $cto :: forall blk x. Rep (JumpInfo blk) x -> JumpInfo blk to :: forall x. Rep (JumpInfo blk) x -> JumpInfo blk Generic) instance (HasHeader (Header blk)) => Eq (JumpInfo blk) where == :: JumpInfo blk -> JumpInfo blk -> Bool (==) = Point (Header blk) -> Point (Header blk) -> Bool forall a. Eq a => a -> a -> Bool (==) (Point (Header blk) -> Point (Header blk) -> Bool) -> (JumpInfo blk -> Point (Header blk)) -> JumpInfo blk -> JumpInfo blk -> Bool forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c `on` AnchoredFragment (Header blk) -> Point (Header blk) forall block. HasHeader block => AnchoredFragment block -> Point block headPoint (AnchoredFragment (Header blk) -> Point (Header blk)) -> (JumpInfo blk -> AnchoredFragment (Header blk)) -> JumpInfo blk -> Point (Header blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . JumpInfo blk -> AnchoredFragment (Header blk) forall blk. JumpInfo blk -> AnchoredFragment (Header blk) jTheirFragment instance LedgerSupportsProtocol blk => NoThunks (JumpInfo blk) where showTypeOf :: Proxy (JumpInfo blk) -> String showTypeOf Proxy (JumpInfo blk) _ = TypeRep -> String forall a. Show a => a -> String show (TypeRep -> String) -> TypeRep -> String forall a b. (a -> b) -> a -> b $ Proxy (JumpInfo blk) -> TypeRep forall {k} (proxy :: k -> *) (a :: k). Typeable a => proxy a -> TypeRep typeRep (forall t. Proxy t forall {k} (t :: k). Proxy t Proxy @(JumpInfo blk)) -- | The specific state of a jumper peer. This state is to be understood as “to -- the best of our knowledge”, that is “last time we asked them”. For instance, -- a jumper might be marked as 'Happy' even though its chain has been differing -- from the dynamo's for hundreds of blocks, if we haven't asked them to jump -- since then. data ChainSyncJumpingJumperState blk = -- | The jumper is happy with the dynamo, and we hold the jump info of the -- last accepted jump. Happy JumperInitState !(Maybe (JumpInfo blk)) | -- | The jumper disagrees with the dynamo and we are searching where exactly -- that happens. All we know is a point where the jumper agrees with the -- dynamo and a point where the jumper disagrees with the dynamo, carried by -- this constructor. -- -- INVARIANT: The tip of the fragment in the good jump info (first argument) -- is in the fragment of the bad jump info or is an ancestor of it. LookingForIntersection !(JumpInfo blk) !(JumpInfo blk) | -- | The jumper disagrees with the dynamo and we have determined the latest -- point where dynamo and jumper agree. We store here the jump info of the -- latest accepted jump and the point of the earliest rejected jump. -- -- The init state indicates the initialization to use for the objector in -- case this jumper is promoted. FoundIntersection ObjectorInitState !(JumpInfo blk) !(Point (Header blk)) deriving ((forall x. ChainSyncJumpingJumperState blk -> Rep (ChainSyncJumpingJumperState blk) x) -> (forall x. Rep (ChainSyncJumpingJumperState blk) x -> ChainSyncJumpingJumperState blk) -> Generic (ChainSyncJumpingJumperState blk) forall x. Rep (ChainSyncJumpingJumperState blk) x -> ChainSyncJumpingJumperState blk forall x. ChainSyncJumpingJumperState blk -> Rep (ChainSyncJumpingJumperState blk) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a forall blk x. Rep (ChainSyncJumpingJumperState blk) x -> ChainSyncJumpingJumperState blk forall blk x. ChainSyncJumpingJumperState blk -> Rep (ChainSyncJumpingJumperState blk) x $cfrom :: forall blk x. ChainSyncJumpingJumperState blk -> Rep (ChainSyncJumpingJumperState blk) x from :: forall x. ChainSyncJumpingJumperState blk -> Rep (ChainSyncJumpingJumperState blk) x $cto :: forall blk x. Rep (ChainSyncJumpingJumperState blk) x -> ChainSyncJumpingJumperState blk to :: forall x. Rep (ChainSyncJumpingJumperState blk) x -> ChainSyncJumpingJumperState blk Generic) deriving anyclass instance ( HasHeader blk, LedgerSupportsProtocol blk, NoThunks (Header blk) ) => NoThunks (ChainSyncJumpingJumperState blk)