{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}

module Ouroboros.Consensus.MiniProtocol.ChainSync.Server (
    Tip
  , chainSyncBlockServerFollower
  , chainSyncBlocksServer
  , chainSyncHeaderServerFollower
  , chainSyncHeadersServer
    -- * Trace events
  , BlockingType (..)
  , TraceChainSyncServerEvent (..)
  ) where

import           Control.Tracer

import           Ouroboros.Network.Block (ChainUpdate (..), Serialised,
                     Tip (..))
import           Ouroboros.Network.Protocol.ChainSync.Server

import           Ouroboros.Consensus.Storage.ChainDB.API (ChainDB, Follower,
                     WithPoint (..), getSerialisedBlockWithPoint,
                     getSerialisedHeaderWithPoint)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import           Ouroboros.Consensus.Storage.Serialisation

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util.Enclose (Enclosing, Enclosing' (..),
                     pattern FallingEdge)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)


chainSyncHeaderServerFollower
    :: ChainDB m blk
    -> ChainDB.ChainType
    -> ResourceRegistry m
    -> m (Follower m blk (WithPoint blk (SerialisedHeader blk)))
chainSyncHeaderServerFollower :: ChainDB m blk
-> ChainType
-> ResourceRegistry m
-> m (Follower m blk (WithPoint blk (SerialisedHeader blk)))
chainSyncHeaderServerFollower ChainDB m blk
chainDB ChainType
chainType ResourceRegistry m
registry =
  ChainDB m blk
-> ResourceRegistry m
-> ChainType
-> BlockComponent blk (WithPoint blk (SerialisedHeader blk))
-> m (Follower m blk (WithPoint blk (SerialisedHeader blk)))
forall (m :: * -> *) blk.
ChainDB m blk
-> forall b.
   ResourceRegistry m
   -> ChainType -> BlockComponent blk b -> m (Follower m blk b)
ChainDB.newFollower ChainDB m blk
chainDB ResourceRegistry m
registry ChainType
chainType BlockComponent blk (WithPoint blk (SerialisedHeader blk))
forall blk.
BlockComponent blk (WithPoint blk (SerialisedHeader blk))
getSerialisedHeaderWithPoint

chainSyncBlockServerFollower
    :: ChainDB m blk
    -> ResourceRegistry m
    -> m (Follower m blk (WithPoint blk (Serialised blk)))
chainSyncBlockServerFollower :: ChainDB m blk
-> ResourceRegistry m
-> m (Follower m blk (WithPoint blk (Serialised blk)))
chainSyncBlockServerFollower ChainDB m blk
chainDB ResourceRegistry m
registry =
  ChainDB m blk
-> ResourceRegistry m
-> ChainType
-> BlockComponent blk (WithPoint blk (Serialised blk))
-> m (Follower m blk (WithPoint blk (Serialised blk)))
forall (m :: * -> *) blk.
ChainDB m blk
-> forall b.
   ResourceRegistry m
   -> ChainType -> BlockComponent blk b -> m (Follower m blk b)
ChainDB.newFollower ChainDB m blk
chainDB ResourceRegistry m
registry ChainType
ChainDB.SelectedChain BlockComponent blk (WithPoint blk (Serialised blk))
forall blk. BlockComponent blk (WithPoint blk (Serialised blk))
getSerialisedBlockWithPoint

-- | Chain Sync Server for block headers for a given a 'ChainDB'.
--
-- The node-to-node protocol uses the chain sync mini-protocol with chain
-- headers (and fetches blocks separately with the block fetch mini-protocol).
--
chainSyncHeadersServer
    :: forall m blk.
       ( IOLike m
       , HasHeader (Header blk)
       )
    => Tracer m (TraceChainSyncServerEvent blk)
    -> ChainDB m blk
    -> Follower m blk (WithPoint blk (SerialisedHeader blk))
    -> ChainSyncServer (SerialisedHeader blk) (Point blk) (Tip blk) m ()
