{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Iterator
  ( CurrentChunkInfo (..)
  , extractBlockComponent
  , getSlotInfo
  , streamImpl
  , getBlockAtOrAfterPointImpl
  ) where

import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Prelude (forceElemsToWHNF)
import Cardano.Slotting.Slot (WithOrigin (..))
import qualified Codec.CBOR.Read as CBOR
import Control.Monad (unless, void, when)
import Control.Monad.Except (ExceptT, runExceptT, throwError)
import Control.Monad.Trans.Class (lift)
import Control.ResourceRegistry
  ( ResourceKey
  , ResourceRegistry
  , allocate
  , release
  , unsafeRelease
  )
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString.Short as Short
import Data.Foldable (find)
import Data.Functor ((<&>))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as Text
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Ouroboros.Consensus.Block hiding (headerHash)
import Ouroboros.Consensus.Storage.Common
import Ouroboros.Consensus.Storage.ImmutableDB.API hiding
  ( getBlockComponent
  )
import Ouroboros.Consensus.Storage.ImmutableDB.Chunks
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index (Index)
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index as Index
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary
  ( BlockOffset (..)
  , BlockSize (..)
  )
import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary as Secondary
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.State
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types
import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util
import Ouroboros.Consensus.Storage.Serialisation
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.SizeInBytes
import System.FS.API.Lazy
import System.FS.CRC

{------------------------------------------------------------------------------
  ImmutableDB Iterator Implementation
------------------------------------------------------------------------------}

-- | Internal handle to an iterator.
--
-- Note: in contrast to 'IteratorState', these fields remain static for the
-- lifetime of the iterator.
data IteratorHandle m blk h = IteratorHandle
  { forall (m :: * -> *) blk h. IteratorHandle m blk h -> HasFS m h
ithHasFS :: !(HasFS m h)
  -- ^ Bundled HasFS instance because of the existential @h@.
  , forall (m :: * -> *) blk h. IteratorHandle m blk h -> Index m blk h
ithIndex :: !(Index m blk h)
  -- ^ Bundled Index instance because of the existential @h@.
  , forall (m :: * -> *) blk h.
IteratorHandle m blk h
-> StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: !(StrictTVar m (IteratorStateOrExhausted m blk h))
  -- ^ The state of the iterator
  , forall (m :: * -> *) blk h. IteratorHandle m blk h -> ChunkNo
ithEndChunk :: !ChunkNo
  -- ^ The chunk in which the last block to stream is located.
  , forall (m :: * -> *) blk h.
IteratorHandle m blk h -> HeaderHash blk
ithEndHash :: !(HeaderHash blk)
  -- ^ The has of the last block the iterator should return.
  }

data IteratorStateOrExhausted m hash h
  = IteratorStateOpen !(IteratorState m hash h)
  | IteratorStateExhausted
  deriving ((forall x.
 IteratorStateOrExhausted m hash h
 -> Rep (IteratorStateOrExhausted m hash h) x)
-> (forall x.
    Rep (IteratorStateOrExhausted m hash h) x
    -> IteratorStateOrExhausted m hash h)
-> Generic (IteratorStateOrExhausted m hash h)
forall x.
Rep (IteratorStateOrExhausted m hash h) x
-> IteratorStateOrExhausted m hash h
forall x.
IteratorStateOrExhausted m hash h
-> Rep (IteratorStateOrExhausted m hash h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) hash h x.
Rep (IteratorStateOrExhausted m hash h) x
-> IteratorStateOrExhausted m hash h
forall (m :: * -> *) hash h x.
IteratorStateOrExhausted m hash h
-> Rep (IteratorStateOrExhausted m hash h) x
$cfrom :: forall (m :: * -> *) hash h x.
IteratorStateOrExhausted m hash h
-> Rep (IteratorStateOrExhausted m hash h) x
from :: forall x.
IteratorStateOrExhausted m hash h
-> Rep (IteratorStateOrExhausted m hash h) x
$cto :: forall (m :: * -> *) hash h x.
Rep (IteratorStateOrExhausted m hash h) x
-> IteratorStateOrExhausted m hash h
to :: forall x.
Rep (IteratorStateOrExhausted m hash h) x
-> IteratorStateOrExhausted m hash h
Generic, Context
-> IteratorStateOrExhausted m hash h -> IO (Maybe ThunkInfo)
Proxy (IteratorStateOrExhausted m hash h) -> String
(Context
 -> IteratorStateOrExhausted m hash h -> IO (Maybe ThunkInfo))
-> (Context
    -> IteratorStateOrExhausted m hash h -> IO (Maybe ThunkInfo))
-> (Proxy (IteratorStateOrExhausted m hash h) -> String)
-> NoThunks (IteratorStateOrExhausted m hash h)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) hash h.
(StandardHash hash, IOLike m) =>
Context
-> IteratorStateOrExhausted m hash h -> IO (Maybe ThunkInfo)
forall (m :: * -> *) hash h.
(StandardHash hash, IOLike m) =>
Proxy (IteratorStateOrExhausted m hash h) -> String
$cnoThunks :: forall (m :: * -> *) hash h.
(StandardHash hash, IOLike m) =>
Context
-> IteratorStateOrExhausted m hash h -> IO (Maybe ThunkInfo)
noThunks :: Context
-> IteratorStateOrExhausted m hash h -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) hash h.
(StandardHash hash, IOLike m) =>
Context
-> IteratorStateOrExhausted m hash h -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> IteratorStateOrExhausted m hash h -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) hash h.
(StandardHash hash, IOLike m) =>
Proxy (IteratorStateOrExhausted m hash h) -> String
showTypeOf :: Proxy (IteratorStateOrExhausted m hash h) -> String
NoThunks)

data IteratorState m blk h = IteratorState
  { forall (m :: * -> *) blk h. IteratorState m blk h -> ChunkNo
itsChunk :: !ChunkNo
  -- ^ The current chunk the iterator is streaming from.
  , forall (m :: * -> *) blk h. IteratorState m blk h -> Handle h
itsChunkHandle :: !(Handle h)
  -- ^ A handle to the chunk file corresponding with 'itsChunk'.
  , forall (m :: * -> *) blk h. IteratorState m blk h -> ResourceKey m
itsChunkKey :: !(ResourceKey m)
  -- ^ The 'ResourceKey' corresponding to the 'itsChunkHandle'. We use it to
  -- release the handle from the 'ResourceRegistry'.
  --
  -- NOTE: if we only close the handle but don't release the resource, the
  -- registry will still hold on to the (closed) handle/resource.
  , forall (m :: * -> *) blk h.
IteratorState m blk h -> NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries :: !(NonEmpty (WithBlockSize (Secondary.Entry blk)))
  -- ^ The entries from the secondary index corresponding to the current
  -- chunk. The first entry in the list is the next one to stream.
  --
  -- Invariant: all the entries in this list must be included in the stream.
  -- In other words, entries corresponding to blocks after the end bound are
  -- not included in this list.
  }
  deriving (forall x. IteratorState m blk h -> Rep (IteratorState m blk h) x)
-> (forall x.
    Rep (IteratorState m blk h) x -> IteratorState m blk h)
-> Generic (IteratorState m blk h)
forall x. Rep (IteratorState m blk h) x -> IteratorState m blk h
forall x. IteratorState m blk h -> Rep (IteratorState m blk h) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) blk h x.
Rep (IteratorState m blk h) x -> IteratorState m blk h
forall (m :: * -> *) blk h x.
IteratorState m blk h -> Rep (IteratorState m blk h) x
$cfrom :: forall (m :: * -> *) blk h x.
IteratorState m blk h -> Rep (IteratorState m blk h) x
from :: forall x. IteratorState m blk h -> Rep (IteratorState m blk h) x
$cto :: forall (m :: * -> *) blk h x.
Rep (IteratorState m blk h) x -> IteratorState m blk h
to :: forall x. Rep (IteratorState m blk h) x -> IteratorState m blk h
Generic

deriving instance (StandardHash blk, IOLike m) => NoThunks (IteratorState m blk h)

-- | Auxiliary data type that combines the 'currentChunk' and
-- 'currentChunkOffset' fields from 'OpenState'. This is used to avoid passing
-- the whole state around, and moreover, it avoids issues with existential @h@
-- type parameter.
data CurrentChunkInfo = CurrentChunkInfo !ChunkNo !BlockOffset

streamImpl ::
  forall m blk b.
  ( IOLike m
  , HasHeader blk
  , DecodeDisk blk (Lazy.ByteString -> Either Plain.DecoderError blk)
  , DecodeDiskDep (NestedCtxt Header) blk
  , ReconstructNestedCtxt Header blk
  , HasCallStack
  ) =>
  ImmutableDBEnv m blk ->
  ResourceRegistry m ->
  BlockComponent blk b ->
  StreamFrom blk ->
  StreamTo blk ->
  m (Either (MissingBlock blk) (Iterator m blk b))
streamImpl :: forall (m :: * -> *) blk b.
(IOLike m, HasHeader blk,
 DecodeDisk blk (ByteString -> Either DecoderError blk),
 DecodeDiskDep (NestedCtxt Header) blk,
 ReconstructNestedCtxt Header blk, HasCallStack) =>
ImmutableDBEnv m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
streamImpl ImmutableDBEnv m blk
dbEnv ResourceRegistry m
registry BlockComponent blk b
blockComponent = \StreamFrom blk
from StreamTo blk
to ->
  ImmutableDBEnv m blk
-> (forall h.
    HasFS m h
    -> OpenState m blk h
    -> m (Either (MissingBlock blk) (Iterator m blk b)))
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall (m :: * -> *) blk r.
(HasCallStack, IOLike m, StandardHash blk, Typeable blk) =>
ImmutableDBEnv m blk
-> (forall h. HasFS m h -> OpenState m blk h -> m r) -> m r
withOpenState ImmutableDBEnv m blk
dbEnv ((forall h.
  HasFS m h
  -> OpenState m blk h
  -> m (Either (MissingBlock blk) (Iterator m blk b)))
 -> m (Either (MissingBlock blk) (Iterator m blk b)))
-> (forall h.
    HasFS m h
    -> OpenState m blk h
    -> m (Either (MissingBlock blk) (Iterator m blk b)))
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall a b. (a -> b) -> a -> b
$ \HasFS m h
hasFS OpenState{SecondaryOffset
WithOrigin (Tip blk)
Handle h
ChunkNo
BlockOffset
Index m blk h
currentChunk :: forall (m :: * -> *) blk h. OpenState m blk h -> ChunkNo
currentChunkOffset :: forall (m :: * -> *) blk h. OpenState m blk h -> BlockOffset
currentChunk :: ChunkNo
currentChunkOffset :: BlockOffset
currentSecondaryOffset :: SecondaryOffset
currentChunkHandle :: Handle h
currentPrimaryHandle :: Handle h
currentSecondaryHandle :: Handle h
currentTip :: WithOrigin (Tip blk)
currentIndex :: Index m blk h
currentIndex :: forall (m :: * -> *) blk h. OpenState m blk h -> Index m blk h
currentTip :: forall (m :: * -> *) blk h.
OpenState m blk h -> WithOrigin (Tip blk)
currentSecondaryHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentPrimaryHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentChunkHandle :: forall (m :: * -> *) blk h. OpenState m blk h -> Handle h
currentSecondaryOffset :: forall (m :: * -> *) blk h. OpenState m blk h -> SecondaryOffset
..} -> ExceptT (MissingBlock blk) m (Iterator m blk b)
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (MissingBlock blk) m (Iterator m blk b)
 -> m (Either (MissingBlock blk) (Iterator m blk b)))
