Skip to content
Permalink
Browse files

Add IteratorBlockGCed constructor to ChainDB.IteratorResult

Handle this rare case in the BlockFetchServer by throwing an exception.
  • Loading branch information...
mrBliss committed May 14, 2019
1 parent f830bb1 commit 77b11d96cf819880182fd3189780b4f7f28d19fb
@@ -1,9 +1,15 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Ouroboros.Consensus.BlockFetchServer
( blockFetchServer
) where

import Data.Typeable (Typeable)

import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadThrow
import Control.Tracer (Tracer)
@@ -14,16 +20,35 @@ import Ouroboros.Network.Protocol.BlockFetch.Server
BlockFetchServer (..))
import Ouroboros.Network.Protocol.BlockFetch.Type (ChainRange (..))

import Ouroboros.Storage.ChainDB.API (ChainDB)
import Ouroboros.Storage.ChainDB.API (ChainDB, IteratorResult (..))
import qualified Ouroboros.Storage.ChainDB.API as ChainDB

data BlockFetchServerException blk =
-- | 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 when streaming some old fork. This
-- will not happen when streaming blocks from the current chain (old or
-- new) or a recent fork.
BlockGCed (HeaderHash blk)

deriving instance (Show (HeaderHash blk))
=> Show (BlockFetchServerException blk)

instance (Typeable blk, Show (HeaderHash blk))
=> Exception (BlockFetchServerException blk)

-- | Block fetch server based on
-- 'Ouroboros.Network.BlockFetch.Examples.mockBlockFetchServer1', but using
-- the 'ChainDB'.
blockFetchServer
:: forall m hdr blk.
(MonadSTM m, MonadThrow m, HeaderHash hdr ~ HeaderHash blk)
( MonadSTM m
, MonadThrow m
, HeaderHash hdr ~ HeaderHash blk
, Typeable blk
, Show (HeaderHash blk)
)
=> Tracer m String
-> ChainDB m blk hdr
-> BlockFetchServer hdr blk m ()
@@ -47,9 +72,10 @@ blockFetchServer _tracer chainDB = senderSide
-> m (BlockFetchSendBlocks hdr blk m ())
sendBlocks it = do
next <- ChainDB.iteratorNext it
return $ case next of
ChainDB.IteratorExhausted -> SendMsgBatchDone (return senderSide)
ChainDB.IteratorResult blk -> SendMsgBlock blk (sendBlocks it)
case next of
IteratorExhausted -> return $ SendMsgBatchDone (return senderSide)
IteratorResult blk -> return $ SendMsgBlock blk (sendBlocks it)
IteratorBlockGCed hash -> throwM $ BlockGCed @blk hash

withIter :: ChainRange hdr -> (ChainDB.Iterator m blk -> m a) -> m a
withIter (ChainRange start end) = bracket
@@ -225,8 +225,9 @@ toChain chainDB = bracket
go chain it = do
next <- iteratorNext it
case next of
IteratorExhausted -> return chain
IteratorResult blk -> go (Chain.addBlock blk chain) it
IteratorExhausted -> return chain
IteratorBlockGCed _ -> error "block was garbage-collected"
IteratorResult blk -> go (Chain.addBlock blk chain) it

fromChain :: forall m blk hdr. Monad m
=> m (ChainDB m blk hdr)
@@ -275,6 +276,11 @@ newtype IteratorId = IteratorId Int
data IteratorResult blk =
IteratorExhausted
| IteratorResult blk
| IteratorBlockGCed (HeaderHash blk)
-- ^ The block that was supposed to be streamed was garbage-collected from
-- the VolatileDB, but not added to the ImmutableDB.
--
-- This will only happen when streaming very old forks.

{-------------------------------------------------------------------------------
Chain updates

0 comments on commit 77b11d9

Please sign in to comment.
You can’t perform that action at this time.