chainSyncHeadersServer :: Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk (SerialisedHeader blk))
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
chainSyncHeadersServer Tracer m (TraceChainSyncServerEvent blk)
tracer ChainDB m blk
chainDB Follower m blk (WithPoint blk (SerialisedHeader blk))
flr =
    Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk (SerialisedHeader blk))
-> ChainSyncServer
     (SerialisedHeader blk) (Point blk) (Tip blk) m ()
forall (m :: * -> *) blk b.
(IOLike m, HasHeader (Header blk)) =>
Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk b)
-> ChainSyncServer b (Point blk) (Tip blk) m ()
chainSyncServerForFollower Tracer m (TraceChainSyncServerEvent blk)
tracer ChainDB m blk
chainDB Follower m blk (WithPoint blk (SerialisedHeader blk))
flr

-- | Chain Sync Server for blocks for a given a 'ChainDB'.
--
-- The local node-to-client protocol uses the chain sync mini-protocol with
-- chains of full blocks (rather than a header \/ body split).
--
chainSyncBlocksServer
    :: forall m blk. (IOLike m, HasHeader (Header blk))
    => Tracer m (TraceChainSyncServerEvent blk)
    -> ChainDB m blk
    -> Follower m blk (WithPoint blk (Serialised blk))
    -> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
chainSyncBlocksServer :: Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
chainSyncBlocksServer Tracer m (TraceChainSyncServerEvent blk)
tracer ChainDB m blk
chainDB Follower m blk (WithPoint blk (Serialised blk))
flr =
    Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk (Serialised blk))
-> ChainSyncServer (Serialised blk) (Point blk) (Tip blk) m ()
forall (m :: * -> *) blk b.
(IOLike m, HasHeader (Header blk)) =>
Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk b)
-> ChainSyncServer b (Point blk) (Tip blk) m ()
chainSyncServerForFollower Tracer m (TraceChainSyncServerEvent blk)
tracer ChainDB m blk
chainDB Follower m blk (WithPoint blk (Serialised blk))
flr

-- | A chain sync server.
--
-- This is a version of
-- 'Ouroboros.Network.Protocol.ChainSync.Examples.chainSyncServerExample' that
-- uses a 'chainDB' and a 'Follower' instead of
-- 'Ourboros.Network.ChainProducerState.ChainProducerState'.
--
-- All the hard work is done by the 'Follower's provided by the 'ChainDB'.
--
chainSyncServerForFollower ::
     forall m blk b.
     ( IOLike m
     , HasHeader (Header blk)
     )
  => Tracer m (TraceChainSyncServerEvent blk)
  -> ChainDB m blk
  -> Follower  m blk (WithPoint blk b)
  -> ChainSyncServer b (Point blk) (Tip blk) m ()
chainSyncServerForFollower :: Tracer m (TraceChainSyncServerEvent blk)
-> ChainDB m blk
-> Follower m blk (WithPoint blk b)
-> ChainSyncServer b (Point blk) (Tip blk) m ()
chainSyncServerForFollower Tracer m (TraceChainSyncServerEvent blk)
tracer ChainDB m blk
chainDB Follower m blk (WithPoint blk b)
flr =
    ChainSyncServer b (Point blk) (Tip blk) m ()
idle'
  where
    idle :: ServerStIdle b (Point blk) (Tip blk) m ()
    idle :: ServerStIdle b (Point blk) (Tip blk) m ()
idle = ServerStIdle :: forall header point tip (m :: * -> *) a.
m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
-> ([point] -> m (ServerStIntersect header point tip m a))
-> m a
-> ServerStIdle header point tip m a
ServerStIdle {
        recvMsgRequestNext :: m (Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ())))
recvMsgRequestNext   = m (Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ())))
handleRequestNext,
        recvMsgFindIntersect :: [Point blk] -> m (ServerStIntersect b (Point blk) (Tip blk) m ())
recvMsgFindIntersect = [Point blk] -> m (ServerStIntersect b (Point blk) (Tip blk) m ())
handleFindIntersect,
        recvMsgDoneClient :: m ()