-> ExceptT (MissingBlock blk) m (Iterator m blk b)
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall a b. (a -> b) -> a -> b
$ do
    Bool
-> ExceptT (MissingBlock blk) m ()
-> ExceptT (MissingBlock blk) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (StreamFrom blk -> StreamTo blk -> Bool
forall blk.
StandardHash blk =>
StreamFrom blk -> StreamTo blk -> Bool
validBounds StreamFrom blk
from StreamTo blk
to) (ExceptT (MissingBlock blk) m ()
 -> ExceptT (MissingBlock blk) m ())
-> ExceptT (MissingBlock blk) m ()
-> ExceptT (MissingBlock blk) m ()
forall a b. (a -> b) -> a -> b
$
      m () -> ExceptT (MissingBlock blk) m ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (MissingBlock blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT (MissingBlock blk) m ())
-> m () -> ExceptT (MissingBlock blk) m ()
forall a b. (a -> b) -> a -> b
$
        ApiMisuse blk -> m ()
forall (m :: * -> *) blk a.
(MonadThrow m, HasCallStack, StandardHash blk, Typeable blk) =>
ApiMisuse blk -> m a
throwApiMisuse (ApiMisuse blk -> m ()) -> ApiMisuse blk -> m ()
forall a b. (a -> b) -> a -> b
$
          StreamFrom blk -> StreamTo blk -> ApiMisuse blk
forall blk. StreamFrom blk -> StreamTo blk -> ApiMisuse blk
InvalidIteratorRangeError StreamFrom blk
from StreamTo blk
to

    endChunkSlot <- Index m blk h
-> WithOrigin (Tip blk)
-> StreamTo blk
-> ExceptT (MissingBlock blk) m ChunkSlot
forall h.
HasCallStack =>
Index m blk h
-> WithOrigin (Tip blk)
-> StreamTo blk
-> ExceptT (MissingBlock blk) m ChunkSlot
checkUpperBound Index m blk h
currentIndex WithOrigin (Tip blk)
currentTip StreamTo blk
to

    --  When the lower bound is exclusive, we do the same as when it is
    --  inclusive. We set up the iterator to point at the lower bound. Only at
    --  the very end of this function do we advance it to the block after it,
    --  in the case of an exclusive lower bound.
    (secondaryOffset, startChunkSlot) <-
      checkLowerBound currentIndex currentTip from

    lift $ do
      -- 'validBounds' will catch nearly all invalid ranges, except for one:
      -- streaming from the regular block to the EBB in the same slot. The
      -- EBB comes before the regular block, so these bounds are invalid.
      -- However, to distinguish the EBB from the regular block, as both
      -- have the same slot number, we need to look at the hashes.
      -- 'validateBounds' doesn't have enough information to do that.
      when (startChunkSlot > endChunkSlot) $
        throwApiMisuse $
          InvalidIteratorRangeError from to

      let ChunkSlot startChunk startRelSlot = startChunkSlot
          startIsEBB = RelativeSlot -> IsEBB
relativeSlotIsEBB RelativeSlot
startRelSlot
          currentChunkInfo = ChunkNo -> BlockOffset -> CurrentChunkInfo
CurrentChunkInfo ChunkNo
currentChunk BlockOffset
currentChunkOffset
          endHash = case StreamTo blk
to of
            StreamToInclusive (RealPoint SlotNo
_slot HeaderHash blk
hash) -> HeaderHash blk
hash

      iteratorState <-
        iteratorStateForChunk
          hasFS
          currentIndex
          registry
          currentChunkInfo
          endHash
          startChunk
          secondaryOffset
          startIsEBB

      varIteratorState <- newTVarIO $ IteratorStateOpen iteratorState

      let ith =
            IteratorHandle
              { ithHasFS :: HasFS m h
ithHasFS = HasFS m h
hasFS
              , ithIndex :: Index m blk h
ithIndex = Index m blk h
currentIndex
              , ithVarState :: StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState = StrictTVar m (IteratorStateOrExhausted m blk h)
varIteratorState
              , ithEndChunk :: ChunkNo
ithEndChunk = ChunkSlot -> ChunkNo
chunkIndex ChunkSlot
endChunkSlot
              , ithEndHash :: HeaderHash blk
ithEndHash = HeaderHash blk
endHash
              }

      -- When streaming from an exclusive lower bound that is not genesis, we
      -- have opened the iterator at the bound itself, so we have to skip it
      -- first.
      case from of
        StreamFromExclusive (BlockPoint{}) ->
          ResourceRegistry m
-> CurrentChunkInfo -> IteratorHandle m blk h -> m ()
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, HasHeader blk) =>
ResourceRegistry m
-> CurrentChunkInfo -> IteratorHandle m blk h -> m ()
stepIterator ResourceRegistry m
registry CurrentChunkInfo
currentChunkInfo IteratorHandle m blk h
ith
        StreamFrom blk
_otherwise -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      return $ mkIterator ith
 where
  ImmutableDBEnv{ChunkInfo
chunkInfo :: ChunkInfo
chunkInfo :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> ChunkInfo
chunkInfo} = ImmutableDBEnv m blk
dbEnv

  -- \| Check the upper bound: check whether it exists in the database (return
  -- a 'MissingBlock' otherwise), and return the corresponding 'ChunkSlot'.
  checkUpperBound ::
    HasCallStack =>
    Index m blk h ->
    WithOrigin (Tip blk) ->
    -- \^ Current tip
    StreamTo blk ->
    ExceptT (MissingBlock blk) m ChunkSlot
  -- \^ We can't return 'TipInfo' here because the secondary index does
  -- not give us block numbers
  checkUpperBound :: forall h.
HasCallStack =>
Index m blk h
-> WithOrigin (Tip blk)
-> StreamTo blk
-> ExceptT (MissingBlock blk) m ChunkSlot
checkUpperBound Index m blk h
index WithOrigin (Tip blk)
currentTip (StreamToInclusive RealPoint blk
endPt) = do
    (chunkSlot, _, _) <- ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, HasHeader blk) =>
ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
getSlotInfo ChunkInfo
chunkInfo Index m blk h
index WithOrigin (Tip blk)
currentTip RealPoint blk
endPt
    return chunkSlot

  -- \| Check the lower bound: check whether it exists in the database (return
  -- a 'MissingBlock' otherwise), and return the corresponding 'ChunkSlot' and
  -- 'SecondaryOffset'.
  --
  -- PRECONDITION: the end bound has been checked already
  --
  -- PRECONDITION: the bounds passed the 'validBounds' check
  --
  -- Both preconditions combined guarantee us that the tip is not origin and
  -- that the lower bound is <= the tip.
  checkLowerBound ::
    HasCallStack =>
    Index m blk h ->
    WithOrigin (Tip blk) ->
    -- \^ Current tip
    StreamFrom blk ->
    ExceptT (MissingBlock blk) m (SecondaryOffset, ChunkSlot)
  checkLowerBound :: forall h.
HasCallStack =>
Index m blk h
-> WithOrigin (Tip blk)
-> StreamFrom blk
-> ExceptT (MissingBlock blk) m (SecondaryOffset, ChunkSlot)
checkLowerBound Index m blk h
index WithOrigin (Tip blk)
currentTip = \case
    StreamFromInclusive RealPoint blk
startPt -> do
      (chunkSlot, _, secondaryOffset) <-
        ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, HasHeader blk) =>
ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
getSlotInfo ChunkInfo
chunkInfo Index m blk h
index WithOrigin (Tip blk)
currentTip RealPoint blk
startPt
      return (secondaryOffset, chunkSlot)
    StreamFromExclusive Point blk
startPt -> case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
startPt of
      WithOrigin (RealPoint blk)
Origin -> m (SecondaryOffset, ChunkSlot)
-> ExceptT (MissingBlock blk) m (SecondaryOffset, ChunkSlot)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (MissingBlock blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (SecondaryOffset, ChunkSlot)
 -> ExceptT (MissingBlock blk) m (SecondaryOffset, ChunkSlot))
-> m (SecondaryOffset, ChunkSlot)
-> ExceptT (MissingBlock blk) m (SecondaryOffset, ChunkSlot)
forall a b. (a -> b) -> a -> b
$ Index m blk h -> m (SecondaryOffset, ChunkSlot)
forall h.
HasCallStack =>
Index m blk h -> m (SecondaryOffset, ChunkSlot)
findFirstBlock Index m blk h
index
      NotOrigin RealPoint blk
startPt' -> do
        (chunkSlot, _, secondaryOffset) <-
          ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, HasHeader blk) =>
ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
getSlotInfo ChunkInfo
chunkInfo Index m blk h
index WithOrigin (Tip blk)
currentTip RealPoint blk
startPt'
        return (secondaryOffset, chunkSlot)

  mkIterator :: IteratorHandle m blk h -> Iterator m blk b
  mkIterator :: forall h. IteratorHandle m blk h -> Iterator m blk b
mkIterator IteratorHandle m blk h
ith =
    Iterator
      { iteratorNext :: HasCallStack => m (IteratorResult b)
iteratorNext = ImmutableDBEnv m blk
-> IteratorHandle m blk h
-> ResourceRegistry m
-> BlockComponent blk b
-> m (IteratorResult b)
forall (m :: * -> *) blk b h.
(IOLike m, HasHeader blk,
 DecodeDisk blk (ByteString -> Either DecoderError blk),
 DecodeDiskDep (NestedCtxt Header) blk,
 ReconstructNestedCtxt Header blk) =>
ImmutableDBEnv m blk
-> IteratorHandle m blk h
-> ResourceRegistry m
-> BlockComponent blk b
-> m (IteratorResult b)
iteratorNextImpl ImmutableDBEnv m blk
dbEnv IteratorHandle m blk h
ith ResourceRegistry m
registry BlockComponent blk b
blockComponent
      , iteratorHasNext :: HasCallStack => STM m (Maybe (RealPoint blk))
iteratorHasNext = ImmutableDBEnv m blk
-> IteratorHandle m blk h -> STM m (Maybe (RealPoint blk))
forall (m :: * -> *) blk h.
IOLike m =>
ImmutableDBEnv m blk
-> IteratorHandle m blk h -> STM m (Maybe (RealPoint blk))
iteratorHasNextImpl ImmutableDBEnv m blk
dbEnv IteratorHandle m blk h
ith
      , iteratorClose :: HasCallStack => m ()
iteratorClose = IteratorHandle m blk h -> m ()
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m) =>
IteratorHandle m blk h -> m ()
iteratorCloseImpl IteratorHandle m blk h
ith
      }

  -- \| Find the 'SecondaryOffset' and 'ChunkSlot' corresponding to the first
  -- block in the ImmutableDB.
  --
  -- PRECONDITION: the ImmutableDB is not empty.
  findFirstBlock ::
    HasCallStack =>
    Index m blk h ->
    m (SecondaryOffset, ChunkSlot)
  findFirstBlock :: forall h.
