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