recvMsgDoneClient    = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      }

    idle' :: ChainSyncServer b (Point blk) (Tip blk) m ()
    idle' :: ChainSyncServer b (Point blk) (Tip blk) m ()
idle' = m (ServerStIdle b (Point blk) (Tip blk) m ())
-> ChainSyncServer b (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (m (ServerStIdle b (Point blk) (Tip blk) m ())
 -> ChainSyncServer b (Point blk) (Tip blk) m ())
-> m (ServerStIdle b (Point blk) (Tip blk) m ())
-> ChainSyncServer b (Point blk) (Tip blk) m ()
forall a b. (a -> b) -> a -> b
$ ServerStIdle b (Point blk) (Tip blk) m ()
-> m (ServerStIdle b (Point blk) (Tip blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ServerStIdle b (Point blk) (Tip blk) m ()
idle

    handleRequestNext :: m (Either (ServerStNext b (Point blk) (Tip blk) m ())
                                (m (ServerStNext b (Point blk) (Tip blk) m ())))
    handleRequestNext :: m (Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ())))
handleRequestNext = Follower m blk (WithPoint blk b)
-> m (Maybe (ChainUpdate blk (WithPoint blk b)))
forall (m :: * -> *) blk a.
Follower m blk a -> m (Maybe (ChainUpdate blk a))
ChainDB.followerInstruction Follower m blk (WithPoint blk b)
flr m (Maybe (ChainUpdate blk (WithPoint blk b)))
-> (Maybe (ChainUpdate blk (WithPoint blk b))
    -> m (Either
            (ServerStNext b (Point blk) (Tip blk) m ())
            (m (ServerStNext b (Point blk) (Tip blk) m ()))))
-> m (Either
        (ServerStNext b (Point blk) (Tip blk) m ())
        (m (ServerStNext b (Point blk) (Tip blk) m ())))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just ChainUpdate blk (WithPoint blk b)
update -> do
        Tip blk
tip <- STM m (Tip blk) -> m (Tip blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Tip blk) -> m (Tip blk)) -> STM m (Tip blk) -> m (Tip blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> STM m (Tip blk)
forall (m :: * -> *) blk.
(Monad (STM m), HasHeader (Header blk)) =>
ChainDB m blk -> STM m (Tip blk)
ChainDB.getCurrentTip ChainDB m blk
chainDB
        let mkTraceEvent :: Enclosing -> TraceChainSyncServerEvent blk
mkTraceEvent =
              Tip blk
-> ChainUpdate blk (Point blk)
-> BlockingType
-> Enclosing
-> TraceChainSyncServerEvent blk
forall blk.
Tip blk
-> ChainUpdate blk (Point blk)
-> BlockingType
-> Enclosing
-> TraceChainSyncServerEvent blk
TraceChainSyncServerUpdate Tip blk
tip (WithPoint blk b -> Point blk
forall blk b. WithPoint blk b -> Point blk
point (WithPoint blk b -> Point blk)
-> ChainUpdate blk (WithPoint blk b) -> ChainUpdate blk (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainUpdate blk (WithPoint blk b)
update) BlockingType
NonBlocking
        Tracer m (TraceChainSyncServerEvent blk)
-> TraceChainSyncServerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncServerEvent blk)
tracer (TraceChainSyncServerEvent blk -> m ())
-> TraceChainSyncServerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Enclosing -> TraceChainSyncServerEvent blk
mkTraceEvent Enclosing
forall a. Enclosing' a
RisingEdge
        Either
  (ServerStNext b (Point blk) (Tip blk) m ())
  (m (ServerStNext b (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext b (Point blk) (Tip blk) m ())
        (m (ServerStNext b (Point blk) (Tip blk) m ())))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (ServerStNext b (Point blk) (Tip blk) m ())
   (m (ServerStNext b (Point blk) (Tip blk) m ()))
 -> m (Either
         (ServerStNext b (Point blk) (Tip blk) m ())
         (m (ServerStNext b (Point blk) (Tip blk) m ()))))
-> Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext b (Point blk) (Tip blk) m ())
        (m (ServerStNext b (Point blk) (Tip blk) m ())))