HasCallStack =>
Index m blk h -> m (SecondaryOffset, ChunkSlot)
findFirstBlock Index m blk h
index = ChunkNo -> m (SecondaryOffset, ChunkSlot)
go ChunkNo
firstChunkNo
   where
    go :: ChunkNo -> m (SecondaryOffset, ChunkSlot)
    go :: ChunkNo -> m (SecondaryOffset, ChunkSlot)
go ChunkNo
chunk =
      Index m blk h -> HasCallStack => ChunkNo -> m (Maybe RelativeSlot)
forall (m :: * -> *) blk h.
Index m blk h -> HasCallStack => ChunkNo -> m (Maybe RelativeSlot)
Index.readFirstFilledSlot Index m blk h
index ChunkNo
chunk m (Maybe RelativeSlot)
-> (Maybe RelativeSlot -> m (SecondaryOffset, ChunkSlot))
-> m (SecondaryOffset, ChunkSlot)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe RelativeSlot
Nothing -> ChunkNo -> m (SecondaryOffset, ChunkSlot)
go (ChunkNo -> ChunkNo
nextChunkNo ChunkNo
chunk)
        Just RelativeSlot
relSlot -> (SecondaryOffset, ChunkSlot) -> m (SecondaryOffset, ChunkSlot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SecondaryOffset
0, ChunkNo -> RelativeSlot -> ChunkSlot
chunkSlotForRelativeSlot ChunkNo
chunk RelativeSlot
relSlot)

-- | Get information about the block or EBB at the given slot with the given
-- hash. If no such block exists, because the slot is empty, it contains a block
-- and/or EBB with a different hash, or it is newer than the current tip, return
-- a 'MissingBlock'.
--
-- Return the 'ChunkSlot' corresponding to the block or EBB, the corresponding
-- entry (and 'BlockSize') from the secondary index file, and the
-- 'SecondaryOffset' of that entry.
--
-- The primary index is read to find out whether the slot is filled and what
-- the 'SecondaryOffset' is for the slot. The secondary index is read to check
-- the hash and to return the 'Secondary.Entry'.
getSlotInfo ::
  forall m blk h.
  (HasCallStack, IOLike m, HasHeader blk) =>
  ChunkInfo ->
  Index m blk h ->
  -- | Current tip
  WithOrigin (Tip blk) ->
  RealPoint blk ->
  ExceptT
    (MissingBlock blk)
    m
    ( ChunkSlot
    , (Secondary.Entry blk, BlockSize)
    , SecondaryOffset
    )
getSlotInfo :: forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, HasHeader blk) =>
ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
getSlotInfo ChunkInfo
chunkInfo Index m blk h
index WithOrigin (Tip blk)
currentTip pt :: RealPoint blk
pt@(RealPoint SlotNo
slot HeaderHash blk
hash) = do
  let (ChunkNo
chunk, Maybe ChunkSlot
mIfBoundary, ChunkSlot
ifRegular) =
        HasCallStack =>
ChunkInfo -> SlotNo -> (ChunkNo, Maybe ChunkSlot, ChunkSlot)
ChunkInfo -> SlotNo -> (ChunkNo, Maybe ChunkSlot, ChunkSlot)
chunkSlotForUnknownBlock ChunkInfo
chunkInfo SlotNo
slot

  case WithOrigin (Tip blk)
currentTip of
    NotOrigin (Tip{SlotNo
tipSlotNo :: SlotNo
tipSlotNo :: forall blk. Tip blk -> SlotNo
tipSlotNo})
      | SlotNo
slot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
tipSlotNo ->
          () -> ExceptT (MissingBlock blk) m ()
forall a. a -> ExceptT (MissingBlock blk) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    WithOrigin (Tip blk)
_otherwise ->
      MissingBlock blk -> ExceptT (MissingBlock blk) m ()
forall a. MissingBlock blk -> ExceptT (MissingBlock blk) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk -> ExceptT (MissingBlock blk) m ())
-> MissingBlock blk -> ExceptT (MissingBlock blk) m ()
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Point blk -> MissingBlock blk
forall blk. RealPoint blk -> Point blk -> MissingBlock blk
NewerThanTip RealPoint blk
pt (WithOrigin (Tip blk) -> Point blk
forall blk. WithOrigin (Tip blk) -> Point blk
tipToPoint WithOrigin (Tip blk)
currentTip)

  -- Obtain the offsets in the secondary index file from the primary index
  -- file. The block /could/ still correspond to an EBB, a regular block or
  -- both. We will know which one it is when we can check the hashes from
  -- the secondary index file with the hash we have.
  toRead :: NonEmpty (IsEBB, SecondaryOffset) <- case Maybe ChunkSlot
mIfBoundary of
    Just ChunkSlot
ifBoundary -> do
      let relatives :: Two RelativeSlot
relatives@(Two RelativeSlot
relb RelativeSlot
relr) = ChunkSlot -> RelativeSlot
chunkRelative (ChunkSlot -> RelativeSlot) -> Two ChunkSlot -> Two RelativeSlot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChunkSlot -> ChunkSlot -> Two ChunkSlot
forall a. a -> a -> Two a
Two ChunkSlot
ifBoundary ChunkSlot
ifRegular
      (offsets, s) <- m (Two (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
-> ExceptT
     (MissingBlock blk)
     m
     (Two (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (MissingBlock blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Two (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
 -> ExceptT
      (MissingBlock blk)
      m
      (Two (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset)))
-> m (Two (Maybe SecondaryOffset),
      Maybe (StrictSeq SecondaryOffset))
-> ExceptT
     (MissingBlock blk)
     m
     (Two (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
forall a b. (a -> b) -> a -> b
$ Index m blk h
-> forall (t :: * -> *).
   (HasCallStack, Traversable t) =>
   ChunkNo
   -> t RelativeSlot
   -> m (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
forall (m :: * -> *) blk h.
Index m blk h
-> forall (t :: * -> *).
   (HasCallStack, Traversable t) =>
   ChunkNo
   -> t RelativeSlot
   -> m (t (Maybe SecondaryOffset), Maybe (StrictSeq SecondaryOffset))
Index.readOffsets Index m blk h
index ChunkNo
chunk Two RelativeSlot
relatives
      case offsets of
        Two Maybe SecondaryOffset
Nothing Maybe SecondaryOffset
Nothing ->
          MissingBlock blk
-> ExceptT (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset))
forall a. MissingBlock blk -> ExceptT (MissingBlock blk) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk
 -> ExceptT
      (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset)))
-> MissingBlock blk
-> ExceptT (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset))
forall a b. (a -> b) -> a -> b
$ RealPoint blk
-> ChunkNo
-> [RelativeSlot]
-> Maybe (StrictSeq SecondaryOffset)
-> MissingBlock blk
forall blk.
RealPoint blk
-> ChunkNo
-> [RelativeSlot]
-> Maybe (StrictSeq SecondaryOffset)
-> MissingBlock blk
EmptySlot RealPoint blk
pt ChunkNo
chunk [RelativeSlot
relb, RelativeSlot
relr] Maybe (StrictSeq SecondaryOffset)
s
        Two (Just SecondaryOffset
ebbOffset) (Just SecondaryOffset
blkOffset) ->
          NonEmpty (IsEBB, SecondaryOffset)
-> ExceptT (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset))
forall a. a -> ExceptT (MissingBlock blk) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((IsEBB
IsEBB, SecondaryOffset
ebbOffset) (IsEBB, SecondaryOffset)
-> [(IsEBB, SecondaryOffset)] -> NonEmpty (IsEBB, SecondaryOffset)
forall a. a -> [a] -> NonEmpty a
NE.:| [(IsEBB
IsNotEBB, SecondaryOffset
blkOffset)])
        Two (Just SecondaryOffset
ebbOffset) Maybe SecondaryOffset
Nothing ->
          NonEmpty (IsEBB, SecondaryOffset)
-> ExceptT (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset))
forall a. a -> ExceptT (MissingBlock blk) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((IsEBB
IsEBB, SecondaryOffset
ebbOffset) (IsEBB, SecondaryOffset)
-> [(IsEBB, SecondaryOffset)] -> NonEmpty (IsEBB, SecondaryOffset)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
        Two Maybe SecondaryOffset
Nothing (Just SecondaryOffset
blkOffset) ->
          NonEmpty (IsEBB, SecondaryOffset)
-> ExceptT (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset))
forall a. a -> ExceptT (MissingBlock blk) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((IsEBB
IsNotEBB, SecondaryOffset
blkOffset) (IsEBB, SecondaryOffset)
-> [(IsEBB, SecondaryOffset)] -> NonEmpty (IsEBB, SecondaryOffset)
forall a. a -> [a] -> NonEmpty a
NE.:| [])
    Maybe ChunkSlot
Nothing -> do
      let relr :: RelativeSlot
relr = ChunkSlot -> RelativeSlot
chunkRelative ChunkSlot
ifRegular
      (offset, s) <- m (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
-> ExceptT
     (MissingBlock blk)
     m
     (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (MissingBlock blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
 -> ExceptT
      (MissingBlock blk)
      m
      (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset)))
-> m (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
-> ExceptT
     (MissingBlock blk)
     m
     (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
forall a b. (a -> b) -> a -> b
$ Index m blk h
-> ChunkNo
-> RelativeSlot
-> m (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
forall (m :: * -> *) blk h.
Functor m =>
Index m blk h
-> ChunkNo
-> RelativeSlot
-> m (Maybe SecondaryOffset, Maybe (StrictSeq SecondaryOffset))
Index.readOffset Index m blk h
index ChunkNo
chunk RelativeSlot
relr
      case offset of
        Maybe SecondaryOffset
Nothing ->
          MissingBlock blk
-> ExceptT (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset))
forall a. MissingBlock blk -> ExceptT (MissingBlock blk) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk
 -> ExceptT
      (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset)))
-> MissingBlock blk
-> ExceptT (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset))
forall a b. (a -> b) -> a -> b
$ RealPoint blk
-> ChunkNo
-> [RelativeSlot]
-> Maybe (StrictSeq SecondaryOffset)
-> MissingBlock blk
forall blk.
RealPoint blk
-> ChunkNo
-> [RelativeSlot]
-> Maybe (StrictSeq SecondaryOffset)
-> MissingBlock blk
EmptySlot RealPoint blk
pt ChunkNo
chunk [RelativeSlot
relr] Maybe (StrictSeq SecondaryOffset)
s
        Just SecondaryOffset
blkOffset ->
          NonEmpty (IsEBB, SecondaryOffset)
-> ExceptT (MissingBlock blk) m (NonEmpty (IsEBB, SecondaryOffset))
forall a. a -> ExceptT (MissingBlock blk) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((IsEBB
IsNotEBB, SecondaryOffset
blkOffset) (IsEBB, SecondaryOffset)
-> [(IsEBB, SecondaryOffset)] -> NonEmpty (IsEBB, SecondaryOffset)
forall a. a -> [a] -> NonEmpty a
NE.:| [])

  entriesWithBlockSizes :: NonEmpty (Secondary.Entry blk, BlockSize) <-
    lift $ Index.readEntries index chunk toRead

  -- Return the entry from the secondary index file that matches the
  -- expected hash.
  (secondaryOffset, (entry, blockSize)) <-
    case find
      ((== hash) . Secondary.headerHash . fst . snd)
      (NE.zip (fmap snd toRead) entriesWithBlockSizes) of
      Just (SecondaryOffset, (Entry blk, BlockSize))
found -> (SecondaryOffset, (Entry blk, BlockSize))
-> ExceptT
     (MissingBlock blk) m (SecondaryOffset, (Entry blk, BlockSize))
forall a. a -> ExceptT (MissingBlock blk) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SecondaryOffset, (Entry blk, BlockSize))
found
      Maybe (SecondaryOffset, (Entry blk, BlockSize))
Nothing -> MissingBlock blk
-> ExceptT
     (MissingBlock blk) m (SecondaryOffset, (Entry blk, BlockSize))
forall a. MissingBlock blk -> ExceptT (MissingBlock blk) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk
 -> ExceptT
      (MissingBlock blk) m (SecondaryOffset, (Entry blk, BlockSize)))
