{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.MiniProtocol.BlockFetch.Server (
    blockFetchServer
    -- * Trace events
  , TraceBlockFetchServerEvent (..)
    -- * Exceptions
  , BlockFetchServerException
    -- * Low-level API
  , blockFetchServer'
  ) where

import           Control.ResourceRegistry (ResourceRegistry)
import           Control.Tracer (Tracer, traceWith)
import           Data.Typeable (Typeable)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Storage.ChainDB (ChainDB, Iterator,
                     IteratorResult (..), UnknownRange, WithPoint (..),
                     getSerialisedBlockWithPoint)
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Network.Block (Serialised (..))
import           Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion)
import           Ouroboros.Network.Protocol.BlockFetch.Server
                     (BlockFetchBlockSender (..), BlockFetchSendBlocks (..),
                     BlockFetchServer (..))
import           Ouroboros.Network.Protocol.BlockFetch.Type (ChainRange (..))

data BlockFetchServerException =
      -- | A block that was supposed to be included in a batch was garbage
      -- collected since we started the batch and can no longer be sent.
      --
      -- This will very rarely happen, only in the following scenario: when
      -- the batch started, the requested blocks were on the current chain,
      -- but then the current chain changed such that the requested blocks are
      -- now on a fork. If while requesting the blocks from the batch, there
      -- were a pause of /hours/ such that the fork gets older than @k@, then
      -- the next request after this long pause could result in this
      -- exception, as the block to stream from the old fork could have been
      -- garbage collected. However, the network protocol will have timed out
      -- long before this happens.
      forall blk. (Typeable blk, StandardHash blk) =>
        BlockGCed (RealPoint blk)

      -- | Thrown when requesting the genesis block from the database
      --
      -- Although the genesis block has a hash and a point associated with it,
      -- it does not actually exist other than as a concept; we cannot read and
      -- return it.
    | NoGenesisBlock

deriving instance Show BlockFetchServerException

instance Exception BlockFetchServerException

-- | Block fetch server based on
-- 'Ouroboros.Network.BlockFetch.Examples.mockBlockFetchServer1', but using
-- the 'ChainDB'.
blockFetchServer ::
       forall m blk.
       ( IOLike m
       , StandardHash blk
       , Typeable     blk
       )
    => Tracer m (TraceBlockFetchServerEvent blk)
    -> ChainDB m blk
    -> NodeToNodeVersion
    -> ResourceRegistry m
    -> BlockFetchServer (Serialised blk) (Point blk) m ()
blockFetchServer :: forall (m :: * -> *) blk.
(IOLike m, StandardHash blk, Typeable blk) =>
Tracer m (TraceBlockFetchServerEvent blk)
-> ChainDB m blk
-> NodeToNodeVersion
-> ResourceRegistry m
-> BlockFetchServer (Serialised blk) (Point blk) m ()
blockFetchServer Tracer m (TraceBlockFetchServerEvent blk)
tracer ChainDB m blk
chainDB NodeToNodeVersion
_version ResourceRegistry m
registry =
    Tracer m (TraceBlockFetchServerEvent blk)
-> (StreamFrom blk
    -> StreamTo blk
    -> m (Either
            (UnknownRange blk)
            (Iterator m blk (WithPoint blk (Serialised blk)))))
-> BlockFetchServer (Serialised blk) (Point blk) m ()
forall (m :: * -> *) blk a.
(IOLike m, StandardHash blk, Typeable blk) =>
Tracer m (TraceBlockFetchServerEvent blk)
-> (StreamFrom blk
    -> StreamTo blk
    -> m (Either
            (UnknownRange blk) (Iterator m blk (WithPoint blk a))))
-> BlockFetchServer a (Point blk) m ()
blockFetchServer' Tracer m (TraceBlockFetchServerEvent blk)
tracer ((StreamFrom blk
  -> StreamTo blk
  -> m (Either
          (UnknownRange blk)
          (Iterator m blk (WithPoint blk (Serialised blk)))))
 -> BlockFetchServer (Serialised blk) (Point blk) m ())
-> (StreamFrom blk
    -> StreamTo blk
    -> m (Either
            (UnknownRange blk)
            (Iterator m blk (WithPoint blk (Serialised blk)))))
-> BlockFetchServer (Serialised blk) (Point blk) m ()
forall a b. (a -> b) -> a -> b
$
      ChainDB m blk
