{-# 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
  ) where

import           Control.Tracer (Tracer, traceWith)
import           Data.Typeable (Typeable)

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 (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry)

import           Ouroboros.Consensus.Storage.ChainDB (ChainDB,
                     IteratorResult (..), WithPoint (..),
                     getSerialisedBlockWithPoint)
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB

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 :: 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 = BlockFetchServer (Serialised blk) (Point blk) m ()
senderSide
  where
    senderSide :: BlockFetchServer (Serialised blk) (Point blk) m ()
    senderSide :: BlockFetchServer (Serialised blk) (Point blk) m ()
senderSide = (ChainRange (Point blk)
 -> m (BlockFetchBlockSender (Serialised blk) (Point blk) m ()))
-> () -> BlockFetchServer (Serialised blk) (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 (Serialised blk) (Point blk) m ())
receiveReq' ()

    receiveReq' :: ChainRange (Point blk)
                -> m (BlockFetchBlockSender (Serialised blk) (Point blk) m ())
    receiveReq' :: ChainRange (Point blk)
-> m (BlockFetchBlockSender (Serialised blk) (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 (Serialised blk) (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 (Serialised blk) (Point blk) m ())
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO BlockFetchServerException
NoGenesisBlock

    receiveReq :: RealPoint blk
               -> RealPoint blk
               -> m (BlockFetchBlockSender (Serialised blk) (Point blk) m ())
    receiveReq :: RealPoint blk
-> RealPoint blk
-> m (BlockFetchBlockSender (Serialised blk) (Point blk) m ())
receiveReq RealPoint blk
start RealPoint blk
end = do
      Either
  (UnknownRange blk)
  (Iterator m blk (WithPoint blk (Serialised blk)))
errIt <- ChainDB m blk
-> ResourceRegistry m
-> BlockComponent blk (WithPoint blk (Serialised blk))
-> StreamFrom blk
-> StreamTo blk
-> m (Either
        (UnknownRange blk)
        (Iterator m blk (WithPoint blk (Serialised blk))))
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
        (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 (Serialised blk) (Point blk) m ()
-> m (BlockFetchBlockSender (Serialised blk) (Point blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockFetchBlockSender (Serialised blk) (Point blk) m ()
 -> m (BlockFetchBlockSender (Serialised blk) (Point blk) m ()))
-> BlockFetchBlockSender (Serialised blk) (Point blk) m ()
-> m (BlockFetchBlockSender (Serialised blk) (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ case Either
  (UnknownRange blk)
  (Iterator m blk (WithPoint blk (Serialised blk)))
errIt of
        -- The range is not in the ChainDB or it forks off more than @k@
        -- blocks back.
        Left  UnknownRange blk
_  -> m (BlockFetchServer (Serialised blk) (Point blk) m ())
-> BlockFetchBlockSender (Serialised blk) (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchBlockSender block point m a
SendMsgNoBlocks (m (BlockFetchServer (Serialised blk) (Point blk) m ())
 -> BlockFetchBlockSender (Serialised blk) (Point blk) m ())
-> m (BlockFetchServer (Serialised blk) (Point blk) m ())
-> BlockFetchBlockSender (Serialised blk) (Point blk) m ()
forall a b. (a -> b) -> a -> b
$ BlockFetchServer (Serialised blk) (Point blk) m ()
-> m (BlockFetchServer (Serialised blk) (Point blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return BlockFetchServer (Serialised blk) (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 (Serialised blk))
it -> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
-> BlockFetchBlockSender (Serialised blk) (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchSendBlocks block point m a)
-> BlockFetchBlockSender block point m a
SendMsgStartBatch (m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
 -> BlockFetchBlockSender (Serialised blk) (Point blk) m ())
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
-> BlockFetchBlockSender (Serialised blk) (Point blk) m ()
forall a b. (a -> b) -> a -> b
$ Iterator m blk (WithPoint blk (Serialised blk))
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
sendBlocks Iterator m blk (WithPoint blk (Serialised blk))
it

    sendBlocks :: ChainDB.Iterator m blk (WithPoint blk (Serialised blk))
               -> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
    sendBlocks :: Iterator m blk (WithPoint blk (Serialised blk))
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
sendBlocks Iterator m blk (WithPoint blk (Serialised blk))
it = do
      IteratorResult blk (WithPoint blk (Serialised blk))
next <- Iterator m blk (WithPoint blk (Serialised blk))
-> m (IteratorResult blk (WithPoint blk (Serialised blk)))
forall (m :: * -> *) blk b.
Iterator m blk b -> m (IteratorResult blk b)
ChainDB.iteratorNext Iterator m blk (WithPoint blk (Serialised blk))
it
      case IteratorResult blk (WithPoint blk (Serialised blk))
next of
        IteratorResult WithPoint blk (Serialised blk)
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 (Serialised blk) -> Point blk
forall blk b. WithPoint blk b -> Point blk
point WithPoint blk (Serialised blk)
blk
          BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
 -> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ()))
-> BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ Serialised blk
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
-> BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
forall block (m :: * -> *) point a.
block
-> m (BlockFetchSendBlocks block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBlock (WithPoint blk (Serialised blk) -> Serialised blk
forall blk b. WithPoint blk b -> b
withoutPoint WithPoint blk (Serialised blk)
blk) (Iterator m blk (WithPoint blk (Serialised blk))
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
sendBlocks Iterator m blk (WithPoint blk (Serialised blk))
it)
        IteratorResult blk (WithPoint blk (Serialised blk))
IteratorExhausted      -> do
          Iterator m blk (WithPoint blk (Serialised blk)) -> m ()
forall (m :: * -> *) blk b. Iterator m blk b -> m ()
ChainDB.iteratorClose Iterator m blk (WithPoint blk (Serialised blk))
it
          BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
 -> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ()))
-> BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ m (BlockFetchServer (Serialised blk) (Point blk) m ())
-> BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBatchDone (m (BlockFetchServer (Serialised blk) (Point blk) m ())
 -> BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
-> m (BlockFetchServer (Serialised blk) (Point blk) m ())
-> BlockFetchSendBlocks (Serialised blk) (Point blk) m ()
forall a b. (a -> b) -> a -> b
$ BlockFetchServer (Serialised blk) (Point blk) m ()
-> m (BlockFetchServer (Serialised blk) (Point blk) m ())
forall (m :: * -> *) a. Monad m => a -> m a
return BlockFetchServer (Serialised blk) (Point blk) m ()
senderSide
        IteratorBlockGCed RealPoint blk
pt -> do
          Iterator m blk (WithPoint blk (Serialised blk)) -> m ()
forall (m :: * -> *) blk b. Iterator m blk b -> m ()
ChainDB.iteratorClose Iterator m blk (WithPoint blk (Serialised blk))
it
          BlockFetchServerException
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (BlockFetchServerException
 -> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ()))
-> BlockFetchServerException
-> m (BlockFetchSendBlocks (Serialised blk) (Point blk) m ())
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> BlockFetchServerException
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
/= :: TraceBlockFetchServerEvent blk
-> TraceBlockFetchServerEvent blk -> Bool
$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
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
showList :: [TraceBlockFetchServerEvent blk] -> ShowS
$cshowList :: forall blk.
StandardHash blk =>
[TraceBlockFetchServerEvent blk] -> ShowS
show :: TraceBlockFetchServerEvent blk -> String
$cshow :: forall blk.
StandardHash blk =>
TraceBlockFetchServerEvent blk -> String
showsPrec :: Int -> TraceBlockFetchServerEvent blk -> ShowS
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> TraceBlockFetchServerEvent blk -> ShowS
Show)