-> MissingBlock blk
-> ExceptT
     (MissingBlock blk) m (SecondaryOffset, (Entry blk, BlockSize))
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> NonEmpty (HeaderHash blk) -> MissingBlock blk
forall blk.
RealPoint blk -> NonEmpty (HeaderHash blk) -> MissingBlock blk
WrongHash RealPoint blk
pt NonEmpty (HeaderHash blk)
hashes
       where
        hashes :: NonEmpty (HeaderHash blk)
hashes = Entry blk -> HeaderHash blk
forall blk. Entry blk -> HeaderHash blk
Secondary.headerHash (Entry blk -> HeaderHash blk)
-> ((Entry blk, BlockSize) -> Entry blk)
-> (Entry blk, BlockSize)
-> HeaderHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry blk, BlockSize) -> Entry blk
forall a b. (a, b) -> a
fst ((Entry blk, BlockSize) -> HeaderHash blk)
-> NonEmpty (Entry blk, BlockSize) -> NonEmpty (HeaderHash blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (Entry blk, BlockSize)
entriesWithBlockSizes

  -- Use the secondary index entry to determine whether the slot + hash
  -- correspond to an EBB or a regular block.
  let chunkSlot = case (Maybe ChunkSlot
mIfBoundary, Entry blk -> BlockOrEBB
forall blk. Entry blk -> BlockOrEBB
Secondary.blockOrEBB Entry blk
entry) of
        (Just ChunkSlot
ifBoundary, EBB EpochNo
_) -> ChunkSlot
ifBoundary
        (Maybe ChunkSlot, BlockOrEBB)
_otherwise -> ChunkSlot
ifRegular
  return (chunkSlot, (entry, blockSize), secondaryOffset)

-- | Move the iterator to the next position that can be read from,
-- advancing chunks if necessary. If no next position can be found, the
-- iterator is closed.
--
-- PRECONDITION: the given 'IteratorState' matches the one stored in the
-- given 'StrictTVar'.
--
-- PRECONDITION: the iterator is not exhausted.
stepIterator ::
  forall m blk h.
  (HasCallStack, IOLike m, HasHeader blk) =>
  ResourceRegistry m ->
  CurrentChunkInfo ->
  IteratorHandle m blk h ->
  m ()
stepIterator :: forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, HasHeader blk) =>
ResourceRegistry m
-> CurrentChunkInfo -> IteratorHandle m blk h -> m ()
stepIterator
  ResourceRegistry m
registry
  CurrentChunkInfo
currentChunkInfo
  ith :: IteratorHandle m blk h
ith@IteratorHandle{HasFS m h
ithHasFS :: forall (m :: * -> *) blk h. IteratorHandle m blk h -> HasFS m h
ithHasFS :: HasFS m h
ithHasFS, Index m blk h
ithIndex :: forall (m :: * -> *) blk h. IteratorHandle m blk h -> Index m blk h
ithIndex :: Index m blk h
ithIndex, StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: forall (m :: * -> *) blk h.
IteratorHandle m blk h
-> StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState, ChunkNo
ithEndChunk :: forall (m :: * -> *) blk h. IteratorHandle m blk h -> ChunkNo
ithEndChunk :: ChunkNo
ithEndChunk, HeaderHash blk
ithEndHash :: forall (m :: * -> *) blk h.
IteratorHandle m blk h -> HeaderHash blk
ithEndHash :: HeaderHash blk
ithEndHash} =
    STM m (IteratorStateOrExhausted m blk h)
-> m (IteratorStateOrExhausted m blk h)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (IteratorStateOrExhausted m blk h)
-> STM m (IteratorStateOrExhausted m blk h)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState) m (IteratorStateOrExhausted m blk h)
-> (IteratorStateOrExhausted m blk h -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      IteratorStateOrExhausted m blk h
IteratorStateExhausted ->
        String -> m ()
forall a. HasCallStack => String -> a
error String
"precondition violated: iterator must not be exhausted"
      IteratorStateOpen its :: IteratorState m blk h
its@IteratorState{NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries :: forall (m :: * -> *) blk h.
IteratorState m blk h -> NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries :: NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries, ResourceKey m
itsChunkKey :: forall (m :: * -> *) blk h. IteratorState m blk h -> ResourceKey m
itsChunkKey :: ResourceKey m
itsChunkKey, ChunkNo
itsChunk :: forall (m :: * -> *) blk h. IteratorState m blk h -> ChunkNo
itsChunk :: ChunkNo
itsChunk} ->
        case [WithBlockSize (Entry blk)]
-> Maybe (NonEmpty (WithBlockSize (Entry blk)))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty (NonEmpty (WithBlockSize (Entry blk)) -> [WithBlockSize (Entry blk)]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries) of
          -- There are entries left in this chunk, so continue. See the
          -- invariant on 'itsChunkEntries'
          Just NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries' ->
            STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
              StrictTVar m (IteratorStateOrExhausted m blk h)
-> IteratorStateOrExhausted m blk h -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState (IteratorStateOrExhausted m blk h -> STM m ())
-> IteratorStateOrExhausted m blk h -> STM m ()
forall a b. (a -> b) -> a -> b
$
                IteratorState m blk h -> IteratorStateOrExhausted m blk h
forall (m :: * -> *) hash h.
IteratorState m hash h -> IteratorStateOrExhausted m hash h
IteratorStateOpen IteratorState m blk h
its{itsChunkEntries = itsChunkEntries'}
          -- No more entries in this chunk, so open the next.
          Maybe (NonEmpty (WithBlockSize (Entry blk)))
Nothing -> do
            -- Release the resource, i.e., close the handle.
            m (Maybe (Context m)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Context m)) -> m ()) -> m (Maybe (Context m)) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceKey m -> m (Maybe (Context m))
forall (m :: * -> *).
(MonadMask m, MonadSTM m, MonadThread m, HasCallStack) =>
ResourceKey m -> m (Maybe (Context m))
release ResourceKey m
itsChunkKey
            -- If this was the final chunk, close the iterator
            if ChunkNo
itsChunk ChunkNo -> ChunkNo -> Bool
forall a. Ord a => a -> a -> Bool
>= ChunkNo
ithEndChunk
              then
                IteratorHandle m blk h -> m ()
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m) =>
IteratorHandle m blk h -> m ()
iteratorCloseImpl IteratorHandle m blk h
ith
              else
                ChunkNo -> m (IteratorState m blk h)
openNextChunk (ChunkNo -> ChunkNo
nextChunkNo ChunkNo
itsChunk) m (IteratorState m blk h)
-> (IteratorState m blk h -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \IteratorState m blk h
its' ->
                  STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (IteratorStateOrExhausted m blk h)
-> IteratorStateOrExhausted m blk h -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState (IteratorStateOrExhausted m blk h -> STM m ())
-> IteratorStateOrExhausted m blk h -> STM m ()
forall a b. (a -> b) -> a -> b
$ IteratorState m blk h -> IteratorStateOrExhausted m blk h
forall (m :: * -> *) hash h.
IteratorState m hash h -> IteratorStateOrExhausted m hash h
IteratorStateOpen IteratorState m blk h
its'
   where
    openNextChunk ::
      ChunkNo ->
      -- \^ The chunk to open
      m (IteratorState m blk h)
    openNextChunk :: ChunkNo -> m (IteratorState m blk h)
openNextChunk ChunkNo
chunk =
      Index m blk h -> HasCallStack => ChunkNo -> m (Maybe RelativeSlot)
forall (m :: * -> *) blk h.
Index m blk h -> HasCallStack => ChunkNo -> m (Maybe RelativeSlot)
Index.readFirstFilledSlot Index m blk h
ithIndex ChunkNo
chunk m (Maybe RelativeSlot)
-> (Maybe RelativeSlot -> m (IteratorState m blk h))
-> m (IteratorState m blk h)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        -- This chunk is empty, look in the next one.
        --
        -- We still haven't encountered the end bound, so this loop must end
        -- when we reach the non-empty chunk containing the end bound. This
        -- cannot loop forever as an error would be thrown when opening the
        -- index file(s) of a non-existing chunk.
        Maybe RelativeSlot
Nothing -> ChunkNo -> m (IteratorState m blk h)
openNextChunk (ChunkNo -> ChunkNo
nextChunkNo ChunkNo
chunk)
        Just RelativeSlot
relSlot -> do
          -- Note that the only reason we actually open the primary index file
          -- is to see whether the first block in the chunk is an EBB or not.
          -- To see whether the chunk is empty, we could open the secondary
          -- index file directly and see whether it contains any blocks. The
          -- 'secondaryOffset' will be 0, as the first entry in the secondary
          -- index file always starts at offset 0. The same is true for
          -- 'findFirstFilledSlot'.
          let firstIsEBB :: IsEBB
firstIsEBB = RelativeSlot -> IsEBB
relativeSlotIsEBB RelativeSlot
relSlot
              secondaryOffset :: SecondaryOffset
secondaryOffset = SecondaryOffset
0

          HasFS m h
-> Index m blk h
-> ResourceRegistry m
-> CurrentChunkInfo
-> HeaderHash blk
-> ChunkNo
-> SecondaryOffset
-> IsEBB
-> m (IteratorState m blk h)
forall blk (m :: * -> *) h.
(HasCallStack, HasHeader blk, IOLike m) =>
HasFS m h
-> Index m blk h
-> ResourceRegistry m
-> CurrentChunkInfo
-> HeaderHash blk
-> ChunkNo
-> SecondaryOffset
-> IsEBB
-> m (IteratorState m blk h)
iteratorStateForChunk
            HasFS m h
ithHasFS
            Index m blk h
ithIndex
            ResourceRegistry m
registry
            CurrentChunkInfo
currentChunkInfo
            HeaderHash blk
ithEndHash
            ChunkNo
chunk
            SecondaryOffset
secondaryOffset
            IsEBB
firstIsEBB

iteratorNextImpl ::
  forall m blk b h.
  ( IOLike m
  , HasHeader blk
  , DecodeDisk blk (Lazy.ByteString -> Either Plain.DecoderError blk)
  , DecodeDiskDep (NestedCtxt Header) blk
  , ReconstructNestedCtxt Header blk
  ) =>
  ImmutableDBEnv m blk ->
  IteratorHandle m blk h ->
  ResourceRegistry m ->
  BlockComponent blk b ->
  m (IteratorResult b)
iteratorNextImpl :: forall (m :: * -> *) blk b h.
(IOLike m, HasHeader blk,
 DecodeDisk blk (ByteString -> Either DecoderError blk),
 DecodeDiskDep (NestedCtxt Header) blk,
 ReconstructNestedCtxt Header blk) =>
ImmutableDBEnv m blk
-> IteratorHandle m blk h
-> ResourceRegistry m
-> BlockComponent blk b
-> m (IteratorResult b)
iteratorNextImpl ImmutableDBEnv m blk
dbEnv ith :: IteratorHandle m blk h
ith@IteratorHandle{HasFS m h
ithHasFS :: forall (m :: * -> *) blk h. IteratorHandle m blk h -> HasFS m h
ithHasFS :: HasFS m h
ithHasFS, StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: forall (m :: * -> *) blk h.
IteratorHandle m blk h
-> StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState} ResourceRegistry m
registry BlockComponent blk b
blockComponent = do
  -- The idea is that if the state is not 'IteratorStateExhausted', then the
  -- head of 'itsChunkEntries' is always ready to be read. After extracting
  -- the block component, 'stepIterator' will advance the iterator to the next
  -- block.
  STM m (IteratorStateOrExhausted m blk h)
-> m (IteratorStateOrExhausted m blk h)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (IteratorStateOrExhausted m blk h)
-> STM m (IteratorStateOrExhausted m blk h)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState) m (IteratorStateOrExhausted m blk h)
-> (IteratorStateOrExhausted m blk h -> m (IteratorResult b))
-> m (IteratorResult b)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Iterator already closed
    IteratorStateOrExhausted m blk h