forall a b. (a -> b) -> a -> b
$ ServerStNext b (Point blk) (Tip blk) m ()
-> Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ()))
forall a b. a -> Either a b
Left (ServerStNext b (Point blk) (Tip blk) m ()
 -> Either
      (ServerStNext b (Point blk) (Tip blk) m ())
      (m (ServerStNext b (Point blk) (Tip blk) m ())))
-> ServerStNext b (Point blk) (Tip blk) m ()
-> Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ()))
forall a b. (a -> b) -> a -> b
$ (Enclosing -> TraceChainSyncServerEvent blk)
-> Tip blk
-> ChainUpdate blk (WithPoint blk b)
-> ServerStNext b (Point blk) (Tip blk) m ()
sendNext Enclosing -> TraceChainSyncServerEvent blk
mkTraceEvent Tip blk
tip ChainUpdate blk (WithPoint blk b)
update
      Maybe (ChainUpdate blk (WithPoint blk b))
Nothing     -> Either
  (ServerStNext b (Point blk) (Tip blk) m ())
  (m (ServerStNext b (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext b (Point blk) (Tip blk) m ())
        (m (ServerStNext b (Point blk) (Tip blk) m ())))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (ServerStNext b (Point blk) (Tip blk) m ())
   (m (ServerStNext b (Point blk) (Tip blk) m ()))
 -> m (Either
         (ServerStNext b (Point blk) (Tip blk) m ())
         (m (ServerStNext b (Point blk) (Tip blk) m ()))))
-> Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ()))
-> m (Either
        (ServerStNext b (Point blk) (Tip blk) m ())
        (m (ServerStNext b (Point blk) (Tip blk) m ())))
forall a b. (a -> b) -> a -> b
$ m (ServerStNext b (Point blk) (Tip blk) m ())
-> Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ()))
forall a b. b -> Either a b
Right (m (ServerStNext b (Point blk) (Tip blk) m ())
 -> Either
      (ServerStNext b (Point blk) (Tip blk) m ())
      (m (ServerStNext b (Point blk) (Tip blk) m ())))
-> m (ServerStNext b (Point blk) (Tip blk) m ())
-> Either
     (ServerStNext b (Point blk) (Tip blk) m ())
     (m (ServerStNext b (Point blk) (Tip blk) m ()))
forall a b. (a -> b) -> a -> b
$ do
        -- Follower is at the head, we have to block and wait for the chain to
        -- change.
        ChainUpdate blk (WithPoint blk b)
update <- Follower m blk (WithPoint blk b)
-> m (ChainUpdate blk (WithPoint blk b))
forall (m :: * -> *) blk a.
Follower m blk a -> m (ChainUpdate blk a)
ChainDB.followerInstructionBlocking Follower m blk (WithPoint blk b)
flr
        Tip blk