-> forall b.
   ResourceRegistry m
   -> BlockComponent blk b
   -> StreamFrom blk
   -> StreamTo blk
   -> m (Either (UnknownRange blk) (Iterator m blk b))
forall (m :: * -> *) blk.
ChainDB m blk
-> forall b.
   ResourceRegistry m
   -> BlockComponent blk b
   -> StreamFrom blk
   -> StreamTo blk
   -> m (Either (UnknownRange blk) (Iterator m blk b))
ChainDB.stream ChainDB m blk
chainDB ResourceRegistry m
registry BlockComponent blk (WithPoint blk (Serialised blk))
forall blk. BlockComponent blk (WithPoint blk (Serialised blk))
getSerialisedBlockWithPoint

blockFetchServer'
    :: forall m blk a.
       ( IOLike m
       , StandardHash blk
       , Typeable     blk
       )
    => Tracer m (TraceBlockFetchServerEvent blk)
    -> (    ChainDB.StreamFrom blk -> ChainDB.StreamTo blk
         -> m (Either (UnknownRange blk) (Iterator m blk (WithPoint blk a)))
       )
    -> BlockFetchServer a (Point blk) m ()
blockFetchServer' :: forall (m :: * -> *) blk a.
(IOLike m, StandardHash blk, Typeable blk) =>
Tracer m (TraceBlockFetchServerEvent blk)
-> (StreamFrom blk
    -> StreamTo blk
    -> m (Either
            (UnknownRange blk) (Iterator m blk (WithPoint blk a))))
-> BlockFetchServer a (Point blk) m ()
blockFetchServer' Tracer m (TraceBlockFetchServerEvent blk)
tracer StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk (WithPoint blk a)))
stream = BlockFetchServer a (Point blk) m ()
senderSide
  where
    senderSide :: BlockFetchServer a (Point blk) m ()
    senderSide :: BlockFetchServer a (Point blk) m ()
senderSide = (ChainRange (Point blk)
 -> m (BlockFetchBlockSender a (Point blk) m ()))
-> () -> BlockFetchServer a (Point blk) m ()
forall point (m :: * -> *) block a.
(ChainRange point -> m (BlockFetchBlockSender block point m a))
-> a -> BlockFetchServer block point m a
BlockFetchServer ChainRange (Point blk)
-> m (BlockFetchBlockSender a (Point blk) m ())
receiveReq' ()

    receiveReq' :: ChainRange (Point blk)
                -> m (BlockFetchBlockSender a (Point blk) m ())
    receiveReq' :: ChainRange (Point blk)