IteratorStateExhausted -> IteratorResult b -> m (IteratorResult b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IteratorResult b
forall b. IteratorResult b
IteratorExhausted
    IteratorStateOpen IteratorState{NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries :: forall (m :: * -> *) blk h.
IteratorState m blk h -> NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries :: NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries, ChunkNo
itsChunk :: forall (m :: * -> *) blk h. IteratorState m blk h -> ChunkNo
itsChunk :: ChunkNo
itsChunk, Handle h
itsChunkHandle :: forall (m :: * -> *) blk h. IteratorState m blk h -> Handle h
itsChunkHandle :: Handle h
itsChunkHandle} ->
      ImmutableDBEnv m blk
-> (forall h.
    HasFS m h -> OpenState m blk h -> m (IteratorResult b))
-> m (IteratorResult b)
forall (m :: * -> *) blk r.
(HasCallStack, IOLike m, StandardHash blk, Typeable blk) =>
ImmutableDBEnv m blk
-> (forall h. HasFS m h -> OpenState m blk h -> m r) -> m r
withOpenState ImmutableDBEnv m blk
dbEnv ((forall h. HasFS m h -> OpenState m blk h -> m (IteratorResult b))
 -> m (IteratorResult b))
-> (forall h.
    HasFS m h -> OpenState m blk h -> m (IteratorResult b))
-> m (IteratorResult b)
forall a b. (a -> b) -> a -> b
$ \HasFS m h
_ OpenState m blk h
st -> do
        let entry :: WithBlockSize (Entry blk)
entry = NonEmpty (WithBlockSize (Entry blk)) -> WithBlockSize (Entry blk)
forall a. NonEmpty a -> a
NE.head NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries
            currentChunkInfo :: CurrentChunkInfo
currentChunkInfo =
              ChunkNo -> BlockOffset -> CurrentChunkInfo
CurrentChunkInfo
                (OpenState m blk h -> ChunkNo
forall (m :: * -> *) blk h. OpenState m blk h -> ChunkNo
currentChunk OpenState m blk h
st)
                (OpenState m blk h -> BlockOffset
forall (m :: * -> *) blk h. OpenState m blk h -> BlockOffset
currentChunkOffset OpenState m blk h
st)
        b <-
          HasFS m h
-> ChunkInfo
-> ChunkNo
-> CodecConfig blk
-> (blk -> Bool)
-> Handle h
-> WithBlockSize (Entry blk)
-> BlockComponent blk b
-> m b
forall (m :: * -> *) blk b h.
(HasHeader blk, ReconstructNestedCtxt Header blk,
 DecodeDisk blk (ByteString -> Either DecoderError blk),
 DecodeDiskDep (NestedCtxt Header) blk, IOLike m) =>
HasFS m h
-> ChunkInfo
-> ChunkNo
-> CodecConfig blk
-> (blk -> Bool)
-> Handle h
-> WithBlockSize (Entry blk)
-> BlockComponent blk b
-> m b
extractBlockComponent
            HasFS m h
ithHasFS
            ChunkInfo
chunkInfo
            ChunkNo
itsChunk
            CodecConfig blk
codecConfig
            blk -> Bool
checkIntegrity
            Handle h
itsChunkHandle
            WithBlockSize (Entry blk)
entry
            BlockComponent blk b
blockComponent
        stepIterator registry currentChunkInfo ith
        return $ IteratorResult b
 where
  ImmutableDBEnv{CodecConfig blk
codecConfig :: CodecConfig blk
codecConfig :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> CodecConfig blk
codecConfig, ChunkInfo
chunkInfo :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> ChunkInfo
chunkInfo :: ChunkInfo
chunkInfo, blk -> Bool
checkIntegrity :: blk -> Bool
checkIntegrity :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> blk -> Bool
checkIntegrity} = ImmutableDBEnv m blk
dbEnv

iteratorHasNextImpl ::
  IOLike m =>
  ImmutableDBEnv m blk ->
  IteratorHandle m blk h ->
  STM m (Maybe (RealPoint blk))
iteratorHasNextImpl :: forall (m :: * -> *) blk h.
IOLike m =>
ImmutableDBEnv m blk
-> IteratorHandle m blk h -> STM m (Maybe (RealPoint blk))
iteratorHasNextImpl ImmutableDBEnv{ChunkInfo
chunkInfo :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> ChunkInfo
chunkInfo :: ChunkInfo
chunkInfo} IteratorHandle{StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: forall (m :: * -> *) blk h.
IteratorHandle m blk h
-> StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState} =
  StrictTVar m (IteratorStateOrExhausted m blk h)
-> STM m (IteratorStateOrExhausted m blk h)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState STM m (IteratorStateOrExhausted m blk h)
-> (IteratorStateOrExhausted m blk h -> Maybe (RealPoint blk))
-> STM m (Maybe (RealPoint blk))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    IteratorStateOrExhausted m blk h
IteratorStateExhausted -> Maybe (RealPoint blk)
forall a. Maybe a
Nothing
    IteratorStateOpen IteratorState{NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries :: forall (m :: * -> *) blk h.
IteratorState m blk h -> NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries :: NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries} ->
      RealPoint blk -> Maybe (RealPoint blk)
forall a. a -> Maybe a
Just (SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
slotNo (Entry blk -> HeaderHash blk
forall blk. Entry blk -> HeaderHash blk
Secondary.headerHash Entry blk
nextEntry))
     where
      WithBlockSize SecondaryOffset
_ Entry blk
nextEntry NE.:| [WithBlockSize (Entry blk)]
_ = NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries

      slotNo :: SlotNo
      slotNo :: SlotNo
slotNo = ChunkInfo -> BlockOrEBB -> SlotNo
slotNoOfBlockOrEBB ChunkInfo
chunkInfo (Entry blk -> BlockOrEBB
forall blk. Entry blk -> BlockOrEBB
Secondary.blockOrEBB Entry blk
nextEntry)

iteratorCloseImpl ::
  (HasCallStack, IOLike m) =>
  IteratorHandle m blk h ->
  m ()
iteratorCloseImpl :: forall (m :: * -> *) blk h.
(HasCallStack, IOLike m) =>
IteratorHandle m blk h -> m ()
iteratorCloseImpl IteratorHandle{StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: forall (m :: * -> *) blk h.
IteratorHandle m blk h
-> StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState :: StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState} = do
  STM m (IteratorStateOrExhausted m blk h)
-> m (IteratorStateOrExhausted m blk h)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (IteratorStateOrExhausted m blk h)
-> STM m (IteratorStateOrExhausted m blk h)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState) m (IteratorStateOrExhausted m blk h)
-> (IteratorStateOrExhausted m blk h -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Already closed
    IteratorStateOrExhausted m blk h
IteratorStateExhausted -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IteratorStateOpen IteratorState{ResourceKey m
itsChunkKey :: forall (m :: * -> *) blk h. IteratorState m blk h -> ResourceKey m
itsChunkKey :: ResourceKey m
itsChunkKey} -> do
      -- First set it to Nothing to indicate it is closed, as the call to
      -- 'release' might fail, which would leave the iterator open in an
      -- invalid state.
      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (IteratorStateOrExhausted m blk h)
-> IteratorStateOrExhausted m blk h -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (IteratorStateOrExhausted m blk h)
ithVarState IteratorStateOrExhausted m blk h
forall (m :: * -> *) hash h. IteratorStateOrExhausted m hash h
IteratorStateExhausted
      -- TODO: we must use 'unsafeRelease' instead of 'release' because we
      -- might close the iterator from an /untracked thread/, i.e., a thread
      -- that was not spawned by the resource registry (or the thread that
      -- opened the resource registry) in which the handle was allocated.
      --
      -- This happens in the consensus tests (but not in the actual node),
      -- where the protocol threads that open iterators (BlockFetchServer
      -- and ChainSyncServer) are spawned using a different resource
      -- registry (A) than the one the ImmutableDB (and ChainDB) use (B).
      -- When the ChainDB is closed (by the thread that opened B), we're
      -- closing all open iterators, i.e., the iterators opened by the
      -- protocol threads. So we're releasing handles allocated in resource
      -- registry A from a thread tracked by resource registry B. See #1390.
      m (Maybe (Context m)) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe (Context m)) -> m ()) -> m (Maybe (Context m)) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceKey m -> m (Maybe (Context m))
