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

import           Cardano.Prelude (forceElemsToWHNF)
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           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 -> 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 -> 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 -> 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
  -> WithOrigin (Tip blk)  -- ^ Current tip
  -> 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 -> 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 -> 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 -> 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
  -> HeaderHash blk
     -- ^ Hash of the end bound
  -> ChunkNo
  -> SecondaryOffset
     -- ^ Where to start in the secondary index
  -> IsEBB
     -- ^ Whether the first expected block will be an EBB or not.
  -> 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 -> 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 -> 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 -> blk)
-> m blk
forall b'.
ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> b') -> m b'
throwParseErrors ByteString
bytes (Either DeserialiseFailure (ByteString, ByteString -> blk)
 -> m blk)
-> Either DeserialiseFailure (ByteString, ByteString -> blk)
-> m blk
forall a b. (a -> b) -> a -> b
$
        (forall s. Decoder s (ByteString -> blk))
-> ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> blk)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes (CodecConfig blk -> forall s. Decoder s (ByteString -> 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 -> Header blk)
-> m (Header blk)
forall b'.
ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> b') -> m b'
throwParseErrors ByteString
bytes (Either DeserialiseFailure (ByteString, ByteString -> Header blk)
 -> m (Header blk))
-> Either DeserialiseFailure (ByteString, ByteString -> Header blk)
-> m (Header blk)
forall a b. (a -> b) -> a -> b
$
        (forall s. Decoder s (ByteString -> Header blk))
-> ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> Header blk)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
CBOR.deserialiseFromBytes
          ((\ByteString -> b
f -> 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) ((ByteString -> b) -> ByteString -> Header blk)
-> Decoder s (ByteString -> b)
-> Decoder s (ByteString -> 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

    throwParseErrors ::
         forall b'.
         Lazy.ByteString
      -> Either CBOR.DeserialiseFailure (Lazy.ByteString, Lazy.ByteString -> b')
      -> m b'
    throwParseErrors :: forall b'.
ByteString
-> Either DeserialiseFailure (ByteString, ByteString -> b') -> m b'
throwParseErrors ByteString
fullBytes = \case
        Right (ByteString
trailing, ByteString -> b'
f)
          | ByteString -> Bool
Lazy.null ByteString
trailing
          -> 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
$ ByteString -> b'
f ByteString
fullBytes
          | 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 -> DeserialiseFailure -> UnexpectedFailure blk
forall blk.
FsPath
-> RealPoint blk -> DeserialiseFailure -> UnexpectedFailure blk
ParseError (ChunkNo -> FsPath
fsPathChunkFile ChunkNo
chunk) RealPoint blk
pt DeserialiseFailure
err