{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DeriveTraversable   #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE TypeApplications    #-}
module Ouroboros.Consensus.Storage.ImmutableDB.API (
    -- * API
    ImmutableDB (..)
    -- * Iterator API
  , Iterator (..)
  , IteratorResult (..)
  , iteratorToList
  , traverseIterator
    -- * Types
  , CompareTip (..)
  , Tip (..)
  , blockToTip
  , tipToAnchor
  , tipToPoint
  , tipToRealPoint
    -- * Errors
  , ApiMisuse (..)
  , ImmutableDBError (..)
  , MissingBlock (..)
  , UnexpectedFailure (..)
  , missingBlockPoint
  , throwApiMisuse
  , throwUnexpectedFailure
    -- * Wrappers that preserve 'HasCallStack'
  , appendBlock
  , closeDB
  , getBlockComponent
  , getTip
  , stream
    -- * Derived functionality
  , getKnownBlockComponent
  , getTipAnchor
  , getTipPoint
  , getTipSlot
  , hasBlock
  , streamAfterKnownPoint
  , streamAfterPoint
  , streamAll
  , withDB
  ) where

import qualified Codec.CBOR.Read as CBOR
import           Control.Monad.Except (ExceptT (..), lift, runExceptT,
                     throwError)
import qualified Data.ByteString.Lazy as Lazy
import           Data.Either (isRight)
import           Data.Function (on)
import           Data.List.NonEmpty (NonEmpty)
import           Data.Typeable (Typeable)
import           GHC.Generics (Generic)
import           NoThunks.Class (OnlyCheckWhnfNamed (..))

import qualified Ouroboros.Network.AnchoredFragment as AF

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

import           Ouroboros.Consensus.Storage.Common
import           Ouroboros.Consensus.Storage.FS.API.Types (FsError, FsPath)
import           Ouroboros.Consensus.Storage.FS.CRC (CRC)

{-------------------------------------------------------------------------------
  API
-------------------------------------------------------------------------------}

-- | API for the 'ImmutableDB'.
--
-- The 'ImmutableDB' stores blocks in 'SlotNo's. Nevertheless, lookups use
-- 'RealPoint', primarily because Epoch Boundary Blocks (EBBs) have the same
-- 'SlotNo' as the regular block after them (unless that slot is empty), so that
-- we have to use the hash of the block to distinguish the two (hence
-- 'RealPoint'). But also to avoid reading the wrong block, i.e., when we expect
-- a block with a different hash.
--
-- The database is append-only, so you cannot append a block to a slot in the
-- past. You can, however, skip slots, e.g., append to slot 0 and then to slot
-- 5, but afterwards, you can no longer append to slots 1-4. You can only store
-- at most one block in each slot, except for EBBs, which are stored separately,
-- at the start of each epoch/chunk.
--
-- The block stored in a slot can be queried with 'getBlockComponent'. Block
-- components can also be streamed using 'Iterator's, see 'stream'.
--
-- The 'Tip' of the database can be queried with 'getTip'. This tip will
-- always point to a filled slot or an EBB that is present.
--
-- The database can be explicitly closed, but can also be automatically closed
-- in case of an 'UnexpectedFailure'.
data ImmutableDB m blk = ImmutableDB {
      -- | Close the database.
      --
      -- Idempotent.
      --
      -- __Note__: Use 'withDB' instead of this function.
      ImmutableDB m blk -> HasCallStack => m ()
closeDB_ :: HasCallStack => m ()

      -- | Return the tip of the database.
      --
      -- The tip of the database will never point to an unfilled slot or missing
      -- EBB.
      --
      -- Throws a 'ClosedDBError' if the database is closed.
    , ImmutableDB m blk -> HasCallStack => STM m (WithOrigin (Tip blk))
getTip_ :: HasCallStack => STM m (WithOrigin (Tip blk))

      -- | Get the block component of the block with the given 'Point'.
      --
      -- The hash of the point is used to distinguish a potential EBB from the
      -- regular block in the same slot.
      --
      -- Returns a 'MissingBlockError' if no block was stored with the given
      -- 'Point', either because the slot was empty or because the block stored
      -- with that slot had a different hash.
      --
      -- Throws a 'ClosedDBError' if the database is closed.
    , ImmutableDB m blk
-> forall b.
   HasCallStack =>
   BlockComponent blk b
   -> RealPoint blk -> m (Either (MissingBlock blk) b)
getBlockComponent_ ::
           forall b. HasCallStack
        => BlockComponent blk b -> RealPoint blk -> m (Either (MissingBlock blk) b)

      -- | Appends a block to the ImmutableDB.
      --
      -- Throws an 'AppendBlockNotNewerThanTipError' if the given slot is <= the
      -- result of 'getTip'.
      --
      -- Throws a 'ClosedDBError' if the database is closed.
    , ImmutableDB m blk -> HasCallStack => blk -> m ()
appendBlock_
        :: HasCallStack => blk -> m ()

      -- | Return an 'Iterator' to efficiently stream blocks from the
      -- ImmutableDB.
      --
      -- Throws an 'InvalidIteratorRangeError' if the start of the range is
      -- greater than the end of the range.
      --
      -- NOTE: 'MissingBlock' is returned, but 'InvalidIteratorRangeError' is
      -- thrown. This is because the former is expected to occur during normal
      -- operation: a node serving blocks might get requests to stream blocks
      -- that are not in the database. The latter exception indicates incorrect
      -- usage and should not happen during normal operation.
      --
      -- Throws a 'ClosedDBError' if the database is closed.
      --
      -- The iterator is automatically closed when exhausted, and can be
      -- prematurely closed with 'iteratorClose'.
    , ImmutableDB m blk
-> forall b.
   HasCallStack =>
   ResourceRegistry m
   -> BlockComponent blk b
   -> StreamFrom blk
   -> StreamTo blk
   -> m (Either (MissingBlock blk) (Iterator m blk b))
stream_
        :: forall b. HasCallStack
        => ResourceRegistry m
        -> BlockComponent blk b
        -> StreamFrom blk
        -> StreamTo   blk
        -> m (Either (MissingBlock blk) (Iterator m blk b))
    }
  deriving Context -> ImmutableDB m blk -> IO (Maybe ThunkInfo)
Proxy (ImmutableDB m blk) -> String
(Context -> ImmutableDB m blk -> IO (Maybe ThunkInfo))
-> (Context -> ImmutableDB m blk -> IO (Maybe ThunkInfo))
-> (Proxy (ImmutableDB m blk) -> String)
-> NoThunks (ImmutableDB m blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk.
Context -> ImmutableDB m blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk. Proxy (ImmutableDB m blk) -> String
showTypeOf :: Proxy (ImmutableDB m blk) -> String
$cshowTypeOf :: forall (m :: * -> *) blk. Proxy (ImmutableDB m blk) -> String
wNoThunks :: Context -> ImmutableDB m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk.
Context -> ImmutableDB m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> ImmutableDB m blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (m :: * -> *) blk.
Context -> ImmutableDB m blk -> IO (Maybe ThunkInfo)
NoThunks via OnlyCheckWhnfNamed "ImmutableDB" (ImmutableDB m blk)

{-------------------------------------------------------------------------------
  Iterator API
-------------------------------------------------------------------------------}

-- | An 'Iterator' is a handle which can be used to efficiently stream block
-- components from the ImmutableDB.
data Iterator m blk b = Iterator {
      -- | Steps an 'Iterator' yielding an 'IteratorResult'.
      --
      -- After returning the block component as an 'IteratorResult', the
      -- iterator is advanced to the next non-empty slot or non-empty EBB.
      --
      -- Throws a 'ClosedDBError' if the database is closed.
      --
      -- The iterator is automatically closed when exhausted
      -- ('IteratorExhausted'), and can be prematurely closed with
      -- 'iteratorClose'.
      Iterator m blk b -> HasCallStack => m (IteratorResult b)
iteratorNext    :: HasCallStack => m (IteratorResult b)

      -- | Return the point of the next block to stream, if there is one. Return
      -- 'Nothing' if not.
      --
      -- This operation is idempotent.
    , Iterator m blk b -> HasCallStack => STM m (Maybe (RealPoint blk))
iteratorHasNext :: HasCallStack => STM m (Maybe (RealPoint blk))

      -- | Dispose of the 'Iterator' by closing any open handles.
      --
      -- Idempotent operation.
    , Iterator m blk b -> HasCallStack => m ()
iteratorClose   :: HasCallStack => m ()
    }
  deriving (a -> Iterator m blk b -> Iterator m blk a
(a -> b) -> Iterator m blk a -> Iterator m blk b
(forall a b. (a -> b) -> Iterator m blk a -> Iterator m blk b)
-> (forall a b. a -> Iterator m blk b -> Iterator m blk a)
-> Functor (Iterator m blk)
forall a b. a -> Iterator m blk b -> Iterator m blk a
forall a b. (a -> b) -> Iterator m blk a -> Iterator m blk b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) blk a b.
Functor m =>
a -> Iterator m blk b -> Iterator m blk a
forall (m :: * -> *) blk a b.
Functor m =>
(a -> b) -> Iterator m blk a -> Iterator m blk b
<$ :: a -> Iterator m blk b -> Iterator m blk a
$c<$ :: forall (m :: * -> *) blk a b.
Functor m =>
a -> Iterator m blk b -> Iterator m blk a
fmap :: (a -> b) -> Iterator m blk a -> Iterator m blk b
$cfmap :: forall (m :: * -> *) blk a b.
Functor m =>
(a -> b) -> Iterator m blk a -> Iterator m blk b
Functor)
  deriving Context -> Iterator m blk b -> IO (Maybe ThunkInfo)
Proxy (Iterator m blk b) -> String
(Context -> Iterator m blk b -> IO (Maybe ThunkInfo))
-> (Context -> Iterator m blk b -> IO (Maybe ThunkInfo))
-> (Proxy (Iterator m blk b) -> String)
-> NoThunks (Iterator m blk b)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk b.
Context -> Iterator m blk b -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk b. Proxy (Iterator m blk b) -> String
showTypeOf :: Proxy (Iterator m blk b) -> String
$cshowTypeOf :: forall (m :: * -> *) blk b. Proxy (Iterator m blk b) -> String
wNoThunks :: Context -> Iterator m blk b -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk b.
Context -> Iterator m blk b -> IO (Maybe ThunkInfo)
noThunks :: Context -> Iterator m blk b -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (m :: * -> *) blk b.
Context -> Iterator m blk b -> IO (Maybe ThunkInfo)
NoThunks via OnlyCheckWhnfNamed "Iterator" (Iterator m blk b)

-- | Variant of 'traverse' instantiated to @'Iterator' m blk m@ that executes
-- the monadic function when calling 'iteratorNext'.
traverseIterator
  :: Monad m
  => (b -> m b')
  -> Iterator m blk b
  -> Iterator m blk b'
traverseIterator :: (b -> m b') -> Iterator m blk b -> Iterator m blk b'
traverseIterator b -> m b'
f Iterator m blk b
itr = Iterator :: forall (m :: * -> *) blk b.
(HasCallStack => m (IteratorResult b))
-> (HasCallStack => STM m (Maybe (RealPoint blk)))
-> (HasCallStack => m ())
-> Iterator m blk b
Iterator{
      iteratorNext :: HasCallStack => m (IteratorResult b')
iteratorNext    = Iterator m blk b -> HasCallStack => m (IteratorResult b)
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m (IteratorResult b)
iteratorNext    Iterator m blk b
itr m (IteratorResult b)
-> (IteratorResult b -> m (IteratorResult b'))
-> m (IteratorResult b')
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> m b') -> IteratorResult b -> m (IteratorResult b')
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse b -> m b'
f
    , iteratorHasNext :: HasCallStack => STM m (Maybe (RealPoint blk))
iteratorHasNext = Iterator m blk b -> HasCallStack => STM m (Maybe (RealPoint blk))
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => STM m (Maybe (RealPoint blk))
iteratorHasNext Iterator m blk b
itr
    , iteratorClose :: HasCallStack => m ()
iteratorClose   = Iterator m blk b -> HasCallStack => m ()
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m ()
iteratorClose   Iterator m blk b
itr
    }

-- | The result of stepping an 'Iterator'.
data IteratorResult b
  = IteratorExhausted
  | IteratorResult b
  deriving (Int -> IteratorResult b -> ShowS
[IteratorResult b] -> ShowS
IteratorResult b -> String
(Int -> IteratorResult b -> ShowS)
-> (IteratorResult b -> String)
-> ([IteratorResult b] -> ShowS)
-> Show (IteratorResult b)
forall b. Show b => Int -> IteratorResult b -> ShowS
forall b. Show b => [IteratorResult b] -> ShowS
forall b. Show b => IteratorResult b -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IteratorResult b] -> ShowS
$cshowList :: forall b. Show b => [IteratorResult b] -> ShowS
show :: IteratorResult b -> String
$cshow :: forall b. Show b => IteratorResult b -> String
showsPrec :: Int -> IteratorResult b -> ShowS
$cshowsPrec :: forall b. Show b => Int -> IteratorResult b -> ShowS
Show, IteratorResult b -> IteratorResult b -> Bool
(IteratorResult b -> IteratorResult b -> Bool)
-> (IteratorResult b -> IteratorResult b -> Bool)
-> Eq (IteratorResult b)
forall b. Eq b => IteratorResult b -> IteratorResult b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IteratorResult b -> IteratorResult b -> Bool
$c/= :: forall b. Eq b => IteratorResult b -> IteratorResult b -> Bool
== :: IteratorResult b -> IteratorResult b -> Bool
$c== :: forall b. Eq b => IteratorResult b -> IteratorResult b -> Bool
Eq, (forall x. IteratorResult b -> Rep (IteratorResult b) x)
-> (forall x. Rep (IteratorResult b) x -> IteratorResult b)
-> Generic (IteratorResult b)
forall x. Rep (IteratorResult b) x -> IteratorResult b
forall x. IteratorResult b -> Rep (IteratorResult b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall b x. Rep (IteratorResult b) x -> IteratorResult b
forall b x. IteratorResult b -> Rep (IteratorResult b) x
$cto :: forall b x. Rep (IteratorResult b) x -> IteratorResult b
$cfrom :: forall b x. IteratorResult b -> Rep (IteratorResult b) x
Generic, a -> IteratorResult b -> IteratorResult a
(a -> b) -> IteratorResult a -> IteratorResult b
(forall a b. (a -> b) -> IteratorResult a -> IteratorResult b)
-> (forall a b. a -> IteratorResult b -> IteratorResult a)
-> Functor IteratorResult
forall a b. a -> IteratorResult b -> IteratorResult a
forall a b. (a -> b) -> IteratorResult a -> IteratorResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> IteratorResult b -> IteratorResult a
$c<$ :: forall a b. a -> IteratorResult b -> IteratorResult a
fmap :: (a -> b) -> IteratorResult a -> IteratorResult b
$cfmap :: forall a b. (a -> b) -> IteratorResult a -> IteratorResult b
Functor, IteratorResult a -> Bool
(a -> m) -> IteratorResult a -> m
(a -> b -> b) -> b -> IteratorResult a -> b
(forall m. Monoid m => IteratorResult m -> m)
-> (forall m a. Monoid m => (a -> m) -> IteratorResult a -> m)
-> (forall m a. Monoid m => (a -> m) -> IteratorResult a -> m)
-> (forall a b. (a -> b -> b) -> b -> IteratorResult a -> b)
-> (forall a b. (a -> b -> b) -> b -> IteratorResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> IteratorResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> IteratorResult a -> b)
-> (forall a. (a -> a -> a) -> IteratorResult a -> a)
-> (forall a. (a -> a -> a) -> IteratorResult a -> a)
-> (forall a. IteratorResult a -> [a])
-> (forall a. IteratorResult a -> Bool)
-> (forall a. IteratorResult a -> Int)
-> (forall a. Eq a => a -> IteratorResult a -> Bool)
-> (forall a. Ord a => IteratorResult a -> a)
-> (forall a. Ord a => IteratorResult a -> a)
-> (forall a. Num a => IteratorResult a -> a)
-> (forall a. Num a => IteratorResult a -> a)
-> Foldable IteratorResult
forall a. Eq a => a -> IteratorResult a -> Bool
forall a. Num a => IteratorResult a -> a
forall a. Ord a => IteratorResult a -> a
forall m. Monoid m => IteratorResult m -> m
forall a. IteratorResult a -> Bool
forall a. IteratorResult a -> Int
forall a. IteratorResult a -> [a]
forall a. (a -> a -> a) -> IteratorResult a -> a
forall m a. Monoid m => (a -> m) -> IteratorResult a -> m
forall b a. (b -> a -> b) -> b -> IteratorResult a -> b
forall a b. (a -> b -> b) -> b -> IteratorResult a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: IteratorResult a -> a
$cproduct :: forall a. Num a => IteratorResult a -> a
sum :: IteratorResult a -> a
$csum :: forall a. Num a => IteratorResult a -> a
minimum :: IteratorResult a -> a
$cminimum :: forall a. Ord a => IteratorResult a -> a
maximum :: IteratorResult a -> a
$cmaximum :: forall a. Ord a => IteratorResult a -> a
elem :: a -> IteratorResult a -> Bool
$celem :: forall a. Eq a => a -> IteratorResult a -> Bool
length :: IteratorResult a -> Int
$clength :: forall a. IteratorResult a -> Int
null :: IteratorResult a -> Bool
$cnull :: forall a. IteratorResult a -> Bool
toList :: IteratorResult a -> [a]
$ctoList :: forall a. IteratorResult a -> [a]
foldl1 :: (a -> a -> a) -> IteratorResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> IteratorResult a -> a
foldr1 :: (a -> a -> a) -> IteratorResult a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> IteratorResult a -> a
foldl' :: (b -> a -> b) -> b -> IteratorResult a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> IteratorResult a -> b
foldl :: (b -> a -> b) -> b -> IteratorResult a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> IteratorResult a -> b
foldr' :: (a -> b -> b) -> b -> IteratorResult a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> IteratorResult a -> b
foldr :: (a -> b -> b) -> b -> IteratorResult a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> IteratorResult a -> b
foldMap' :: (a -> m) -> IteratorResult a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> IteratorResult a -> m
foldMap :: (a -> m) -> IteratorResult a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> IteratorResult a -> m
fold :: IteratorResult m -> m
$cfold :: forall m. Monoid m => IteratorResult m -> m
Foldable, Functor IteratorResult
Foldable IteratorResult
Functor IteratorResult
-> Foldable IteratorResult
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> IteratorResult a -> f (IteratorResult b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    IteratorResult (f a) -> f (IteratorResult a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> IteratorResult a -> m (IteratorResult b))
-> (forall (m :: * -> *) a.
    Monad m =>
    IteratorResult (m a) -> m (IteratorResult a))
-> Traversable IteratorResult
(a -> f b) -> IteratorResult a -> f (IteratorResult b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
IteratorResult (m a) -> m (IteratorResult a)
forall (f :: * -> *) a.
Applicative f =>
IteratorResult (f a) -> f (IteratorResult a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> IteratorResult a -> m (IteratorResult b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IteratorResult a -> f (IteratorResult b)
sequence :: IteratorResult (m a) -> m (IteratorResult a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
IteratorResult (m a) -> m (IteratorResult a)
mapM :: (a -> m b) -> IteratorResult a -> m (IteratorResult b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> IteratorResult a -> m (IteratorResult b)
sequenceA :: IteratorResult (f a) -> f (IteratorResult a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
IteratorResult (f a) -> f (IteratorResult a)
traverse :: (a -> f b) -> IteratorResult a -> f (IteratorResult b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IteratorResult a -> f (IteratorResult b)
$cp2Traversable :: Foldable IteratorResult
$cp1Traversable :: Functor IteratorResult
Traversable)

-- | Consume an 'Iterator' by stepping until it is exhausted. A list of all
-- the 'IteratorResult's (excluding the final 'IteratorExhausted') produced by
-- the 'Iterator' is returned.
iteratorToList :: (HasCallStack, Monad m)
               => Iterator m blk b -> m [b]
iteratorToList :: Iterator m blk b -> m [b]
iteratorToList Iterator m blk b
it = [b] -> m [b]
go []
  where
    go :: [b] -> m [b]
go [b]
acc = do
      IteratorResult b
next <- Iterator m blk b -> HasCallStack => m (IteratorResult b)
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m (IteratorResult b)
iteratorNext Iterator m blk b
it
      case IteratorResult b
next of
        IteratorResult b
IteratorExhausted  -> [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> m [b]) -> [b] -> m [b]
forall a b. (a -> b) -> a -> b
$ [b] -> [b]
forall a. [a] -> [a]
reverse [b]
acc
        IteratorResult b
res -> [b] -> m [b]
go (b
resb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
acc)

-- | An iterator that is immediately exhausted.
emptyIterator :: MonadSTM m => Iterator m blk b
emptyIterator :: Iterator m blk b
emptyIterator = Iterator :: forall (m :: * -> *) blk b.
(HasCallStack => m (IteratorResult b))
-> (HasCallStack => STM m (Maybe (RealPoint blk)))
-> (HasCallStack => m ())
-> Iterator m blk b
Iterator {
      iteratorNext :: HasCallStack => m (IteratorResult b)
iteratorNext    = IteratorResult b -> m (IteratorResult b)
forall (m :: * -> *) a. Monad m => a -> m a
return IteratorResult b
forall b. IteratorResult b
IteratorExhausted
    , iteratorHasNext :: HasCallStack => STM m (Maybe (RealPoint blk))
iteratorHasNext = Maybe (RealPoint blk) -> STM m (Maybe (RealPoint blk))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RealPoint blk)
forall a. Maybe a
Nothing
    , iteratorClose :: HasCallStack => m ()
iteratorClose   = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }

{-------------------------------------------------------------------------------
  Types
-------------------------------------------------------------------------------}

-- | Information about the tip of the ImmutableDB.
data Tip blk = Tip {
      Tip blk -> SlotNo
tipSlotNo  :: !SlotNo
    , Tip blk -> IsEBB
tipIsEBB   :: !IsEBB
    , Tip blk -> BlockNo
tipBlockNo :: !BlockNo
    , Tip blk -> HeaderHash blk
tipHash    :: !(HeaderHash blk)
    }
  deriving ((forall x. Tip blk -> Rep (Tip blk) x)
-> (forall x. Rep (Tip blk) x -> Tip blk) -> Generic (Tip blk)
forall x. Rep (Tip blk) x -> Tip blk
forall x. Tip blk -> Rep (Tip blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (Tip blk) x -> Tip blk
forall blk x. Tip blk -> Rep (Tip blk) x
$cto :: forall blk x. Rep (Tip blk) x -> Tip blk
$cfrom :: forall blk x. Tip blk -> Rep (Tip blk) x
Generic)

deriving instance StandardHash blk => Eq       (Tip blk)
deriving instance StandardHash blk => Show     (Tip blk)
deriving instance StandardHash blk => NoThunks (Tip blk)

tipToRealPoint :: Tip blk -> RealPoint blk
tipToRealPoint :: Tip blk -> RealPoint blk
tipToRealPoint Tip { SlotNo
tipSlotNo :: SlotNo
tipSlotNo :: forall blk. Tip blk -> SlotNo
tipSlotNo, HeaderHash blk
tipHash :: HeaderHash blk
tipHash :: forall blk. Tip blk -> HeaderHash blk
tipHash } = SlotNo -> HeaderHash blk -> RealPoint blk
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
tipSlotNo HeaderHash blk
tipHash

tipToPoint :: WithOrigin (Tip blk) -> Point blk
tipToPoint :: WithOrigin (Tip blk) -> Point blk
tipToPoint = \case
    WithOrigin (Tip blk)
Origin        -> Point blk
forall block. Point block
GenesisPoint
    NotOrigin Tip blk
tip -> RealPoint blk -> Point blk
forall blk. RealPoint blk -> Point blk
realPointToPoint (RealPoint blk -> Point blk) -> RealPoint blk -> Point blk
forall a b. (a -> b) -> a -> b
$ Tip blk -> RealPoint blk
forall blk. Tip blk -> RealPoint blk
tipToRealPoint Tip blk
tip

tipToAnchor :: WithOrigin (Tip blk) -> AF.Anchor blk
tipToAnchor :: WithOrigin (Tip blk) -> Anchor blk
tipToAnchor = \case
    WithOrigin (Tip blk)
Origin ->
      Anchor blk
forall block. Anchor block
AF.AnchorGenesis
    NotOrigin (Tip { SlotNo
tipSlotNo :: SlotNo
tipSlotNo :: forall blk. Tip blk -> SlotNo
tipSlotNo, HeaderHash blk
tipHash :: HeaderHash blk
tipHash :: forall blk. Tip blk -> HeaderHash blk
tipHash, BlockNo
tipBlockNo :: BlockNo
tipBlockNo :: forall blk. Tip blk -> BlockNo
tipBlockNo }) ->
      SlotNo -> HeaderHash blk -> BlockNo -> Anchor blk
forall block. SlotNo -> HeaderHash block -> BlockNo -> Anchor block
AF.Anchor SlotNo
tipSlotNo HeaderHash blk
tipHash BlockNo
tipBlockNo

blockToTip :: (HasHeader blk, GetHeader blk) => blk -> Tip blk
blockToTip :: blk -> Tip blk
blockToTip blk
blk = Tip :: forall blk. SlotNo -> IsEBB -> BlockNo -> HeaderHash blk -> Tip blk
Tip {
      tipSlotNo :: SlotNo
tipSlotNo  = blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot    blk
blk
    , tipIsEBB :: IsEBB
tipIsEBB   = blk -> IsEBB
forall blk. GetHeader blk => blk -> IsEBB
blockToIsEBB blk
blk
    , tipBlockNo :: BlockNo
tipBlockNo = blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo      blk
blk
    , tipHash :: HeaderHash blk
tipHash    = blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash    blk
blk
    }

-- | newtype with an 'Ord' instance that only uses 'tipSlotNo' and 'tipIsEBB'
-- and ignores the other fields.
newtype CompareTip blk = CompareTip { CompareTip blk -> Tip blk
getCompareTip :: Tip blk }

instance Eq (CompareTip blk) where
  CompareTip blk
a == :: CompareTip blk -> CompareTip blk -> Bool
== CompareTip blk
b = CompareTip blk -> CompareTip blk -> Ordering
forall a. Ord a => a -> a -> Ordering
compare CompareTip blk
a CompareTip blk
b Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

instance Ord (CompareTip blk) where
  compare :: CompareTip blk -> CompareTip blk -> Ordering
compare = [CompareTip blk -> CompareTip blk -> Ordering]
-> CompareTip blk -> CompareTip blk -> Ordering
forall a. Monoid a => [a] -> a
mconcat [
        SlotNo -> SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
compare      (SlotNo -> SlotNo -> Ordering)
-> (CompareTip blk -> SlotNo)
-> CompareTip blk
-> CompareTip blk
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Tip blk -> SlotNo
forall blk. Tip blk -> SlotNo
tipSlotNo (Tip blk -> SlotNo)
-> (CompareTip blk -> Tip blk) -> CompareTip blk -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompareTip blk -> Tip blk
forall blk. CompareTip blk -> Tip blk
getCompareTip
      , IsEBB -> IsEBB -> Ordering
compareIsEBB (IsEBB -> IsEBB -> Ordering)
-> (CompareTip blk -> IsEBB)
-> CompareTip blk
-> CompareTip blk
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Tip blk -> IsEBB
forall blk. Tip blk -> IsEBB
tipIsEBB  (Tip blk -> IsEBB)
-> (CompareTip blk -> Tip blk) -> CompareTip blk -> IsEBB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompareTip blk -> Tip blk
forall blk. CompareTip blk -> Tip blk
getCompareTip
      ]
    where
      -- When a block and an EBB share a slot number, the EBB is "older".
      compareIsEBB :: IsEBB -> IsEBB -> Ordering
      compareIsEBB :: IsEBB -> IsEBB -> Ordering
compareIsEBB IsEBB
IsEBB    IsEBB
IsNotEBB = Ordering
LT
      compareIsEBB IsEBB
IsNotEBB IsEBB
IsEBB    = Ordering
GT
      compareIsEBB IsEBB
_        IsEBB
_        = Ordering
EQ

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

-- | Errors that might arise when working with this database.
data ImmutableDBError blk =
    ApiMisuse (ApiMisuse blk) PrettyCallStack
    -- ^ An error thrown because of incorrect usage of the immutable database
    -- by the user.
  | UnexpectedFailure (UnexpectedFailure blk)
    -- ^ An unexpected error thrown because something went wrong on a lower
    -- layer.
  deriving ((forall x. ImmutableDBError blk -> Rep (ImmutableDBError blk) x)
-> (forall x. Rep (ImmutableDBError blk) x -> ImmutableDBError blk)
-> Generic (ImmutableDBError blk)
forall x. Rep (ImmutableDBError blk) x -> ImmutableDBError blk
forall x. ImmutableDBError blk -> Rep (ImmutableDBError blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (ImmutableDBError blk) x -> ImmutableDBError blk
forall blk x. ImmutableDBError blk -> Rep (ImmutableDBError blk) x
$cto :: forall blk x. Rep (ImmutableDBError blk) x -> ImmutableDBError blk
$cfrom :: forall blk x. ImmutableDBError blk -> Rep (ImmutableDBError blk) x
Generic, Int -> ImmutableDBError blk -> ShowS
[ImmutableDBError blk] -> ShowS
ImmutableDBError blk -> String
(Int -> ImmutableDBError blk -> ShowS)
-> (ImmutableDBError blk -> String)
-> ([ImmutableDBError blk] -> ShowS)
-> Show (ImmutableDBError blk)
forall blk.
(StandardHash blk, Typeable blk) =>
Int -> ImmutableDBError blk -> ShowS
forall blk.
(StandardHash blk, Typeable blk) =>
[ImmutableDBError blk] -> ShowS
forall blk.
(StandardHash blk, Typeable blk) =>
ImmutableDBError blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImmutableDBError blk] -> ShowS
$cshowList :: forall blk.
(StandardHash blk, Typeable blk) =>
[ImmutableDBError blk] -> ShowS
show :: ImmutableDBError blk -> String
$cshow :: forall blk.
(StandardHash blk, Typeable blk) =>
ImmutableDBError blk -> String
showsPrec :: Int -> ImmutableDBError blk -> ShowS
$cshowsPrec :: forall blk.
(StandardHash blk, Typeable blk) =>
Int -> ImmutableDBError blk -> ShowS
Show)

instance (StandardHash blk, Typeable blk)
      => Exception (ImmutableDBError blk) where
  displayException :: ImmutableDBError blk -> String
displayException = \case
      ApiMisuse {} ->
        String
"ImmutableDB incorrectly used, indicative of a bug"
      UnexpectedFailure (FileSystemError FsError
fse) ->
        FsError -> String
forall e. Exception e => e -> String
displayException FsError
fse
      UnexpectedFailure {} ->
        String
"The ImmutableDB got corrupted, full validation will be enabled for the next startup"

data ApiMisuse blk =
    -- | When trying to append a new block, it was not newer than the current
    -- tip, i.e., the slot was older than or equal to the current tip's slot.
    --
    -- The 'RealPoint' corresponds to the new block and the 'Point' to the
    -- current tip.
    AppendBlockNotNewerThanTipError (RealPoint blk) (Point blk)

    -- | When the chosen iterator range was invalid, i.e. the @start@ (first
    -- parameter) came after the @end@ (second parameter).
  | InvalidIteratorRangeError (StreamFrom blk) (StreamTo blk)

    -- | When performing an operation on a closed DB that is only allowed when
    -- the database is open.
  | ClosedDBError

    -- | When performing an operation on an open DB that is only allowed when
    -- the database is closed.
  | OpenDBError

deriving instance (StandardHash blk, Typeable blk) => Show (ApiMisuse blk)

throwApiMisuse ::
     (MonadThrow m, HasCallStack, StandardHash blk, Typeable blk)
  => ApiMisuse blk -> m a
throwApiMisuse :: ApiMisuse blk -> m a
throwApiMisuse ApiMisuse blk
e = ImmutableDBError blk -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ImmutableDBError blk -> m a) -> ImmutableDBError blk -> m a
forall a b. (a -> b) -> a -> b
$ ApiMisuse blk -> PrettyCallStack -> ImmutableDBError blk
forall blk.
ApiMisuse blk -> PrettyCallStack -> ImmutableDBError blk
ApiMisuse ApiMisuse blk
e PrettyCallStack
HasCallStack => PrettyCallStack
prettyCallStack

data UnexpectedFailure blk =
    -- | An IO operation on the file-system threw an error.
    FileSystemError FsError -- An FsError already stores the callstack

    -- | When loading an epoch or index file, its contents did not pass
    -- validation.
  | InvalidFileError FsPath String PrettyCallStack

    -- | A missing epoch or index file.
  | MissingFileError FsPath PrettyCallStack

    -- | There was a checksum mismatch when reading the block with the given
    -- point. The first 'CRC' is the expected one, the second one the actual
    -- one.
  | ChecksumMismatchError (RealPoint blk) CRC CRC FsPath PrettyCallStack

    -- | A block failed to parse
  | ParseError FsPath (RealPoint blk) CBOR.DeserialiseFailure

    -- | When parsing a block we got some trailing data
  | TrailingDataError FsPath (RealPoint blk) Lazy.ByteString

    -- | Block missing
    --
    -- This exception gets thrown when a block that we /know/ it should be in
    -- the ImmutableDB, nonetheless was not found.
  | MissingBlockError (MissingBlock blk)

    -- | A (parsed) block did not pass the integrity check.
    --
    -- This exception gets thrown when a block doesn't pass the integrity check
    -- done for 'GetVerifiedBlock'.
    --
    -- NOTE: we do not check the integrity of a block when it is added to the
    -- ImmutableDB. While this exception typically means the block has been
    -- corrupted, it could also mean the block didn't pass the check at the time
    -- it was added.
  | CorruptBlockError (RealPoint blk)

deriving instance (StandardHash blk, Typeable blk) => Show (UnexpectedFailure blk)

throwUnexpectedFailure ::
     (StandardHash blk, Typeable blk, MonadThrow m)
  => UnexpectedFailure blk -> m a
throwUnexpectedFailure :: UnexpectedFailure blk -> m a
throwUnexpectedFailure = ImmutableDBError blk -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ImmutableDBError blk -> m a)
-> (UnexpectedFailure blk -> ImmutableDBError blk)
-> UnexpectedFailure blk
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnexpectedFailure blk -> ImmutableDBError blk
forall blk. UnexpectedFailure blk -> ImmutableDBError blk
UnexpectedFailure

-- | This type can be part of an exception, but also returned as part of an
-- 'Either', because it can be expected in some cases.
data MissingBlock blk
    -- | There is no block in the slot of the given point.
  = EmptySlot (RealPoint blk)
    -- | The block and/or EBB in the slot of the given point have a different
    -- hash.
  | WrongHash (RealPoint blk) (NonEmpty (HeaderHash blk))
    -- | The requested point is in the future, i.e., its slot is greater than
    -- that of the tip. We record the tip as the second argument.
  | NewerThanTip (RealPoint blk) (Point blk)
  deriving (MissingBlock blk -> MissingBlock blk -> Bool
(MissingBlock blk -> MissingBlock blk -> Bool)
-> (MissingBlock blk -> MissingBlock blk -> Bool)
-> Eq (MissingBlock blk)
forall blk.
StandardHash blk =>
MissingBlock blk -> MissingBlock blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MissingBlock blk -> MissingBlock blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
MissingBlock blk -> MissingBlock blk -> Bool
== :: MissingBlock blk -> MissingBlock blk -> Bool
$c== :: forall blk.
StandardHash blk =>
MissingBlock blk -> MissingBlock blk -> Bool
Eq, Int -> MissingBlock blk -> ShowS
[MissingBlock blk] -> ShowS
MissingBlock blk -> String
(Int -> MissingBlock blk -> ShowS)
-> (MissingBlock blk -> String)
-> ([MissingBlock blk] -> ShowS)
-> Show (MissingBlock blk)
forall blk. StandardHash blk => Int -> MissingBlock blk -> ShowS
forall blk. StandardHash blk => [MissingBlock blk] -> ShowS
forall blk. StandardHash blk => MissingBlock blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MissingBlock blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [MissingBlock blk] -> ShowS
show :: MissingBlock blk -> String
$cshow :: forall blk. StandardHash blk => MissingBlock blk -> String
showsPrec :: Int -> MissingBlock blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> MissingBlock blk -> ShowS
Show, (forall x. MissingBlock blk -> Rep (MissingBlock blk) x)
-> (forall x. Rep (MissingBlock blk) x -> MissingBlock blk)
-> Generic (MissingBlock blk)
forall x. Rep (MissingBlock blk) x -> MissingBlock blk
forall x. MissingBlock blk -> Rep (MissingBlock blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (MissingBlock blk) x -> MissingBlock blk
forall blk x. MissingBlock blk -> Rep (MissingBlock blk) x
$cto :: forall blk x. Rep (MissingBlock blk) x -> MissingBlock blk
$cfrom :: forall blk x. MissingBlock blk -> Rep (MissingBlock blk) x
Generic)

-- | Return the 'RealPoint' of the block that was missing.
missingBlockPoint :: MissingBlock blk -> RealPoint blk
missingBlockPoint :: MissingBlock blk -> RealPoint blk
missingBlockPoint (EmptySlot RealPoint blk
pt)      = RealPoint blk
pt
missingBlockPoint (WrongHash RealPoint blk
pt NonEmpty (HeaderHash blk)
_)    = RealPoint blk
pt
missingBlockPoint (NewerThanTip RealPoint blk
pt Point blk
_) = RealPoint blk
pt

{-------------------------------------------------------------------------------
  Wrappers that preserve 'HasCallStack'

  @ghc@ really should do this for us :-/
-------------------------------------------------------------------------------}

closeDB ::
     HasCallStack
  => ImmutableDB m blk
  -> m ()
closeDB :: ImmutableDB m blk -> m ()
closeDB = ImmutableDB m blk -> m ()
forall (m :: * -> *) blk. ImmutableDB m blk -> HasCallStack => m ()
closeDB_

getTip ::
     HasCallStack
  => ImmutableDB m blk
  -> STM m (WithOrigin (Tip blk))
getTip :: ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
getTip = ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
ImmutableDB m blk -> HasCallStack => STM m (WithOrigin (Tip blk))
getTip_

getBlockComponent ::
     HasCallStack
  => ImmutableDB m blk
  -> BlockComponent blk b -> RealPoint blk -> m (Either (MissingBlock blk) b)
getBlockComponent :: ImmutableDB m blk
-> BlockComponent blk b
-> RealPoint blk
-> m (Either (MissingBlock blk) b)
getBlockComponent = ImmutableDB m blk
-> BlockComponent blk b
-> RealPoint blk
-> m (Either (MissingBlock blk) b)
forall (m :: * -> *) blk.
ImmutableDB m blk
-> forall b.
   HasCallStack =>
   BlockComponent blk b
   -> RealPoint blk -> m (Either (MissingBlock blk) b)
getBlockComponent_

appendBlock ::
     HasCallStack
  => ImmutableDB m blk
  -> blk -> m ()
appendBlock :: ImmutableDB m blk -> blk -> m ()
appendBlock = ImmutableDB m blk -> blk -> m ()
forall (m :: * -> *) blk.
ImmutableDB m blk -> HasCallStack => blk -> m ()
appendBlock_

stream ::
     HasCallStack
  => ImmutableDB m blk
  -> ResourceRegistry m
  -> BlockComponent blk b
  -> StreamFrom blk
  -> StreamTo   blk
  -> m (Either (MissingBlock blk) (Iterator m blk b))
stream :: ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
stream = ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall (m :: * -> *) blk.
ImmutableDB m blk
-> forall b.
   HasCallStack =>
   ResourceRegistry m
   -> BlockComponent blk b
   -> StreamFrom blk
   -> StreamTo blk
   -> m (Either (MissingBlock blk) (Iterator m blk b))
stream_

{-------------------------------------------------------------------------------
  Derived functionality
-------------------------------------------------------------------------------}

-- | Open the database using the given function, perform the given action
-- using the database, and closes the database using its 'closeDB' function,
-- in case of success or when an exception was raised.
withDB ::
     (HasCallStack, MonadThrow m)
  => m (ImmutableDB m blk)
     -- ^ How to open the database
  -> (ImmutableDB m blk -> m a)
     -- ^ Action to perform using the database
  -> m a
withDB :: m (ImmutableDB m blk) -> (ImmutableDB m blk -> m a) -> m a
withDB m (ImmutableDB m blk)
openDB = m (ImmutableDB m blk)
-> (ImmutableDB m blk -> m ()) -> (ImmutableDB m blk -> m a) -> m a
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m (ImmutableDB m blk)
openDB ImmutableDB m blk -> m ()
forall (m :: * -> *) blk. HasCallStack => ImmutableDB m blk -> m ()
closeDB

getKnownBlockComponent ::
     (MonadThrow m, HasHeader blk)
  => ImmutableDB m blk
  -> BlockComponent blk b
  -> RealPoint blk
  -> m b
getKnownBlockComponent :: ImmutableDB m blk -> BlockComponent blk b -> RealPoint blk -> m b
getKnownBlockComponent ImmutableDB m blk
db BlockComponent blk b
blockComponent RealPoint blk
pt =
    ImmutableDB m blk
-> BlockComponent blk b
-> RealPoint blk
-> m (Either (MissingBlock blk) b)
forall (m :: * -> *) blk b.
HasCallStack =>
ImmutableDB m blk
-> BlockComponent blk b
-> RealPoint blk
-> m (Either (MissingBlock blk) b)
getBlockComponent ImmutableDB m blk
db BlockComponent blk b
blockComponent RealPoint blk
pt m (Either (MissingBlock blk) b)
-> (Either (MissingBlock blk) b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left MissingBlock blk
missing -> 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
$ MissingBlock blk -> UnexpectedFailure blk
forall blk. MissingBlock blk -> UnexpectedFailure blk
MissingBlockError MissingBlock blk
missing
      Right b
b      -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b

-- | Open an iterator with the given point as lower exclusive bound and the
-- current tip as the inclusive upper bound.
--
-- Returns a 'MissingBlock' when the point is not in the ImmutableDB.
streamAfterPoint ::
     (MonadSTM m, HasHeader blk, HasCallStack)
  => ImmutableDB m blk
  -> ResourceRegistry m
  -> BlockComponent blk b
  -> Point blk
  -> m (Either (MissingBlock blk) (Iterator m blk b))
streamAfterPoint :: ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
streamAfterPoint ImmutableDB m blk
db ResourceRegistry m
registry BlockComponent blk b
blockComponent Point blk
fromPt = 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
    Point blk
tipPt <- m (Point blk) -> ExceptT (MissingBlock blk) m (Point blk)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Point blk) -> ExceptT (MissingBlock blk) m (Point blk))
-> m (Point blk) -> ExceptT (MissingBlock blk) m (Point blk)
forall a b. (a -> b) -> a -> b
$ STM m (Point blk) -> m (Point blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Point blk) -> m (Point blk))
-> STM m (Point blk) -> m (Point blk)
forall a b. (a -> b) -> a -> b
$ ImmutableDB m blk -> STM m (Point blk)
forall (m :: * -> *) blk.
(MonadSTM m, HasCallStack) =>
ImmutableDB m blk -> STM m (Point blk)
getTipPoint ImmutableDB m blk
db
    case (Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
fromPt,
          Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
tipPt) of

      (WithOrigin (RealPoint blk)
Origin, WithOrigin (RealPoint blk)
Origin) ->
        -- Nothing to stream
        Iterator m blk b -> ExceptT (MissingBlock blk) m (Iterator m blk b)
forall (m :: * -> *) a. Monad m => a -> m a
return Iterator m blk b
forall (m :: * -> *) blk b. MonadSTM m => Iterator m blk b
emptyIterator

      (NotOrigin RealPoint blk
fromPt', WithOrigin (RealPoint blk)
Origin) ->
        -- Asked to stream after a block while the ImmutableDB is empty
        MissingBlock blk -> ExceptT (MissingBlock blk) m (Iterator m blk b)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk
 -> ExceptT (MissingBlock blk) m (Iterator m blk b))
-> MissingBlock blk
-> ExceptT (MissingBlock blk) m (Iterator m blk b)
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Point blk -> MissingBlock blk
forall blk. RealPoint blk -> Point blk -> MissingBlock blk
NewerThanTip RealPoint blk
fromPt' Point blk
forall block. Point block
GenesisPoint

      (NotOrigin RealPoint blk
fromPt', NotOrigin RealPoint blk
_) | Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
fromPt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot Point blk
tipPt ->
        -- Lower bound is newer than the tip, nothing to stream
        MissingBlock blk -> ExceptT (MissingBlock blk) m (Iterator m blk b)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk
 -> ExceptT (MissingBlock blk) m (Iterator m blk b))
-> MissingBlock blk
-> ExceptT (MissingBlock blk) m (Iterator m blk b)
forall a b. (a -> b) -> a -> b
$ RealPoint blk -> Point blk -> MissingBlock blk
forall blk. RealPoint blk -> Point blk -> MissingBlock blk
NewerThanTip RealPoint blk
fromPt' Point blk
tipPt

      (NotOrigin RealPoint blk
fromPt', NotOrigin RealPoint blk
tipPt') | RealPoint blk
fromPt' RealPoint blk -> RealPoint blk -> Bool
forall a. Eq a => a -> a -> Bool
== RealPoint blk
tipPt' ->
        -- Nothing to stream after the tip
        Iterator m blk b -> ExceptT (MissingBlock blk) m (Iterator m blk b)
forall (m :: * -> *) a. Monad m => a -> m a
return Iterator m blk b
forall (m :: * -> *) blk b. MonadSTM m => Iterator m blk b
emptyIterator

      (WithOrigin (RealPoint blk)
_, NotOrigin RealPoint blk
tipPt') ->
        -- Stream from the given point to the current tip (not genesis)
        m (Either (MissingBlock blk) (Iterator m blk b))
-> ExceptT (MissingBlock blk) m (Iterator m blk b)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either (MissingBlock blk) (Iterator m blk b))
 -> ExceptT (MissingBlock blk) m (Iterator m blk b))
-> m (Either (MissingBlock blk) (Iterator m blk b))
-> ExceptT (MissingBlock blk) m (Iterator m blk b)
forall a b. (a -> b) -> a -> b
$ ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall (m :: * -> *) blk b.
HasCallStack =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
stream
          ImmutableDB m blk
db
          ResourceRegistry m
registry
          BlockComponent blk b
blockComponent
          (Point blk -> StreamFrom blk
forall blk. Point blk -> StreamFrom blk
StreamFromExclusive Point blk
fromPt)
          (RealPoint blk -> StreamTo blk
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive RealPoint blk
tipPt')

-- | Variant of 'streamAfterPoint' that throws a 'MissingBlockError' when the
-- point is not in the ImmutableDB (or genesis).
streamAfterKnownPoint ::
     (MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack)
  => ImmutableDB m blk
  -> ResourceRegistry m
  -> BlockComponent blk b
  -> Point blk
  -> m (Iterator m blk b)
streamAfterKnownPoint :: ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Iterator m blk b)
streamAfterKnownPoint ImmutableDB m blk
db ResourceRegistry m
registry BlockComponent blk b
blockComponent Point blk
fromPt =
    ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall (m :: * -> *) blk b.
(MonadSTM m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
streamAfterPoint ImmutableDB m blk
db ResourceRegistry m
registry BlockComponent blk b
blockComponent Point blk
fromPt m (Either (MissingBlock blk) (Iterator m blk b))
-> (Either (MissingBlock blk) (Iterator m blk b)
    -> m (Iterator m blk b))
-> m (Iterator m blk b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      (MissingBlock blk -> m (Iterator m blk b))
-> (Iterator m blk b -> m (Iterator m blk b))
-> Either (MissingBlock blk) (Iterator m blk b)
-> m (Iterator m blk b)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (UnexpectedFailure blk -> m (Iterator m blk b)
forall blk (m :: * -> *) a.
(StandardHash blk, Typeable blk, MonadThrow m) =>
UnexpectedFailure blk -> m a
throwUnexpectedFailure (UnexpectedFailure blk -> m (Iterator m blk b))
-> (MissingBlock blk -> UnexpectedFailure blk)
-> MissingBlock blk
-> m (Iterator m blk b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MissingBlock blk -> UnexpectedFailure blk
forall blk. MissingBlock blk -> UnexpectedFailure blk
MissingBlockError) Iterator m blk b -> m (Iterator m blk b)
forall (m :: * -> *) a. Monad m => a -> m a
return

streamAll ::
     (MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack)
  => ImmutableDB m blk
  -> ResourceRegistry m
  -> BlockComponent blk b
  -> m (Iterator m blk b)
streamAll :: ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> m (Iterator m blk b)
streamAll ImmutableDB m blk
db ResourceRegistry m
registry BlockComponent blk b
blockComponent =
    ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Iterator m blk b)
forall (m :: * -> *) blk b.
(MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> Point blk
-> m (Iterator m blk b)
streamAfterKnownPoint ImmutableDB m blk
db ResourceRegistry m
registry BlockComponent blk b
blockComponent Point blk
forall block. Point block
GenesisPoint

hasBlock ::
     (MonadSTM m, HasCallStack)
  => ImmutableDB m blk
  -> RealPoint blk
  -> m Bool
hasBlock :: ImmutableDB m blk -> RealPoint blk -> m Bool
hasBlock ImmutableDB m blk
db RealPoint blk
pt = Either (MissingBlock blk) () -> Bool
forall a b. Either a b -> Bool
isRight (Either (MissingBlock blk) () -> Bool)
-> m (Either (MissingBlock blk) ()) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImmutableDB m blk
-> BlockComponent blk ()
-> RealPoint blk
-> m (Either (MissingBlock blk) ())
forall (m :: * -> *) blk b.
HasCallStack =>
ImmutableDB m blk
-> BlockComponent blk b
-> RealPoint blk
-> m (Either (MissingBlock blk) b)
getBlockComponent ImmutableDB m blk
db (() -> BlockComponent blk ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) RealPoint blk
pt

getTipPoint ::
     (MonadSTM m, HasCallStack)
  => ImmutableDB m blk -> STM m (Point blk)
getTipPoint :: ImmutableDB m blk -> STM m (Point blk)
getTipPoint = (WithOrigin (Tip blk) -> Point blk)
-> STM m (WithOrigin (Tip blk)) -> STM m (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithOrigin (Tip blk) -> Point blk
forall blk. WithOrigin (Tip blk) -> Point blk
tipToPoint (STM m (WithOrigin (Tip blk)) -> STM m (Point blk))
-> (ImmutableDB m blk -> STM m (WithOrigin (Tip blk)))
-> ImmutableDB m blk
-> STM m (Point blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
getTip

getTipAnchor ::
     (MonadSTM m, HasCallStack)
  => ImmutableDB m blk -> STM m (AF.Anchor blk)
getTipAnchor :: ImmutableDB m blk -> STM m (Anchor blk)
getTipAnchor = (WithOrigin (Tip blk) -> Anchor blk)
-> STM m (WithOrigin (Tip blk)) -> STM m (Anchor blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithOrigin (Tip blk) -> Anchor blk
forall blk. WithOrigin (Tip blk) -> Anchor blk
tipToAnchor (STM m (WithOrigin (Tip blk)) -> STM m (Anchor blk))
-> (ImmutableDB m blk -> STM m (WithOrigin (Tip blk)))
-> ImmutableDB m blk
-> STM m (Anchor blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
getTip

getTipSlot ::
     (MonadSTM m, HasCallStack)
  => ImmutableDB m blk -> STM m (WithOrigin SlotNo)
getTipSlot :: ImmutableDB m blk -> STM m (WithOrigin SlotNo)
getTipSlot = (WithOrigin (Tip blk) -> WithOrigin SlotNo)
-> STM m (WithOrigin (Tip blk)) -> STM m (WithOrigin SlotNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tip blk -> SlotNo) -> WithOrigin (Tip blk) -> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tip blk -> SlotNo
forall blk. Tip blk -> SlotNo
tipSlotNo) (STM m (WithOrigin (Tip blk)) -> STM m (WithOrigin SlotNo))
-> (ImmutableDB m blk -> STM m (WithOrigin (Tip blk)))
-> ImmutableDB m blk
-> STM m (WithOrigin SlotNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
getTip