forall (m :: * -> *).
(MonadMask m, MonadSTM m) =>
ResourceKey m -> m (Maybe (Context m))
unsafeRelease ResourceKey m
itsChunkKey

iteratorStateForChunk ::
  (HasCallStack, HasHeader blk, IOLike m) =>
  HasFS m h ->
  Index m blk h ->
  ResourceRegistry m ->
  CurrentChunkInfo ->
  -- | Hash of the end bound
  HeaderHash blk ->
  ChunkNo ->
  -- | Where to start in the secondary index
  SecondaryOffset ->
  -- | Whether the first expected block will be an EBB or not.
  IsEBB ->
  m (IteratorState m blk h)
iteratorStateForChunk :: forall blk (m :: * -> *) h.
(HasCallStack, HasHeader blk, IOLike m) =>
HasFS m h
-> Index m blk h
-> ResourceRegistry m
-> CurrentChunkInfo
-> HeaderHash blk
-> ChunkNo
-> SecondaryOffset
-> IsEBB
-> m (IteratorState m blk h)
iteratorStateForChunk
  HasFS m h
hasFS
  Index m blk h
index
  ResourceRegistry m
registry
  (CurrentChunkInfo ChunkNo
curChunk BlockOffset
curChunkOffset)
  HeaderHash blk
endHash
  ChunkNo
chunk
  SecondaryOffset
secondaryOffset
  IsEBB
firstIsEBB = do
    -- Open the chunk file. Allocate the handle in the registry so that it
    -- will be closed in case of an exception.
    (key, eHnd) <-
      ResourceRegistry m
-> (ResourceId -> m (Handle h))
-> (Handle h -> m ())
-> m (ResourceKey m, Handle h)
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
ResourceRegistry m
-> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a)
allocate
        ResourceRegistry m
registry
        (\ResourceId
_key -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> OpenMode -> m (Handle h)
hOpen (ChunkNo -> FsPath
fsPathChunkFile ChunkNo
chunk) OpenMode
ReadMode)
        HasCallStack => Handle h -> m ()
Handle h -> m ()
hClose

    -- If the last entry in @entries@ corresponds to the last block in the
    -- chunk, we cannot calculate the block size based on the next block.
    -- Instead, we calculate it based on the size of the chunk file.
    --
    -- IMPORTANT: for older chunks, this is fine, as the secondary index
    -- (entries) and the chunk file (size) are immutable. However, when doing
    -- this for the current chunk, there is a potential race condition between
    -- reading of the entries from the secondary index and obtaining the chunk
    -- file size: what if a new block was appended after reading the entries
    -- but before obtaining the chunk file size? Then the chunk file size will
    -- not correspond to the last entry we read, but to the block after it.
    -- Similarly if we switch the order of the two operations.
    --
    -- To avoid this race condition, we use the value of 'currentChunkOffset'
    -- from the state as the file size of the current chunk (stored in
    -- 'CurrentChunkInfo'). This value corresponds to the chunk file size at
    -- the time we /read the state/. We also know that the end bound of our
    -- iterator is always <= the tip from that same state, so all @entries@
    -- must be <= the tip from that state because we'll never stream beyond
    -- the tip. Remember that we only actually use the current chunk file size
    -- if the last entry we have read from the secondary index is the last
    -- entry in the file, in which case it would correspond to the tip from
    -- the state. In this case, the chunk file size (@curChunkOffset@) we are
    -- passed is consistent with the tip, as it was obtained from the same
    -- consistent state.
    chunkFileSize <-
      if chunk == curChunk
        then return (unBlockOffset curChunkOffset)
        else hGetSize eHnd

    entries <-
      Index.readAllEntries
        index
        secondaryOffset
        chunk
        ((== endHash) . Secondary.headerHash)
        chunkFileSize
        firstIsEBB

    case NE.nonEmpty entries of
      -- We still haven't encountered the end bound, so it cannot be
      -- that this non-empty chunk contains no entries <= the end bound.
      Maybe (NonEmpty (WithBlockSize (Entry blk)))
Nothing ->
        String -> m (IteratorState m blk h)
forall a. HasCallStack => String -> a
error
          String
"impossible: there must be entries according to the primary index"
      Just NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries ->
        IteratorState m blk h -> m (IteratorState m blk h)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
          IteratorState
            { itsChunk :: ChunkNo
itsChunk = ChunkNo
chunk
            , itsChunkHandle :: Handle h
itsChunkHandle = Handle h
eHnd
            , itsChunkKey :: ResourceKey m
itsChunkKey = ResourceKey m
key
            , -- Force so we don't store any thunks in the state
              itsChunkEntries :: NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries = NonEmpty (WithBlockSize (Entry blk))
-> NonEmpty (WithBlockSize (Entry blk))
forall (t :: * -> *) a. Foldable t => t a -> t a
forceElemsToWHNF NonEmpty (WithBlockSize (Entry blk))
itsChunkEntries
            }
   where
    HasFS{HasCallStack => FsPath -> OpenMode -> m (Handle h)
hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h)
hOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
hOpen, HasCallStack => Handle h -> m ()
hClose :: HasCallStack => Handle h -> m ()
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hClose, HasCallStack => Handle h -> m Word64
hGetSize :: HasCallStack => Handle h -> m Word64
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
hGetSize} = HasFS m h
hasFS

extractBlockComponent ::
  forall m blk b h.
  ( HasHeader blk
  , ReconstructNestedCtxt Header blk
  , DecodeDisk blk (Lazy.ByteString -> Either Plain.DecoderError blk)
  , DecodeDiskDep (NestedCtxt Header) blk
  , IOLike m
  ) =>
  HasFS m h ->
  ChunkInfo ->
  ChunkNo ->
  CodecConfig blk ->
  (blk -> Bool) ->
  Handle h ->
  WithBlockSize (Secondary.Entry blk) ->
  BlockComponent blk b ->
  m b
extractBlockComponent :: forall (m :: * -> *) blk b h.
(HasHeader blk, ReconstructNestedCtxt Header blk,
 DecodeDisk blk (ByteString -> Either DecoderError blk),
 DecodeDiskDep (NestedCtxt Header) blk, IOLike m) =>
HasFS m h
-> ChunkInfo
-> ChunkNo
-> CodecConfig blk
-> (blk -> Bool)
-> Handle h
-> WithBlockSize (Entry blk)
-> BlockComponent blk b
-> m b
extractBlockComponent
  HasFS m h
hasFS
  ChunkInfo
chunkInfo
  ChunkNo
chunk
  CodecConfig blk
ccfg
  blk -> Bool
checkIntegrity
  Handle h
eHnd
  (WithBlockSize SecondaryOffset
blockSize Entry blk
entry) = BlockComponent blk b -> m b
forall b'. BlockComponent blk b' -> m b'
go
   where
    go :: forall b'. BlockComponent blk b' -> m b'
    go :: forall b'. BlockComponent blk b' -> m b'
go = \case
      BlockComponent blk b'
GetHash -> b' -> m b'
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b'
HeaderHash blk
headerHash
      BlockComponent blk b'
GetSlot -> b' -> m b'
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b'
SlotNo
slotNo
      BlockComponent blk b'
GetIsEBB -> IsEBB -> m IsEBB
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsEBB -> m IsEBB) -> IsEBB -> m IsEBB
forall a b. (a -> b) -> a -> b
$ BlockOrEBB -> IsEBB
isBlockOrEBB BlockOrEBB
blockOrEBB
      BlockComponent blk b'
GetBlockSize -> SizeInBytes -> m SizeInBytes
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SizeInBytes -> m SizeInBytes) -> SizeInBytes -> m SizeInBytes
forall a b. (a -> b) -> a -> b
$ SecondaryOffset -> SizeInBytes
SizeInBytes SecondaryOffset
blockSize
      BlockComponent blk b'
GetHeaderSize -> b' -> m b'
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b' -> m b') -> b' -> m b'
forall a b. (a -> b) -> a -> b
$ Word16 -> b'
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> b') -> Word16 -> b'
forall a b. (a -> b) -> a -> b
$ HeaderSize -> Word16
Secondary.unHeaderSize HeaderSize
headerSize
      BlockComponent blk b'
GetRawBlock -> m b'
m ByteString
readBlock
      BlockComponent blk b'
GetRawHeader -> m b'
m ByteString
readHeader
      BlockComponent blk b'
GetNestedCtxt -> m b'
m (SomeSecond (NestedCtxt Header) blk)
readNestedCtxt
      BlockComponent blk b'
GetBlock -> do
        rawBlk <- BlockComponent blk ByteString -> m ByteString
forall b'. BlockComponent blk b' -> m b'
go BlockComponent blk ByteString
forall blk. BlockComponent blk ByteString
GetRawBlock
        parseBlock rawBlk
      BlockComponent blk b'
GetHeader -> do
        rawHdr <- BlockComponent blk ByteString -> m ByteString
forall b'. BlockComponent blk b' -> m b'
go BlockComponent blk ByteString
forall blk. BlockComponent blk ByteString
GetRawHeader
        ctxt <- readNestedCtxt
        parseHeader ctxt rawHdr
      BlockComponent blk b'
GetVerifiedBlock -> do
        blk <- BlockComponent blk blk -> m blk
forall b'. BlockComponent blk b' -> m b'
go BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock
        unless (checkIntegrity blk) $
          throwUnexpectedFailure $
            CorruptBlockError pt
        return blk
      GetPure b'