-> m (BlockFetchBlockSender a (Point blk) m ())
receiveReq' (ChainRange Point blk
start Point blk
end) =
      case (Point blk
start, Point blk
end) of
        (BlockPoint SlotNo
s HeaderHash blk
h, BlockPoint SlotNo
s' HeaderHash blk
h') ->
          RealPoint blk
-> RealPoint blk -> m (BlockFetchBlockSender a (Point blk) m ())
receiveReq (SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s HeaderHash blk
h) (SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s' HeaderHash blk
h')
        (Point blk, Point blk)
_otherwise ->
          BlockFetchServerException
-> m (BlockFetchBlockSender a (Point blk) m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO BlockFetchServerException
NoGenesisBlock

    receiveReq :: RealPoint blk
               -> RealPoint blk
               -> m (BlockFetchBlockSender a (Point blk) m ())
    receiveReq :: RealPoint blk
-> RealPoint blk -> m (BlockFetchBlockSender a (Point blk) m ())
receiveReq RealPoint blk
start RealPoint blk
end = do
      Either (UnknownRange blk) (Iterator m blk (WithPoint blk a))
errIt <- StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk (WithPoint blk a)))
stream
        (RealPoint blk -> StreamFrom blk
forall blk. RealPoint blk -> StreamFrom blk
ChainDB.StreamFromInclusive RealPoint blk
start)
        (RealPoint blk -> StreamTo blk
forall blk. RealPoint blk -> StreamTo blk
ChainDB.StreamToInclusive   RealPoint blk
end)
      BlockFetchBlockSender a (Point blk) m ()
-> m (BlockFetchBlockSender a (Point blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockFetchBlockSender a (Point blk) m ()
 -> m (BlockFetchBlockSender a (Point blk) m ()))
-> BlockFetchBlockSender a (Point blk) m ()
-> m (BlockFetchBlockSender a (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ case Either (UnknownRange blk) (Iterator m blk (WithPoint blk a))
errIt of
        -- The range is not in the ChainDB or it forks off more than @k@
        -- blocks back.
        Left  UnknownRange blk
_  -> m (BlockFetchServer a (Point blk) m ())
-> BlockFetchBlockSender a (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchBlockSender block point m a
SendMsgNoBlocks (m (BlockFetchServer a (Point blk) m ())
 -> BlockFetchBlockSender a (Point blk) m ())
-> m (BlockFetchServer a (Point blk) m ())
-> BlockFetchBlockSender a (Point blk) m ()
forall a b. (a -> b) -> a -> b
$ BlockFetchServer a (Point blk) m ()
-> m (BlockFetchServer a (Point blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockFetchServer a (Point blk) m ()
senderSide
        -- When we got an iterator, it will stream at least one block since
        -- its bounds are inclusive, so we don't have to check whether the
        -- iterator is empty.
        Right Iterator m blk (WithPoint blk a)
it -> m (BlockFetchSendBlocks a (Point blk) m ())
-> BlockFetchBlockSender a (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchSendBlocks block point m a)
-> BlockFetchBlockSender block point m a
SendMsgStartBatch (m (BlockFetchSendBlocks a (Point blk) m ())
 -> BlockFetchBlockSender a (Point blk) m ())
-> m (BlockFetchSendBlocks a (Point blk) m ())
-> BlockFetchBlockSender a (Point blk) m ()
forall a b. (a -> b) -> a -> b
$ Iterator m blk (WithPoint blk a)
-> m (BlockFetchSendBlocks a (Point blk) m ())
sendBlocks Iterator m blk (WithPoint blk a)
it

    sendBlocks :: ChainDB.Iterator m blk (WithPoint blk a)
               -> m (BlockFetchSendBlocks a (Point blk) m ())
    sendBlocks :: Iterator m blk (WithPoint blk a)
-> m (BlockFetchSendBlocks a (Point blk) m ())
sendBlocks Iterator m blk (WithPoint blk a)
it = do
      IteratorResult blk (WithPoint blk a)
next <- Iterator m blk (WithPoint blk a)
-> m (IteratorResult blk (WithPoint blk a))
forall (m :: * -> *) blk b.
Iterator m blk b -> m (IteratorResult blk b)
ChainDB.iteratorNext Iterator m blk (WithPoint blk a)
it
      case IteratorResult blk (WithPoint blk a)
next of
        IteratorResult WithPoint blk a
blk     -> do
          Tracer m (TraceBlockFetchServerEvent blk)
-> TraceBlockFetchServerEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceBlockFetchServerEvent blk)
tracer (TraceBlockFetchServerEvent blk -> m ())
-> TraceBlockFetchServerEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ Point blk -> TraceBlockFetchServerEvent blk
forall blk. Point blk -> TraceBlockFetchServerEvent blk
TraceBlockFetchServerSendBlock (Point blk -> TraceBlockFetchServerEvent blk)
-> Point blk -> TraceBlockFetchServerEvent blk
forall a b. (a -> b) -> a -> b
$ WithPoint blk a -> Point blk
forall blk b. WithPoint blk b -> Point blk
point WithPoint blk a
blk
          BlockFetchSendBlocks a (Point blk) m ()
-> m (BlockFetchSendBlocks a (Point blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockFetchSendBlocks a (Point blk) m ()
 -> m (BlockFetchSendBlocks a (Point blk) m ()))
-> BlockFetchSendBlocks a (Point blk) m ()
-> m (BlockFetchSendBlocks a (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ a
-> m (BlockFetchSendBlocks a (Point blk) m ())
-> BlockFetchSendBlocks a (Point blk) m ()
forall block (m :: * -> *) point a.
block
-> m (BlockFetchSendBlocks block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBlock (WithPoint blk a -> a
forall blk b. WithPoint blk b -> b
withoutPoint WithPoint blk a
blk) (Iterator m blk (WithPoint blk a)
-> m (BlockFetchSendBlocks a (Point blk) m ())
sendBlocks Iterator m blk (WithPoint blk a)
it)
        IteratorResult blk (WithPoint blk a)
IteratorExhausted      -> do
          Iterator m blk (WithPoint blk a) -> m ()
forall (m :: * -> *) blk b. Iterator m blk b -> m ()
ChainDB.iteratorClose Iterator m blk (WithPoint blk a)
it
          BlockFetchSendBlocks a (Point blk) m ()
-> m (BlockFetchSendBlocks a (Point blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockFetchSendBlocks a (Point blk) m ()
 -> m (BlockFetchSendBlocks a (Point blk) m ()))
-> BlockFetchSendBlocks a (Point blk) m ()
-> m (BlockFetchSendBlocks a (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ m (BlockFetchServer a (Point blk) m ())
-> BlockFetchSendBlocks a (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBatchDone (m (BlockFetchServer a (Point blk) m ())
 -> BlockFetchSendBlocks a (Point blk) m ())
-> m (BlockFetchServer a (Point blk) m ())
-> BlockFetchSendBlocks a (Point blk) m ()
forall a b. (a -> b) -> a -> b
$ BlockFetchServer a (Point blk) m ()
-> m (BlockFetchServer a (Point blk) m ())
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockFetchServer a (Point blk) m ()
senderSide
        IteratorBlockGCed RealPoint blk
pt -> do
          Iterator m blk (WithPoint blk a) -> m ()
forall (m :: * -> *) blk b. Iterator m blk b -> m ()
ChainDB.iteratorClose Iterator m blk (WithPoint blk a)
it
          BlockFetchServerException
-> m (BlockFetchSendBlocks a (Point blk) m ())
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (BlockFetchServerException
 -> m (BlockFetchSendBlocks a (Point blk) m ()))
-> BlockFetchServerException
-> m (BlockFetchSendBlocks a (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ forall blk.
(Typeable blk, StandardHash blk) =>
RealPoint blk -> BlockFetchServerException
BlockGCed @blk RealPoint blk
pt


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

-- | Events traced by the Block Fetch Server.
data TraceBlockFetchServerEvent blk =
    -- | The server sent a block to the peer.
    -- This traces the start, not the end, of block sending.
    --
    TraceBlockFetchServerSendBlock !(Point blk)
  deriving (TraceBlockFetchServerEvent blk
-> TraceBlockFetchServerEvent blk -> Bool
(TraceBlockFetchServerEvent blk
 -> TraceBlockFetchServerEvent blk -> Bool)
-> (TraceBlockFetchServerEvent blk
    -> TraceBlockFetchServerEvent blk -> Bool)
-> Eq (TraceBlockFetchServerEvent blk)
forall blk.
StandardHash blk =>
TraceBlockFetchServerEvent blk
-> TraceBlockFetchServerEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
TraceBlockFetchServerEvent blk
-> TraceBlockFetchServerEvent blk -> Bool
== :: TraceBlockFetchServerEvent blk
-> TraceBlockFetchServerEvent blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
TraceBlockFetchServerEvent blk
-> TraceBlockFetchServerEvent blk -> Bool
/= :: TraceBlockFetchServerEvent blk
-> TraceBlockFetchServerEvent blk -> Bool
Eq, Int -> TraceBlockFetchServerEvent blk -> ShowS
[TraceBlockFetchServerEvent blk] -> ShowS
TraceBlockFetchServerEvent blk -> String
(Int -> TraceBlockFetchServerEvent blk -> ShowS)
-> (TraceBlockFetchServerEvent blk -> String)
-> ([TraceBlockFetchServerEvent blk] -> ShowS)
-> Show (TraceBlockFetchServerEvent blk)
forall blk.
StandardHash blk =>
Int -> TraceBlockFetchServerEvent blk -> ShowS
forall blk.
StandardHash blk =>
[TraceBlockFetchServerEvent blk] -> ShowS
forall blk.
StandardHash blk =>
TraceBlockFetchServerEvent blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> TraceBlockFetchServerEvent blk -> ShowS
showsPrec :: Int -> TraceBlockFetchServerEvent blk -> ShowS
$cshow :: forall blk.
StandardHash blk =>
TraceBlockFetchServerEvent blk -> String
show :: TraceBlockFetchServerEvent blk -> String
$cshowList :: forall blk.
StandardHash blk =>
[TraceBlockFetchServerEvent blk] -> ShowS
showList :: [TraceBlockFetchServerEvent blk] -> ShowS
Show)