tip    <- STM m (Tip blk) -> m (Tip blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Tip blk) -> m (Tip blk)) -> STM m (Tip blk) -> m (Tip blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> STM m (Tip blk)
forall (m :: * -> *) blk.
(Monad (STM m), HasHeader (Header blk)) =>
ChainDB m blk -> STM m (Tip blk)
ChainDB.getCurrentTip ChainDB m blk
chainDB
        let mkTraceEvent :: Enclosing -> TraceChainSyncServerEvent blk
mkTraceEvent =
              Tip blk
-> ChainUpdate blk (Point blk)
-> BlockingType
-> Enclosing
-> TraceChainSyncServerEvent blk
forall blk.
Tip blk
-> ChainUpdate blk (Point blk)
-> BlockingType
-> Enclosing
-> TraceChainSyncServerEvent blk
TraceChainSyncServerUpdate Tip blk
tip (WithPoint blk b -> Point blk
forall blk b. WithPoint blk b -> Point blk
point (WithPoint blk b -> Point blk)
-> ChainUpdate blk (WithPoint blk b) -> ChainUpdate blk (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainUpdate blk (WithPoint blk b)
update) BlockingType
Blocking
        Tracer m (TraceChainSyncServerEvent blk)
-> TraceChainSyncServerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncServerEvent blk)
tracer (TraceChainSyncServerEvent blk -> m ())
-> TraceChainSyncServerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Enclosing -> TraceChainSyncServerEvent blk
mkTraceEvent Enclosing
forall a. Enclosing' a
RisingEdge
        ServerStNext b (Point blk) (Tip blk) m ()
-> m (ServerStNext b (Point blk) (Tip blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerStNext b (Point blk) (Tip blk) m ()
 -> m (ServerStNext b (Point blk) (Tip blk) m ()))
-> ServerStNext b (Point blk) (Tip blk) m ()
-> m (ServerStNext b (Point blk) (Tip blk) m ())
forall a b. (a -> b) -> a -> b
$ (Enclosing -> TraceChainSyncServerEvent blk)
-> Tip blk
-> ChainUpdate blk (WithPoint blk b)
-> ServerStNext b (Point blk) (Tip blk) m ()
sendNext Enclosing -> TraceChainSyncServerEvent blk
mkTraceEvent Tip blk
tip ChainUpdate blk (WithPoint blk b)
update

    sendNext :: (Enclosing -> TraceChainSyncServerEvent blk)
             -> Tip blk
             -> ChainUpdate blk (WithPoint blk b)
             -> ServerStNext b (Point blk) (Tip blk) m ()
    sendNext :: (Enclosing -> TraceChainSyncServerEvent blk)
-> Tip blk
-> ChainUpdate blk (WithPoint blk b)
-> ServerStNext b (Point blk) (Tip blk) m ()
sendNext Enclosing -> TraceChainSyncServerEvent blk
mkTraceEvent Tip blk
tip = \case
        AddBlock WithPoint blk b
hdr -> b
-> Tip blk
-> ChainSyncServer b (Point blk) (Tip blk) m ()
-> ServerStNext b (Point blk) (Tip blk) m ()
forall header tip point (m :: * -> *) a.
header
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollForward (WithPoint blk b -> b
forall blk b. WithPoint blk b -> b
withoutPoint WithPoint blk b
hdr) Tip blk
tip ChainSyncServer b (Point blk) (Tip blk) m ()
traceThenIdle
        RollBack Point blk
pt  -> Point blk
-> Tip blk
-> ChainSyncServer b (Point blk) (Tip blk) m ()
-> ServerStNext b (Point blk) (Tip blk) m ()
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStNext header point tip m a
SendMsgRollBackward Point blk
pt Tip blk
tip ChainSyncServer b (Point blk) (Tip blk) m ()
traceThenIdle
      where
        traceThenIdle :: ChainSyncServer b (Point blk) (Tip blk) m ()
traceThenIdle = m (ServerStIdle b (Point blk) (Tip blk) m ())
-> ChainSyncServer b (Point blk) (Tip blk) m ()
forall header point tip (m :: * -> *) a.
m (ServerStIdle header point tip m a)
-> ChainSyncServer header point tip m a
ChainSyncServer (m (ServerStIdle b (Point blk) (Tip blk) m ())
 -> ChainSyncServer b (Point blk) (Tip blk) m ())
-> m (ServerStIdle b (Point blk) (Tip blk) m ())
-> ChainSyncServer b (Point blk) (Tip blk) m ()
forall a b. (a -> b) -> a -> b
$ do
          Tracer m (TraceChainSyncServerEvent blk)
-> TraceChainSyncServerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceChainSyncServerEvent blk)
tracer (TraceChainSyncServerEvent blk -> m ())
-> TraceChainSyncServerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Enclosing -> TraceChainSyncServerEvent blk
mkTraceEvent Enclosing
FallingEdge
          ServerStIdle b (Point blk) (Tip blk) m ()
-> m (ServerStIdle b (Point blk) (Tip blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return ServerStIdle b (Point blk) (Tip blk) m ()
idle

    handleFindIntersect :: [Point blk]
                        -> m (ServerStIntersect b (Point blk) (Tip blk) m ())
    handleFindIntersect :: [Point blk] -> m (ServerStIntersect b (Point blk) (Tip blk) m ())
handleFindIntersect [Point blk]
points = do
      -- TODO guard number of points
      Maybe (Point blk)
changed <- Follower m blk (WithPoint blk b)
-> [Point blk] -> m (Maybe (Point blk))
forall (m :: * -> *) blk a.
Follower m blk a -> [Point blk] -> m (Maybe (Point blk))
ChainDB.followerForward Follower m blk (WithPoint blk b)
flr [Point blk]
points
      Tip blk
tip     <- STM m (Tip blk) -> m (Tip blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Tip blk) -> m (Tip blk)) -> STM m (Tip blk) -> m (Tip blk)
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> STM m (Tip blk)
forall (m :: * -> *) blk.
(Monad (STM m), HasHeader (Header blk)) =>
ChainDB m blk -> STM m (Tip blk)
ChainDB.getCurrentTip ChainDB m blk
chainDB
      case Maybe (Point blk)
changed of
        Just Point blk
pt -> ServerStIntersect b (Point blk) (Tip blk) m ()
-> m (ServerStIntersect b (Point blk) (Tip blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerStIntersect b (Point blk) (Tip blk) m ()
 -> m (ServerStIntersect b (Point blk) (Tip blk) m ()))
-> ServerStIntersect b (Point blk) (Tip blk) m ()
-> m (ServerStIntersect b (Point blk) (Tip blk) m ())
forall a b. (a -> b) -> a -> b
$ Point blk
-> Tip blk
-> ChainSyncServer b (Point blk) (Tip blk) m ()
-> ServerStIntersect b (Point blk) (Tip blk) m ()
forall point tip header (m :: * -> *) a.
point
-> tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectFound Point blk
pt Tip blk
tip ChainSyncServer b (Point blk) (Tip blk) m ()
idle'
        Maybe (Point blk)
Nothing -> ServerStIntersect b (Point blk) (Tip blk) m ()
-> m (ServerStIntersect b (Point blk) (Tip blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerStIntersect b (Point blk) (Tip blk) m ()
 -> m (ServerStIntersect b (Point blk) (Tip blk) m ()))
-> ServerStIntersect b (Point blk) (Tip blk) m ()
-> m (ServerStIntersect b (Point blk) (Tip blk) m ())
forall a b. (a -> b) -> a -> b
$ Tip blk
-> ChainSyncServer b (Point blk) (Tip blk) m ()
-> ServerStIntersect b (Point blk) (Tip blk) m ()
forall tip header point (m :: * -> *) a.
tip
-> ChainSyncServer header point tip m a
-> ServerStIntersect header point tip m a
SendMsgIntersectNotFound Tip blk
tip ChainSyncServer b (Point blk) (Tip blk) m ()
idle'

{-------------------------------------------------------------------------------
  Trace events
-------------------------------------------------------------------------------}

-- | Events traced by the Chain Sync Server.
data TraceChainSyncServerEvent blk =
    -- | Send a 'ChainUpdate' message.
    TraceChainSyncServerUpdate
      (Tip blk)
      -- ^ Tip of the currently selected chain.
      (ChainUpdate blk (Point blk))
      -- ^ The whole headers/blocks in the traced 'ChainUpdate' are substituted
      -- with their corresponding 'Point'.
      BlockingType
      Enclosing
  deriving (TraceChainSyncServerEvent blk
-> TraceChainSyncServerEvent blk -> Bool
(TraceChainSyncServerEvent blk
 -> TraceChainSyncServerEvent blk -> Bool)
-> (TraceChainSyncServerEvent blk
    -> TraceChainSyncServerEvent blk -> Bool)
-> Eq (TraceChainSyncServerEvent blk)
forall blk.
StandardHash blk =>
TraceChainSyncServerEvent blk
-> TraceChainSyncServerEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TraceChainSyncServerEvent blk
-> TraceChainSyncServerEvent blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
TraceChainSyncServerEvent blk
-> TraceChainSyncServerEvent blk -> Bool
== :: TraceChainSyncServerEvent blk
-> TraceChainSyncServerEvent blk -> Bool
$c== :: forall blk.
StandardHash blk =>
TraceChainSyncServerEvent blk
-> TraceChainSyncServerEvent blk -> Bool
Eq, Int -> TraceChainSyncServerEvent blk -> ShowS
[TraceChainSyncServerEvent blk] -> ShowS
TraceChainSyncServerEvent blk -> String
(Int -> TraceChainSyncServerEvent blk -> ShowS)
-> (TraceChainSyncServerEvent blk -> String)
-> ([TraceChainSyncServerEvent blk] -> ShowS)
-> Show (TraceChainSyncServerEvent blk)
forall blk.
StandardHash blk =>
Int -> TraceChainSyncServerEvent blk -> ShowS
forall blk.
StandardHash blk =>
[TraceChainSyncServerEvent blk] -> ShowS
forall blk.
StandardHash blk =>
TraceChainSyncServerEvent blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TraceChainSyncServerEvent blk] -> ShowS
$cshowList :: forall blk.
StandardHash blk =>
[TraceChainSyncServerEvent blk] -> ShowS
show :: TraceChainSyncServerEvent blk -> String
$cshow :: forall blk.
StandardHash blk =>
TraceChainSyncServerEvent blk -> String
showsPrec :: Int -> TraceChainSyncServerEvent blk -> ShowS
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> TraceChainSyncServerEvent blk -> ShowS
Show)

-- | Whether reading a ChainSync server update instruction was blocking or
-- non-blocking.
data BlockingType = Blocking | NonBlocking
  deriving (BlockingType -> BlockingType -> Bool
(BlockingType -> BlockingType -> Bool)
-> (BlockingType -> BlockingType -> Bool) -> Eq BlockingType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockingType -> BlockingType -> Bool
$c/= :: BlockingType -> BlockingType -> Bool
== :: BlockingType -> BlockingType -> Bool
$c== :: BlockingType -> BlockingType -> Bool
Eq, Eq BlockingType
Eq BlockingType
-> (BlockingType -> BlockingType -> Ordering)
-> (BlockingType -> BlockingType -> Bool)
-> (BlockingType -> BlockingType -> Bool)
-> (BlockingType -> BlockingType -> Bool)
-> (BlockingType -> BlockingType -> Bool)
-> (BlockingType -> BlockingType -> BlockingType)
-> (BlockingType -> BlockingType -> BlockingType)
-> Ord BlockingType
BlockingType -> BlockingType -> Bool
BlockingType -> BlockingType -> Ordering
BlockingType -> BlockingType -> BlockingType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockingType -> BlockingType -> BlockingType
$cmin :: BlockingType -> BlockingType -> BlockingType
max :: BlockingType -> BlockingType -> BlockingType
$cmax :: BlockingType -> BlockingType -> BlockingType
>= :: BlockingType -> BlockingType -> Bool
$c>= :: BlockingType -> BlockingType -> Bool
> :: BlockingType -> BlockingType -> Bool
$c> :: BlockingType -> BlockingType -> Bool
<= :: BlockingType -> BlockingType -> Bool
$c<= :: BlockingType -> BlockingType -> Bool
< :: BlockingType -> BlockingType -> Bool
$c< :: BlockingType -> BlockingType -> Bool
compare :: BlockingType -> BlockingType -> Ordering
$ccompare :: BlockingType -> BlockingType -> Ordering
$cp1Ord :: Eq BlockingType
Ord, Int -> BlockingType -> ShowS
[BlockingType] -> ShowS
BlockingType -> String
(Int -> BlockingType -> ShowS)
-> (BlockingType -> String)
-> ([BlockingType] -> ShowS)
-> Show BlockingType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockingType] -> ShowS
$cshowList :: [BlockingType] -> ShowS
show :: BlockingType -> String
$cshow :: BlockingType -> String
showsPrec :: Int -> BlockingType -> ShowS
$cshowsPrec :: Int -> BlockingType -> ShowS
Show)