a -> b' -> m b'
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b'
a
      GetApply BlockComponent blk (a1 -> b')
f BlockComponent blk a1
bc -> BlockComponent blk (a1 -> b') -> m (a1 -> b')
forall b'. BlockComponent blk b' -> m b'
go BlockComponent blk (a1 -> b')
f m (a1 -> b') -> m a1 -> m b'
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockComponent blk a1 -> m a1
forall b'. BlockComponent blk b' -> m b'
go BlockComponent blk a1
bc

    Secondary.Entry
      { BlockOffset
blockOffset :: BlockOffset
blockOffset :: forall blk. Entry blk -> BlockOffset
blockOffset
      , CRC
checksum :: CRC
checksum :: forall blk. Entry blk -> CRC
checksum
      , HeaderHash blk
headerHash :: forall blk. Entry blk -> HeaderHash blk
headerHash :: HeaderHash blk
headerHash
      , HeaderSize
headerSize :: HeaderSize
headerSize :: forall blk. Entry blk -> HeaderSize
headerSize
      , HeaderOffset
headerOffset :: HeaderOffset
headerOffset :: forall blk. Entry blk -> HeaderOffset
headerOffset
      , BlockOrEBB
blockOrEBB :: forall blk. Entry blk -> BlockOrEBB
blockOrEBB :: BlockOrEBB
blockOrEBB
      } = Entry blk
entry

    slotNo :: SlotNo
    slotNo :: SlotNo
slotNo = ChunkInfo -> BlockOrEBB -> SlotNo
slotNoOfBlockOrEBB ChunkInfo
chunkInfo BlockOrEBB
blockOrEBB

    pt :: RealPoint blk
    pt :: RealPoint blk
pt = SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
slotNo HeaderHash blk
headerHash

    -- \| We don't rely on the position of the handle, we always use
    -- 'hGetExactlyAtCRC', i.e. @pread@ for reading from a given offset.
    --
    -- In case the requested chunk is the current chunk, we will be reading
    -- from the chunk file while we're also writing to it. Are we guaranteed
    -- to read what have written? Duncan says: this is guaranteed at the OS
    -- level (POSIX), but not for Haskell handles, which might perform other
    -- buffering. However, the 'HasFS' implementation we're using uses POSIX
    -- file handles ("Ouroboros.Consensus.Storage.IO") so we're safe (other
    -- implementations of the 'HasFS' API guarantee this too).
    readBlock :: m Lazy.ByteString
    readBlock :: m ByteString
readBlock = do
      (bl, checksum') <- HasFS m h -> Handle h -> Word64 -> AbsOffset -> m (ByteString, CRC)
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> AbsOffset -> m (ByteString, CRC)
hGetExactlyAtCRC HasFS m h
hasFS Handle h
eHnd Word64
size AbsOffset
offset
      checkChecksum chunkFile pt checksum checksum'
      return bl
     where
      size :: Word64
size = SecondaryOffset -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral SecondaryOffset
blockSize
      offset :: AbsOffset
offset = Word64 -> AbsOffset
AbsOffset (Word64 -> AbsOffset) -> Word64 -> AbsOffset
forall a b. (a -> b) -> a -> b
$ BlockOffset -> Word64
Secondary.unBlockOffset BlockOffset
blockOffset
      chunkFile :: FsPath
chunkFile = ChunkNo -> FsPath
fsPathChunkFile ChunkNo
chunk

    -- \| We don't rely on the position of the handle, we always use
    -- 'hGetExactlyAt', i.e. @pread@ for reading from a given offset.
    readHeader :: m Lazy.ByteString
    readHeader :: m ByteString
readHeader =
      -- We cannot check the checksum in this case, as we're not reading the
      -- whole block
      HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
hGetExactlyAt HasFS m h
hasFS Handle h
eHnd Word64
size AbsOffset
offset
     where
      size :: Word64
size = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word64) -> Word16 -> Word64
forall a b. (a -> b) -> a -> b
$ HeaderSize -> Word16
Secondary.unHeaderSize HeaderSize
headerSize
      offset :: AbsOffset
offset =
        Word64 -> AbsOffset
AbsOffset (Word64 -> AbsOffset) -> Word64 -> AbsOffset
forall a b. (a -> b) -> a -> b
$
          (BlockOffset -> Word64
Secondary.unBlockOffset BlockOffset
blockOffset)
            Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HeaderOffset -> Word16
Secondary.unHeaderOffset HeaderOffset
headerOffset)

    readNestedCtxt :: m (SomeSecond (NestedCtxt Header) blk)
    readNestedCtxt :: m (SomeSecond (NestedCtxt Header) blk)
readNestedCtxt = do
      bytes <-
        ByteString -> ShortByteString
Short.toShort (ByteString -> ShortByteString)
-> (ByteString -> ByteString) -> ByteString -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Lazy.toStrict
          (ByteString -> ShortByteString)
-> m ByteString -> m ShortByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h -> Handle h -> Word64 -> AbsOffset -> m ByteString
hGetExactlyAt HasFS m h
hasFS Handle h
eHnd Word64
size AbsOffset
offset
      return $ reconstructNestedCtxt p bytes (SizeInBytes blockSize)
     where
      p :: Proxy (Header blk)
      p :: Proxy (Header blk)
p = Proxy (Header blk)
forall {k} (t :: k). Proxy t
Proxy

      size :: Word64
size = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PrefixLen -> Word8
getPrefixLen (Proxy (Header blk) -> PrefixLen
forall (proxy :: * -> *). proxy (Header blk) -> PrefixLen
forall (f :: * -> *) blk (proxy :: * -> *).
ReconstructNestedCtxt f blk =>
proxy (f blk) -> PrefixLen
reconstructPrefixLen Proxy (Header blk)
p))
      offset :: AbsOffset
offset = Word64 -> AbsOffset
AbsOffset (Word64 -> AbsOffset) -> Word64 -> AbsOffset
forall a b. (a -> b) -> a -> b
$ BlockOffset -> Word64
Secondary.unBlockOffset BlockOffset
blockOffset

    parseBlock :: Lazy.ByteString -> m blk
    parseBlock :: ByteString -> m blk
parseBlock ByteString
bytes =
      ByteString
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError blk)
-> m blk
forall b''.
ByteString
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError b'')
-> m b''
throwParseErrors ByteString
bytes (Either
   DeserialiseFailure
   (ByteString, ByteString -> Either DecoderError blk)
 -> m blk)
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError blk)
-> m blk
forall a b. (a -> b) -> a -> b
$
        (forall s. Decoder s (ByteString -> Either DecoderError blk))
-> ByteString
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError blk)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes (CodecConfig blk
-> forall s. Decoder s (ByteString -> Either DecoderError blk)
forall blk a.
DecodeDisk blk a =>
CodecConfig blk -> forall s. Decoder s a
decodeDisk CodecConfig blk
ccfg) ByteString
bytes

    parseHeader ::
      SomeSecond (NestedCtxt Header) blk ->
      Lazy.ByteString ->
      m (Header blk)
    parseHeader :: SomeSecond (NestedCtxt Header) blk -> ByteString -> m (Header blk)
parseHeader (SomeSecond NestedCtxt Header blk b
ctxt) ByteString
bytes =
      ByteString
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError (Header blk))
-> m (Header blk)
forall b''.
ByteString
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError b'')
-> m b''
throwParseErrors ByteString
bytes (Either
   DeserialiseFailure
   (ByteString, ByteString -> Either DecoderError (Header blk))
 -> m (Header blk))
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError (Header blk))
-> m (Header blk)
forall a b. (a -> b) -> a -> b
$
        (forall s.
 Decoder s (ByteString -> Either DecoderError (Header blk)))
-> ByteString
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError (Header blk))
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes
          ((ByteString -> b) -> ByteString -> Either DecoderError (Header blk)
aux ((ByteString -> b)
 -> ByteString -> Either DecoderError (Header blk))
-> Decoder s (ByteString -> b)
-> Decoder s (ByteString -> Either DecoderError (Header blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodecConfig blk
-> NestedCtxt Header blk b -> forall s. Decoder s (ByteString -> b)
forall a.
CodecConfig blk
-> NestedCtxt Header blk a -> forall s. Decoder s (ByteString -> a)
forall (f :: * -> * -> *) blk a.
DecodeDiskDep f blk =>
CodecConfig blk -> f blk a -> forall s. Decoder s (ByteString -> a)
decodeDiskDep CodecConfig blk
ccfg NestedCtxt Header blk b
ctxt)
          ByteString
bytes
     where
      aux :: (ByteString -> b) -> ByteString -> Either DecoderError (Header blk)
aux = \ByteString -> b
f -> Header blk -> Either DecoderError (Header blk)
forall a b. b -> Either a b
Right (Header blk -> Either DecoderError (Header blk))
-> (ByteString -> Header blk)
-> ByteString
-> Either DecoderError (Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DepPair (NestedCtxt Header blk) -> Header blk
forall (f :: * -> *) blk.
HasNestedContent f blk =>
DepPair (NestedCtxt f blk) -> f blk
nest (DepPair (NestedCtxt Header blk) -> Header blk)
-> (ByteString -> DepPair (NestedCtxt Header blk))
-> ByteString
-> Header blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NestedCtxt Header blk b -> b -> DepPair (NestedCtxt Header blk)
forall (f :: * -> *) a. f a -> a -> DepPair f
DepPair NestedCtxt Header blk b
ctxt (b -> DepPair (NestedCtxt Header blk))
-> (ByteString -> b)
-> ByteString
-> DepPair (NestedCtxt Header blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> b
f

    throwParseErrors ::
      forall b''.
      Lazy.ByteString ->
      Either CBOR.DeserialiseFailure (Lazy.ByteString, Lazy.ByteString -> Either Plain.DecoderError b'') ->
      m b''
    throwParseErrors :: forall b''.
ByteString
-> Either
     DeserialiseFailure
     (ByteString, ByteString -> Either DecoderError b'')
-> m b''
throwParseErrors ByteString
fullBytes = \case
      Right (ByteString
trailing, ByteString -> Either DecoderError b''
f)
        | ByteString -> Bool
Lazy.null ByteString
trailing ->
            case ByteString -> Either DecoderError b''
f ByteString
fullBytes of
              Left DecoderError
err ->
                UnexpectedFailure blk -> m b''
forall blk (m :: * -> *) a.
(StandardHash blk, Typeable blk, MonadThrow m) =>
UnexpectedFailure blk -> m a
throwUnexpectedFailure (UnexpectedFailure blk -> m b'') -> UnexpectedFailure blk -> m b''
forall a b. (a -> b) -> a -> b
$
                  FsPath -> RealPoint blk -> DecoderError -> UnexpectedFailure blk
forall blk.
FsPath -> RealPoint blk -> DecoderError -> UnexpectedFailure blk
ParseError
                    (ChunkNo -> FsPath
fsPathChunkFile ChunkNo
chunk)
                    RealPoint blk
pt
                    (Text -> DeserialiseFailure -> DecoderError
Plain.DecoderErrorDeserialiseFailure (String -> Text
Text.pack String
"") (DeserialiseFailure -> DecoderError)
-> DeserialiseFailure -> DecoderError
forall a b. (a -> b) -> a -> b
$ ByteOffset -> String -> DeserialiseFailure
CBOR.DeserialiseFailure ByteOffset
0 (DecoderError -> String
forall a. Show a => a -> String
show DecoderError
err))
              Right b''
result -> b'' -> m b''
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b''
result
        | Bool
otherwise ->
            UnexpectedFailure blk -> m b''
forall blk (m :: * -> *) a.
(StandardHash blk, Typeable blk, MonadThrow m) =>
UnexpectedFailure blk -> m a
throwUnexpectedFailure (UnexpectedFailure blk -> m b'') -> UnexpectedFailure blk -> m b''
forall a b. (a -> b) -> a -> b
$
              FsPath -> RealPoint blk -> ByteString -> UnexpectedFailure blk
forall blk.
FsPath -> RealPoint blk -> ByteString -> UnexpectedFailure blk
TrailingDataError (ChunkNo -> FsPath
fsPathChunkFile ChunkNo
chunk) RealPoint blk
pt ByteString
trailing
      Left DeserialiseFailure
err ->
        UnexpectedFailure blk -> m b''
forall blk (m :: * -> *) a.
(StandardHash blk, Typeable blk, MonadThrow m) =>
UnexpectedFailure blk -> m a
throwUnexpectedFailure (UnexpectedFailure blk -> m b'') -> UnexpectedFailure blk -> m b''
forall a b. (a -> b) -> a -> b
$
          FsPath -> RealPoint blk -> DecoderError -> UnexpectedFailure blk
forall blk.
FsPath -> RealPoint blk -> DecoderError -> UnexpectedFailure blk
ParseError (ChunkNo -> FsPath
fsPathChunkFile ChunkNo
chunk) RealPoint blk
pt (Text -> DeserialiseFailure -> DecoderError
Plain.DecoderErrorDeserialiseFailure (String -> Text
Text.pack String
"") DeserialiseFailure
err)

-- | Find a filled slot, starting from the target slot and going forwards in the ImmutableDB.
--
--   Because of EBBs, the new resulting slot may be filled with two blocks. This implementation
--   returns the first one, even if it's an EBB. On mainnet, no new EBBs will be produced; hence,
--   this implementation will always return a regular block.
seekBlockForwards ::
  forall m blk h.
  ( IOLike m
  , HasHeader blk
  , HasCallStack
  ) =>
  ImmutableDBEnv m blk ->
  OpenState m blk h ->
  Tip blk ->
  RealPoint blk ->
  m (Either SeekBlockError (RealPoint blk))
seekBlockForwards :: forall (m :: * -> *) blk h.
(IOLike m, HasHeader blk, HasCallStack) =>
ImmutableDBEnv m blk
-> OpenState m blk h
-> Tip blk
-> RealPoint blk
-> m (Either SeekBlockError (RealPoint blk))
seekBlockForwards
  ImmutableDBEnv{ChunkInfo
chunkInfo :: forall (m :: * -> *) blk. ImmutableDBEnv m blk -> ChunkInfo
chunkInfo :: ChunkInfo
chunkInfo}
  OpenState{Index m blk h
currentIndex :: forall (m :: * -> *) blk h. OpenState m blk h -> Index m blk h
currentIndex :: Index m blk h
currentIndex}
  Tip blk
immutableTip = RealPoint blk -> m (Either SeekBlockError (RealPoint blk))
go
   where
    go :: RealPoint blk -> m (Either SeekBlockError (RealPoint blk))
go targetPoint :: RealPoint blk
targetPoint@(RealPoint SlotNo
slot HeaderHash blk
hash) =
      ExceptT
  (MissingBlock blk)
  m
  (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
-> m (Either
        (MissingBlock blk)
        (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
forall (m :: * -> *) blk h.
(HasCallStack, IOLike m, HasHeader blk) =>
ChunkInfo
-> Index m blk h
-> WithOrigin (Tip blk)
-> RealPoint blk
-> ExceptT
     (MissingBlock blk)
     m
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
getSlotInfo ChunkInfo
chunkInfo Index m blk h
currentIndex (Tip blk -> WithOrigin (Tip blk)
forall t. t -> WithOrigin t
NotOrigin Tip blk
immutableTip) RealPoint blk
targetPoint) m (Either
     (MissingBlock blk)
     (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset))
-> (Either
      (MissingBlock blk)
      (ChunkSlot, (Entry blk, BlockSize), SecondaryOffset)
    -> m (Either SeekBlockError (RealPoint blk)))
-> m (Either SeekBlockError (RealPoint blk))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left NewerThanTip{} ->
          -- Stop if the target slot is newer then tip
          Either SeekBlockError (RealPoint blk)
-> m (Either SeekBlockError (RealPoint blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SeekBlockError (RealPoint blk)
 -> m (Either SeekBlockError (RealPoint blk)))
-> (SeekBlockError -> Either SeekBlockError (RealPoint blk))
-> SeekBlockError
-> m (Either SeekBlockError (RealPoint blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeekBlockError -> Either SeekBlockError (RealPoint blk)
forall a b. a -> Either a b
Left (SeekBlockError -> m (Either SeekBlockError (RealPoint blk)))
-> SeekBlockError -> m (Either SeekBlockError (RealPoint blk))
forall a b. (a -> b) -> a -> b
$ SeekBlockError
TargetNewerThanTip
        Left (EmptySlot{}) -> do
          if SlotNo
slot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot (RealPoint blk -> SlotNo)
-> (Tip blk -> RealPoint blk) -> Tip blk -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tip blk -> RealPoint blk
forall blk. Tip blk -> RealPoint blk
tipToRealPoint (Tip blk -> SlotNo) -> Tip blk -> SlotNo
forall a b. (a -> b) -> a -> b
$ Tip blk
immutableTip)
            -- otherwise, skip this slot and repeat with the next one
            then RealPoint blk -> m (Either SeekBlockError (RealPoint blk))
go (SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint (SlotNo
slot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1) HeaderHash blk
hash)
            -- we're past the immutable tip and did not find any blocks, so we can only return the tip.
            -- Note that this case is impossible, as the we would not get 'EmptySlot' from 'getSlotInfo',
            -- but we still return the tip for completeness' sake.
            else Either SeekBlockError (RealPoint blk)
-> m (Either SeekBlockError (RealPoint blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SeekBlockError (RealPoint blk)
 -> m (Either SeekBlockError (RealPoint blk)))
-> (RealPoint blk -> Either SeekBlockError (RealPoint blk))
-> RealPoint blk
-> m (Either SeekBlockError (RealPoint blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> Either SeekBlockError (RealPoint blk)
forall a b. b -> Either a b
Right (RealPoint blk -> m (Either SeekBlockError (RealPoint blk)))
-> RealPoint blk -> m (Either SeekBlockError (RealPoint blk))
forall a b. (a -> b) -> a -> b
$ Tip blk -> RealPoint blk
forall blk. Tip blk -> RealPoint blk
tipToRealPoint Tip blk
immutableTip
        Left (WrongHash RealPoint blk
_ NonEmpty (HeaderHash blk)
hashes) ->
          case NonEmpty (HeaderHash blk)
hashes of
            -- always return the first found block, even if it's an EBB
            (HeaderHash blk
actualHash NE.:| [HeaderHash blk]
_) ->
              Either SeekBlockError (RealPoint blk)
-> m (Either SeekBlockError (RealPoint blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SeekBlockError (RealPoint blk)
 -> m (Either SeekBlockError (RealPoint blk)))
-> (RealPoint blk -> Either SeekBlockError (RealPoint blk))
-> RealPoint blk
-> m (Either SeekBlockError (RealPoint blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> Either SeekBlockError (RealPoint blk)
forall a b. b -> Either a b
Right (RealPoint blk -> m (Either SeekBlockError (RealPoint blk)))
-> RealPoint blk -> m (Either SeekBlockError (RealPoint blk))
forall a b. (a -> b) -> a -> b
$ SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
targetPoint) HeaderHash blk
actualHash
        Right{} ->
          Either SeekBlockError (RealPoint blk)
-> m (Either SeekBlockError (RealPoint blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SeekBlockError (RealPoint blk)
 -> m (Either SeekBlockError (RealPoint blk)))
-> (RealPoint blk -> Either SeekBlockError (RealPoint blk))
-> RealPoint blk
-> m (Either SeekBlockError (RealPoint blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealPoint blk -> Either SeekBlockError (RealPoint blk)
forall a b. b -> Either a b
Right (RealPoint blk -> m (Either SeekBlockError (RealPoint blk)))
-> RealPoint blk -> m (Either SeekBlockError (RealPoint blk))
forall a b. (a -> b) -> a -> b
$ RealPoint blk
targetPoint

-- | Query the immutable DB to for a block at the target slot. If the target slot is empty,
--   return the block at the next occupied slot.
--
--   See the haddock of 'ChainDB.getBlockAtOrAfterPoint_' for more details.
getBlockAtOrAfterPointImpl ::
  forall m blk.
  ( IOLike m
  , HasHeader blk
  , HasCallStack
  ) =>
  ImmutableDBEnv m blk ->
  (RealPoint blk) ->
  m (Either SeekBlockError (RealPoint blk))
getBlockAtOrAfterPointImpl :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, HasCallStack) =>
ImmutableDBEnv m blk
-> RealPoint blk -> m (Either SeekBlockError (RealPoint blk))
getBlockAtOrAfterPointImpl ImmutableDBEnv m blk
dbEnv RealPoint blk
targetPoint =
  ImmutableDBEnv m blk
-> (forall h.
    HasFS m h
    -> OpenState m blk h -> m (Either SeekBlockError (RealPoint blk)))
-> m (Either SeekBlockError (RealPoint blk))
forall (m :: * -> *) blk r.
(HasCallStack, IOLike m, StandardHash blk, Typeable blk) =>
ImmutableDBEnv m blk
-> (forall h. HasFS m h -> OpenState m blk h -> m r) -> m r
withOpenState ImmutableDBEnv m blk
dbEnv ((forall h.
  HasFS m h
  -> OpenState m blk h -> m (Either SeekBlockError (RealPoint blk)))
 -> m (Either SeekBlockError (RealPoint blk)))
-> (forall h.
    HasFS m h
    -> OpenState m blk h -> m (Either SeekBlockError (RealPoint blk)))
-> m (Either SeekBlockError (RealPoint blk))
forall a b. (a -> b) -> a -> b
$ \HasFS m h
_hasFS dbState :: OpenState m blk h
dbState@OpenState{WithOrigin (Tip blk)
currentTip :: forall (m :: * -> *) blk h.
OpenState m blk h -> WithOrigin (Tip blk)
currentTip :: WithOrigin (Tip blk)
currentTip} -> do
    case WithOrigin (Tip blk)
currentTip of
      WithOrigin (Tip blk)
Origin -> Either SeekBlockError (RealPoint blk)
-> m (Either SeekBlockError (RealPoint blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SeekBlockError (RealPoint blk)
 -> m (Either SeekBlockError (RealPoint blk)))
-> (SeekBlockError -> Either SeekBlockError (RealPoint blk))
-> SeekBlockError
-> m (Either SeekBlockError (RealPoint blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SeekBlockError -> Either SeekBlockError (RealPoint blk)
forall a b. a -> Either a b
Left (SeekBlockError -> m (Either SeekBlockError (RealPoint blk)))
-> SeekBlockError -> m (Either SeekBlockError (RealPoint blk))
forall a b. (a -> b) -> a -> b
$ SeekBlockError
TipIsOrigin
      At Tip blk
tip -> ImmutableDBEnv m blk
-> OpenState m blk h
-> Tip blk
-> RealPoint blk
-> m (Either SeekBlockError (RealPoint blk))
forall (m :: * -> *) blk h.
(IOLike m, HasHeader blk, HasCallStack) =>
ImmutableDBEnv m blk
-> OpenState m blk h
-> Tip blk
-> RealPoint blk
-> m (Either SeekBlockError (RealPoint blk))
seekBlockForwards ImmutableDBEnv m blk
dbEnv OpenState m blk h
dbState Tip blk
tip RealPoint blk
targetPoint