{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Model for the 'ImmutableDB'.
module Test.Ouroboros.Storage.ImmutableDB.Model (
    DBModel (..)
  , InSlot (..)
  , IteratorId
  , IteratorModel
  , closeAllIterators
  , dbmBlocks
  , dbmCurrentChunk
  , dbmTip
  , dbmTipBlock
  , initDBModel
  , simulateCorruptions
  , tips
    -- * ImmutableDB implementation
  , appendBlockModel
  , deleteAfterModel
  , getBlockComponentModel
  , getHashForSlotModel
  , getTipModel
  , iteratorCloseModel
  , iteratorHasNextModel
  , iteratorNextModel
  , reopenModel
  , streamAllModel
  , streamModel
  ) where

import qualified Codec.CBOR.Write as CBOR
import           Control.Monad (unless, when)
import           Control.Monad.Except (MonadError, throwError)
import           Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as Lazy
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import           Data.TreeDiff
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Storage.Common
import           Ouroboros.Consensus.Storage.ImmutableDB.API hiding
                     (throwApiMisuse)
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks.Internal
                     (ChunkNo (..))
import           Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util (parseDBFile)
import           Ouroboros.Consensus.Storage.Serialisation
import           Ouroboros.Consensus.Util (lastMaybe, takeUntil)
import           Ouroboros.Consensus.Util.CallStack
import           System.FS.API.Types (FsPath, fsPathSplit)
import           Test.Ouroboros.Storage.TestBlock hiding (EBB)
import           Test.Util.Orphans.ToExpr ()

data InSlot blk =
    -- | This slot contains only a regular block
    InSlotBlock blk

    -- | This slot contains only an EBB
  | InSlotEBB blk

    -- | This slot contains an EBB /and/ a regular block
    --
    -- NOTE: EBBs shares
    --
    -- o a block number with their predecessor
    -- o a slot number with their successor
    --
    -- So within the same /slot/, the EBB comes /first/.
  | InSlotBoth blk blk
  deriving (Int -> InSlot blk -> ShowS
[InSlot blk] -> ShowS
InSlot blk -> String
(Int -> InSlot blk -> ShowS)
-> (InSlot blk -> String)
-> ([InSlot blk] -> ShowS)
-> Show (InSlot blk)
forall blk. Show blk => Int -> InSlot blk -> ShowS
forall blk. Show blk => [InSlot blk] -> ShowS
forall blk. Show blk => InSlot blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. Show blk => Int -> InSlot blk -> ShowS
showsPrec :: Int -> InSlot blk -> ShowS
$cshow :: forall blk. Show blk => InSlot blk -> String
show :: InSlot blk -> String
$cshowList :: forall blk. Show blk => [InSlot blk] -> ShowS
showList :: [InSlot blk] -> ShowS
Show, (forall x. InSlot blk -> Rep (InSlot blk) x)
-> (forall x. Rep (InSlot blk) x -> InSlot blk)
-> Generic (InSlot blk)
forall x. Rep (InSlot blk) x -> InSlot blk
forall x. InSlot blk -> Rep (InSlot blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (InSlot blk) x -> InSlot blk
forall blk x. InSlot blk -> Rep (InSlot blk) x
$cfrom :: forall blk x. InSlot blk -> Rep (InSlot blk) x
from :: forall x. InSlot blk -> Rep (InSlot blk) x
$cto :: forall blk x. Rep (InSlot blk) x -> InSlot blk
to :: forall x. Rep (InSlot blk) x -> InSlot blk
Generic)

data DBModel blk = DBModel {
      forall blk. DBModel blk -> ChunkInfo
dbmChunkInfo    :: ChunkInfo
    , forall blk. DBModel blk -> CodecConfig blk
dbmCodecConfig  :: CodecConfig blk
    , forall blk. DBModel blk -> Map Int (IteratorModel blk)
dbmIterators    :: Map IteratorId (IteratorModel blk)
    , forall blk. DBModel blk -> Int
dbmNextIterator :: IteratorId
    , forall blk. DBModel blk -> Map SlotNo (InSlot blk)
dbmSlots        :: Map SlotNo (InSlot blk)
    }
  deriving ((forall x. DBModel blk -> Rep (DBModel blk) x)
-> (forall x. Rep (DBModel blk) x -> DBModel blk)
-> Generic (DBModel blk)
forall x. Rep (DBModel blk) x -> DBModel blk
forall x. DBModel blk -> Rep (DBModel blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (DBModel blk) x -> DBModel blk
forall blk x. DBModel blk -> Rep (DBModel blk) x
$cfrom :: forall blk x. DBModel blk -> Rep (DBModel blk) x
from :: forall x. DBModel blk -> Rep (DBModel blk) x
$cto :: forall blk x. Rep (DBModel blk) x -> DBModel blk
to :: forall x. Rep (DBModel blk) x -> DBModel blk
Generic)

deriving instance (Show (CodecConfig blk), StandardHash blk, Show blk) => Show (DBModel blk)

initDBModel :: ChunkInfo -> CodecConfig blk -> DBModel blk
initDBModel :: forall blk. ChunkInfo -> CodecConfig blk -> DBModel blk
initDBModel ChunkInfo
chunkInfo CodecConfig blk
codecConfig = DBModel {
      dbmChunkInfo :: ChunkInfo
dbmChunkInfo    = ChunkInfo
chunkInfo
    , dbmCodecConfig :: CodecConfig blk
dbmCodecConfig  = CodecConfig blk
codecConfig
    , dbmIterators :: Map Int (IteratorModel blk)
dbmIterators    = Map Int (IteratorModel blk)
forall k a. Map k a
Map.empty
    , dbmNextIterator :: Int
dbmNextIterator = Int
0
    , dbmSlots :: Map SlotNo (InSlot blk)
dbmSlots        = Map SlotNo (InSlot blk)
forall k a. Map k a
Map.empty
    }

insertInSlot ::
     forall blk. (HasHeader blk, GetHeader blk, HasCallStack)
  => blk
  -> Map SlotNo (InSlot blk)
  -> Map SlotNo (InSlot blk)
insertInSlot :: forall blk.
(HasHeader blk, GetHeader blk, HasCallStack) =>
blk -> Map SlotNo (InSlot blk) -> Map SlotNo (InSlot blk)
insertInSlot blk
blk = (Maybe (InSlot blk) -> Maybe (InSlot blk))
-> SlotNo -> Map SlotNo (InSlot blk) -> Map SlotNo (InSlot blk)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (InSlot blk -> Maybe (InSlot blk)
forall a. a -> Maybe a
Just (InSlot blk -> Maybe (InSlot blk))
-> (Maybe (InSlot blk) -> InSlot blk)
-> Maybe (InSlot blk)
-> Maybe (InSlot blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsEBB -> Maybe (InSlot blk) -> InSlot blk
ins (blk -> IsEBB
forall blk. GetHeader blk => blk -> IsEBB
blockToIsEBB blk
blk)) (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk)
  where
    ins :: IsEBB -> Maybe (InSlot blk) -> InSlot blk
    ins :: IsEBB -> Maybe (InSlot blk) -> InSlot blk
ins IsEBB
IsNotEBB Maybe (InSlot blk)
Nothing                  = blk -> InSlot blk
forall blk. blk -> InSlot blk
InSlotBlock    blk
blk
    ins IsEBB
IsEBB    Maybe (InSlot blk)
Nothing                  = blk -> InSlot blk
forall blk. blk -> InSlot blk
InSlotEBB      blk
blk
    ins IsEBB
IsNotEBB (Just (InSlotEBB   blk
ebb)) = blk -> blk -> InSlot blk
forall blk. blk -> blk -> InSlot blk
InSlotBoth blk
ebb blk
blk
    ins IsEBB
IsEBB    (Just (InSlotBlock blk
_  )) = String -> InSlot blk
forall a. HasCallStack => String -> a
error String
"insertInSlot: EBB after block"
    ins IsEBB
_ Maybe (InSlot blk)
_                               = String -> InSlot blk
forall a. HasCallStack => String -> a
error String
"insertInSlot: slot already filled"

{-------------------------------------------------------------------------------
  Derived values
-------------------------------------------------------------------------------}

dbmTipBlock :: DBModel blk -> WithOrigin blk
dbmTipBlock :: forall blk. DBModel blk -> WithOrigin blk
dbmTipBlock DBModel { Map SlotNo (InSlot blk)
dbmSlots :: forall blk. DBModel blk -> Map SlotNo (InSlot blk)
dbmSlots :: Map SlotNo (InSlot blk)
dbmSlots } =
    case Map SlotNo (InSlot blk) -> Maybe (SlotNo, InSlot blk)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map SlotNo (InSlot blk)
dbmSlots of
      Maybe (SlotNo, InSlot blk)
Nothing              -> WithOrigin blk
forall t. WithOrigin t
Origin
      Just (SlotNo
_slot, InSlot blk
inSlot) -> blk -> WithOrigin blk
forall t. t -> WithOrigin t
NotOrigin (blk -> WithOrigin blk) -> blk -> WithOrigin blk
forall a b. (a -> b) -> a -> b
$
        case InSlot blk
inSlot of
          InSlotBlock     blk
blk -> blk
blk
          InSlotEBB       blk
blk -> blk
blk
          InSlotBoth blk
_ebb blk
blk -> blk
blk

dbmTip :: GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip :: forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip = (blk -> Tip blk) -> WithOrigin blk -> WithOrigin (Tip blk)
forall a b. (a -> b) -> WithOrigin a -> WithOrigin b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> Tip blk
forall blk. GetHeader blk => blk -> Tip blk
blockToTip (WithOrigin blk -> WithOrigin (Tip blk))
-> (DBModel blk -> WithOrigin blk)
-> DBModel blk
-> WithOrigin (Tip blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBModel blk -> WithOrigin blk
forall blk. DBModel blk -> WithOrigin blk
dbmTipBlock

-- | Return a list of blocks in the same order as they appear on the \"virtual\"
-- chain in the ImmutableDB.
dbmBlocks :: DBModel blk -> [blk]
dbmBlocks :: forall blk. DBModel blk -> [blk]
dbmBlocks = (InSlot blk -> [blk]) -> [InSlot blk] -> [blk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InSlot blk -> [blk]
forall blk. InSlot blk -> [blk]
inSlotToBlks ([InSlot blk] -> [blk])
-> (DBModel blk -> [InSlot blk]) -> DBModel blk -> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SlotNo (InSlot blk) -> [InSlot blk]
forall k a. Map k a -> [a]
Map.elems (Map SlotNo (InSlot blk) -> [InSlot blk])
-> (DBModel blk -> Map SlotNo (InSlot blk))
-> DBModel blk
-> [InSlot blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBModel blk -> Map SlotNo (InSlot blk)
forall blk. DBModel blk -> Map SlotNo (InSlot blk)
dbmSlots
  where
    inSlotToBlks :: InSlot blk -> [blk]
    inSlotToBlks :: forall blk. InSlot blk -> [blk]
inSlotToBlks = \case
        InSlotBlock     blk
blk -> [blk
blk]
        InSlotEBB   blk
ebb     -> [blk
ebb]
        InSlotBoth  blk
ebb blk
blk -> [blk
ebb, blk
blk]

dbmCurrentChunk :: HasHeader blk => DBModel blk -> ChunkNo
dbmCurrentChunk :: forall blk. HasHeader blk => DBModel blk -> ChunkNo
dbmCurrentChunk dbm :: DBModel blk
dbm@DBModel { ChunkInfo
dbmChunkInfo :: forall blk. DBModel blk -> ChunkInfo
dbmChunkInfo :: ChunkInfo
dbmChunkInfo } =
    case blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot (blk -> SlotNo) -> WithOrigin blk -> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBModel blk -> WithOrigin blk
forall blk. DBModel blk -> WithOrigin blk
dbmTipBlock DBModel blk
dbm of
      WithOrigin SlotNo
Origin         -> ChunkNo
firstChunkNo
      NotOrigin SlotNo
slot -> ChunkInfo -> SlotNo -> ChunkNo
chunkIndexOfSlot ChunkInfo
dbmChunkInfo SlotNo
slot

type IteratorId = Int

-- | Model for an 'Iterator'.
--
-- An iterator is open iff its is present in 'dbmIterators'.
--
-- The model of an iterator is just the list of blocks it streams over.
-- Advancing the iterator will yield the first one and should drop it from the
-- model.
newtype IteratorModel blk = IteratorModel [blk]
  deriving (Int -> IteratorModel blk -> ShowS
[IteratorModel blk] -> ShowS
IteratorModel blk -> String
(Int -> IteratorModel blk -> ShowS)
-> (IteratorModel blk -> String)
-> ([IteratorModel blk] -> ShowS)
-> Show (IteratorModel blk)
forall blk. Show blk => Int -> IteratorModel blk -> ShowS
forall blk. Show blk => [IteratorModel blk] -> ShowS
forall blk. Show blk => IteratorModel blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. Show blk => Int -> IteratorModel blk -> ShowS
showsPrec :: Int -> IteratorModel blk -> ShowS
$cshow :: forall blk. Show blk => IteratorModel blk -> String
show :: IteratorModel blk -> String
$cshowList :: forall blk. Show blk => [IteratorModel blk] -> ShowS
showList :: [IteratorModel blk] -> ShowS
Show, IteratorModel blk -> IteratorModel blk -> Bool
(IteratorModel blk -> IteratorModel blk -> Bool)
-> (IteratorModel blk -> IteratorModel blk -> Bool)
-> Eq (IteratorModel blk)
forall blk.
Eq blk =>
IteratorModel blk -> IteratorModel blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
Eq blk =>
IteratorModel blk -> IteratorModel blk -> Bool
== :: IteratorModel blk -> IteratorModel blk -> Bool
$c/= :: forall blk.
Eq blk =>
IteratorModel blk -> IteratorModel blk -> Bool
/= :: IteratorModel blk -> IteratorModel blk -> Bool
Eq, (forall x. IteratorModel blk -> Rep (IteratorModel blk) x)
-> (forall x. Rep (IteratorModel blk) x -> IteratorModel blk)
-> Generic (IteratorModel blk)
forall x. Rep (IteratorModel blk) x -> IteratorModel blk
forall x. IteratorModel blk -> Rep (IteratorModel blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (IteratorModel blk) x -> IteratorModel blk
forall blk x. IteratorModel blk -> Rep (IteratorModel blk) x
$cfrom :: forall blk x. IteratorModel blk -> Rep (IteratorModel blk) x
from :: forall x. IteratorModel blk -> Rep (IteratorModel blk) x
$cto :: forall blk x. Rep (IteratorModel blk) x -> IteratorModel blk
to :: forall x. Rep (IteratorModel blk) x -> IteratorModel blk
Generic)

instance ToExpr (IteratorModel TestBlock)
instance ToExpr (DBModel TestBlock)
instance ToExpr (InSlot TestBlock)

{------------------------------------------------------------------------------
  Helpers
------------------------------------------------------------------------------}

throwApiMisuse ::
     (MonadError (ImmutableDBError blk) m, HasCallStack)
  => ApiMisuse blk -> m a
throwApiMisuse :: forall blk (m :: * -> *) a.
(MonadError (ImmutableDBError blk) m, HasCallStack) =>
ApiMisuse blk -> m a
throwApiMisuse ApiMisuse blk
e = ImmutableDBError blk -> m a
forall a. ImmutableDBError blk -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (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

computeBlockSize :: EncodeDisk blk blk => CodecConfig blk -> blk -> Word64
computeBlockSize :: forall blk. EncodeDisk blk blk => CodecConfig blk -> blk -> Word64
computeBlockSize CodecConfig blk
ccfg =
      Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    (Int64 -> Word64) -> (blk -> Int64) -> blk -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
Lazy.length
    (ByteString -> Int64) -> (blk -> ByteString) -> blk -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
CBOR.toLazyByteString
    (Encoding -> ByteString) -> (blk -> Encoding) -> blk -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CodecConfig blk -> blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
ccfg

lookupBlock ::
     (HasHeader blk, GetHeader blk)
  => RealPoint blk
  -> DBModel blk
  -> Either (MissingBlock blk) blk
lookupBlock :: forall blk.
(HasHeader blk, GetHeader blk) =>
RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
lookupBlock pt :: RealPoint blk
pt@(RealPoint SlotNo
slot HeaderHash blk
hash) dbm :: DBModel blk
dbm@DBModel { Map SlotNo (InSlot blk)
dbmSlots :: forall blk. DBModel blk -> Map SlotNo (InSlot blk)
dbmSlots :: Map SlotNo (InSlot blk)
dbmSlots } =
    case SlotNo -> Map SlotNo (InSlot blk) -> Maybe (InSlot blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SlotNo
slot Map SlotNo (InSlot blk)
dbmSlots of
      Just (InSlotBlock blk
blk)
        | blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash blk
hash
        -> blk -> Either (MissingBlock blk) blk
forall a. a -> Either (MissingBlock blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return blk
blk
        | Bool
otherwise
        -> MissingBlock blk -> Either (MissingBlock blk) blk
forall a. MissingBlock blk -> Either (MissingBlock blk) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk -> Either (MissingBlock blk) blk)
-> MissingBlock blk -> Either (MissingBlock blk) blk
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 ([HeaderHash blk] -> NonEmpty (HeaderHash blk)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk])
      Just (InSlotEBB blk
ebb)
        | blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
ebb HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash blk
hash
        -> blk -> Either (MissingBlock blk) blk
forall a. a -> Either (MissingBlock blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return blk
ebb
        | Bool
otherwise
        -> MissingBlock blk -> Either (MissingBlock blk) blk
forall a. MissingBlock blk -> Either (MissingBlock blk) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk -> Either (MissingBlock blk) blk)
-> MissingBlock blk -> Either (MissingBlock blk) blk
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 ([HeaderHash blk] -> NonEmpty (HeaderHash blk)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
ebb])
      Just (InSlotBoth blk
ebb blk
blk)
        | blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
ebb HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash blk
hash
        -> blk -> Either (MissingBlock blk) blk
forall a. a -> Either (MissingBlock blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return blk
ebb
        | blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk HeaderHash blk -> HeaderHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderHash blk
hash
        -> blk -> Either (MissingBlock blk) blk
forall a. a -> Either (MissingBlock blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return blk
blk
        | Bool
otherwise
        -> MissingBlock blk -> Either (MissingBlock blk) blk
forall a. MissingBlock blk -> Either (MissingBlock blk) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk -> Either (MissingBlock blk) blk)
-> MissingBlock blk -> Either (MissingBlock blk) blk
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 ([HeaderHash blk] -> NonEmpty (HeaderHash blk)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList [blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
ebb, blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk])
      Maybe (InSlot blk)
Nothing
        | SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> (Tip blk -> SlotNo
forall blk. Tip blk -> SlotNo
tipSlotNo (Tip blk -> SlotNo) -> WithOrigin (Tip blk) -> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBModel blk -> WithOrigin (Tip blk)
forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip DBModel blk
dbm)
        -> MissingBlock blk -> Either (MissingBlock blk) blk
forall a. MissingBlock blk -> Either (MissingBlock blk) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk -> Either (MissingBlock blk) blk)
-> MissingBlock blk -> Either (MissingBlock blk) blk
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 (DBModel blk -> WithOrigin (Tip blk)
forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip DBModel blk
dbm))
        | Bool
otherwise
        -> MissingBlock blk -> Either (MissingBlock blk) blk
forall a. MissingBlock blk -> Either (MissingBlock blk) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (MissingBlock blk -> Either (MissingBlock blk) blk)
-> MissingBlock blk -> Either (MissingBlock blk) blk
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 (Word64 -> ChunkNo
ChunkNo Word64
0) [] Maybe (StrictSeq SecondaryOffset)
forall a. Maybe a
Nothing

-- | Rolls back the chain so that the given 'Tip' is the new tip.
--
-- PRECONDITION: the given tip must correspond to a block in the model
rollBackToTip ::
     forall blk. GetHeader blk
  => WithOrigin (Tip blk) -> DBModel blk -> DBModel blk
rollBackToTip :: forall blk.
GetHeader blk =>
WithOrigin (Tip blk) -> DBModel blk -> DBModel blk
rollBackToTip WithOrigin (Tip blk)
tip dbm :: DBModel blk
dbm@DBModel { Map SlotNo (InSlot blk)
dbmSlots :: forall blk. DBModel blk -> Map SlotNo (InSlot blk)
dbmSlots :: Map SlotNo (InSlot blk)
dbmSlots } =
    DBModel blk
dbm { dbmSlots = Map.mapMaybe shouldKeep dbmSlots }
  where
    -- Note: we're not checking hashes, we rely on the precondition
    blockNewerThanTip :: blk -> Bool
    blockNewerThanTip :: blk -> Bool
blockNewerThanTip blk
blk =
        CompareTip blk -> WithOrigin (CompareTip blk)
forall t. t -> WithOrigin t
NotOrigin (Tip blk -> CompareTip blk
forall blk. Tip blk -> CompareTip blk
CompareTip (blk -> Tip blk
forall blk. GetHeader blk => blk -> Tip blk
blockToTip blk
blk)) WithOrigin (CompareTip blk) -> WithOrigin (CompareTip blk) -> Bool
forall a. Ord a => a -> a -> Bool
> (Tip blk -> CompareTip blk
forall blk. Tip blk -> CompareTip blk
CompareTip (Tip blk -> CompareTip blk)
-> WithOrigin (Tip blk) -> WithOrigin (CompareTip blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (Tip blk)
tip)

    shouldKeep :: InSlot blk -> Maybe (InSlot blk)
    shouldKeep :: InSlot blk -> Maybe (InSlot blk)
shouldKeep = \case
        InSlotEBB blk
ebb
          | blk -> Bool
blockNewerThanTip blk
ebb
          -> Maybe (InSlot blk)
forall a. Maybe a
Nothing
          | Bool
otherwise
          -> InSlot blk -> Maybe (InSlot blk)
forall a. a -> Maybe a
Just (InSlot blk -> Maybe (InSlot blk))
-> InSlot blk -> Maybe (InSlot blk)
forall a b. (a -> b) -> a -> b
$ blk -> InSlot blk
forall blk. blk -> InSlot blk
InSlotEBB blk
ebb
        InSlotBlock blk
blk
          | blk -> Bool
blockNewerThanTip blk
blk
          -> Maybe (InSlot blk)
forall a. Maybe a
Nothing
          | Bool
otherwise
          -> InSlot blk -> Maybe (InSlot blk)
forall a. a -> Maybe a
Just (InSlot blk -> Maybe (InSlot blk))
-> InSlot blk -> Maybe (InSlot blk)
forall a b. (a -> b) -> a -> b
$ blk -> InSlot blk
forall blk. blk -> InSlot blk
InSlotBlock blk
blk
        InSlotBoth blk
ebb blk
blk
          | blk -> Bool
blockNewerThanTip blk
ebb, blk -> Bool
blockNewerThanTip blk
blk
          -> Maybe (InSlot blk)
forall a. Maybe a
Nothing
          | blk -> Bool
blockNewerThanTip blk
blk
          -> InSlot blk -> Maybe (InSlot blk)
forall a. a -> Maybe a
Just (InSlot blk -> Maybe (InSlot blk))
-> InSlot blk -> Maybe (InSlot blk)
forall a b. (a -> b) -> a -> b
$ blk -> InSlot blk
forall blk. blk -> InSlot blk
InSlotEBB blk
ebb
          | Bool
otherwise
          -> InSlot blk -> Maybe (InSlot blk)
forall a. a -> Maybe a
Just (InSlot blk -> Maybe (InSlot blk))
-> InSlot blk -> Maybe (InSlot blk)
forall a b. (a -> b) -> a -> b
$ blk -> blk -> InSlot blk
forall blk. blk -> blk -> InSlot blk
InSlotBoth blk
ebb blk
blk

-- | Return the blocks before, in, and after the given 'ChunkNo'.
blocksBeforeInAfterChunk ::
     forall blk. HasHeader blk
  => ChunkNo
  -> DBModel blk
  -> ([blk], [blk], [blk])
blocksBeforeInAfterChunk :: forall blk.
HasHeader blk =>
ChunkNo -> DBModel blk -> ([blk], [blk], [blk])
blocksBeforeInAfterChunk ChunkNo
chunk dbm :: DBModel blk
dbm@DBModel { ChunkInfo
dbmChunkInfo :: forall blk. DBModel blk -> ChunkInfo
dbmChunkInfo :: ChunkInfo
dbmChunkInfo } =
    (((blk, ChunkNo) -> blk) -> [(blk, ChunkNo)] -> [blk]
forall a b. (a -> b) -> [a] -> [b]
map (blk, ChunkNo) -> blk
forall a b. (a, b) -> a
fst [(blk, ChunkNo)]
lt, ((blk, ChunkNo) -> blk) -> [(blk, ChunkNo)] -> [blk]
forall a b. (a -> b) -> [a] -> [b]
map (blk, ChunkNo) -> blk
forall a b. (a, b) -> a
fst [(blk, ChunkNo)]
eq, ((blk, ChunkNo) -> blk) -> [(blk, ChunkNo)] -> [blk]
forall a b. (a -> b) -> [a] -> [b]
map (blk, ChunkNo) -> blk
forall a b. (a, b) -> a
fst [(blk, ChunkNo)]
gt)
  where
    blocksWithChunks :: [(blk, ChunkNo)]
    blocksWithChunks :: [(blk, ChunkNo)]
blocksWithChunks =
        [ (blk
blk, ChunkInfo -> SlotNo -> ChunkNo
chunkIndexOfSlot ChunkInfo
dbmChunkInfo (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk))
        | blk
blk <- DBModel blk -> [blk]
forall blk. DBModel blk -> [blk]
dbmBlocks DBModel blk
dbm
        ]

    ([(blk, ChunkNo)]
lt, [(blk, ChunkNo)]
geq) = ((blk, ChunkNo) -> Bool)
-> [(blk, ChunkNo)] -> ([(blk, ChunkNo)], [(blk, ChunkNo)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((ChunkNo -> ChunkNo -> Bool
forall a. Ord a => a -> a -> Bool
< ChunkNo
chunk)             (ChunkNo -> Bool)
-> ((blk, ChunkNo) -> ChunkNo) -> (blk, ChunkNo) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk, ChunkNo) -> ChunkNo
forall a b. (a, b) -> b
snd) [(blk, ChunkNo)]
blocksWithChunks
    ([(blk, ChunkNo)]
eq, [(blk, ChunkNo)]
gt)  = ((blk, ChunkNo) -> Bool)
-> [(blk, ChunkNo)] -> ([(blk, ChunkNo)], [(blk, ChunkNo)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((ChunkNo -> ChunkNo -> Bool
forall a. Ord a => a -> a -> Bool
< ChunkNo -> ChunkNo
nextChunkNo ChunkNo
chunk) (ChunkNo -> Bool)
-> ((blk, ChunkNo) -> ChunkNo) -> (blk, ChunkNo) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk, ChunkNo) -> ChunkNo
forall a b. (a, b) -> b
snd) [(blk, ChunkNo)]
geq

-- | Return the blocks in the given 'ChunkNo', in order.
blocksInChunk :: HasHeader blk => ChunkNo -> DBModel blk -> [blk]
blocksInChunk :: forall blk. HasHeader blk => ChunkNo -> DBModel blk -> [blk]
blocksInChunk ChunkNo
chunk DBModel blk
dbm = [blk]
eq
  where
    ([blk]
_lt, [blk]
eq, [blk]
_gt) = ChunkNo -> DBModel blk -> ([blk], [blk], [blk])
forall blk.
HasHeader blk =>
ChunkNo -> DBModel blk -> ([blk], [blk], [blk])
blocksBeforeInAfterChunk ChunkNo
chunk DBModel blk
dbm

properTips :: GetHeader blk => DBModel blk -> [Tip blk]
properTips :: forall blk. GetHeader blk => DBModel blk -> [Tip blk]
properTips = (blk -> Tip blk) -> [blk] -> [Tip blk]
forall a b. (a -> b) -> [a] -> [b]
map blk -> Tip blk
forall blk. GetHeader blk => blk -> Tip blk
blockToTip ([blk] -> [Tip blk])
-> (DBModel blk -> [blk]) -> DBModel blk -> [Tip blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InSlot blk -> [blk]) -> [InSlot blk] -> [blk]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap InSlot blk -> [blk]
forall blk. InSlot blk -> [blk]
go ([InSlot blk] -> [blk])
-> (DBModel blk -> [InSlot blk]) -> DBModel blk -> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SlotNo (InSlot blk) -> [InSlot blk]
forall k a. Map k a -> [a]
Map.elems (Map SlotNo (InSlot blk) -> [InSlot blk])
-> (DBModel blk -> Map SlotNo (InSlot blk))
-> DBModel blk
-> [InSlot blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBModel blk -> Map SlotNo (InSlot blk)
forall blk. DBModel blk -> Map SlotNo (InSlot blk)
dbmSlots
  where
    go :: InSlot blk -> [blk]
    go :: forall blk. InSlot blk -> [blk]
go (InSlotBlock blk
blk)     = [blk
blk]
    go (InSlotEBB   blk
ebb)     = [blk
ebb]
    go (InSlotBoth  blk
ebb blk
blk) = [blk
ebb, blk
blk]

-- | List all 'Tip's that point to a filled slot or an existing EBB in the
-- model, including 'Origin'. The tips will be sorted from old to recent.
tips ::
     GetHeader blk
  => DBModel blk
  -> NonEmpty (WithOrigin (Tip blk))
tips :: forall blk.
GetHeader blk =>
DBModel blk -> NonEmpty (WithOrigin (Tip blk))
tips DBModel blk
dbm = WithOrigin (Tip blk)
forall t. WithOrigin t
Origin WithOrigin (Tip blk)
-> [WithOrigin (Tip blk)] -> NonEmpty (WithOrigin (Tip blk))
forall a. a -> [a] -> NonEmpty a
NE.:| (Tip blk -> WithOrigin (Tip blk))
-> [Tip blk] -> [WithOrigin (Tip blk)]
forall a b. (a -> b) -> [a] -> [b]
map Tip blk -> WithOrigin (Tip blk)
forall t. t -> WithOrigin t
NotOrigin (DBModel blk -> [Tip blk]
forall blk. GetHeader blk => DBModel blk -> [Tip blk]
properTips DBModel blk
dbm)

closeAllIterators :: DBModel blk -> DBModel blk
closeAllIterators :: forall blk. DBModel blk -> DBModel blk
closeAllIterators DBModel blk
dbm = DBModel blk
dbm { dbmIterators = mempty }

{------------------------------------------------------------------------------
  Simulation corruptions and restoring afterwards
------------------------------------------------------------------------------}

-- | Simulate the following: close the database, apply the corruptions to the
-- respective files, and restore to the last valid epoch.
--
-- The resulting chain will be a prefix of the given chain.
--
-- The 'FsPath's must correspond to index or epoch files that a real database,
-- which is in sync with the given model, would have created on disk.
--
-- Returns the new tip.
simulateCorruptions ::
     (HasHeader blk, GetHeader blk, EncodeDisk blk blk)
  => Corruptions
  -> DBModel blk
  -> (WithOrigin (Tip blk), DBModel blk)
simulateCorruptions :: forall blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk) =>
Corruptions -> DBModel blk -> (WithOrigin (Tip blk), DBModel blk)
simulateCorruptions Corruptions
corrs DBModel blk
dbm = (DBModel blk -> WithOrigin (Tip blk)
forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip DBModel blk
dbm', DBModel blk
dbm')
  where
    dbm' :: DBModel blk
dbm' = DBModel blk -> DBModel blk
forall blk. DBModel blk -> DBModel blk
closeAllIterators (DBModel blk -> DBModel blk) -> DBModel blk -> DBModel blk
forall a b. (a -> b) -> a -> b
$ RollBackPoint blk -> DBModel blk -> DBModel blk
forall blk.
GetHeader blk =>
RollBackPoint blk -> DBModel blk -> DBModel blk
rollBack RollBackPoint blk
rbp DBModel blk
dbm
    -- Take the minimal 'RollBackPoint', which is the earliest.
    rbp :: RollBackPoint blk
rbp = NonEmpty (RollBackPoint blk) -> RollBackPoint blk
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (NonEmpty (RollBackPoint blk) -> RollBackPoint blk)
-> NonEmpty (RollBackPoint blk) -> RollBackPoint blk
forall a b. (a -> b) -> a -> b
$
      ((FileCorruption, FsPath) -> RollBackPoint blk)
-> Corruptions -> NonEmpty (RollBackPoint blk)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(FileCorruption
c, FsPath
f) -> FileCorruption -> FsPath -> DBModel blk -> RollBackPoint blk
forall blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk) =>
FileCorruption -> FsPath -> DBModel blk -> RollBackPoint blk
findCorruptionRollBackPoint FileCorruption
c FsPath
f DBModel blk
dbm) Corruptions
corrs

data RollBackPoint blk
  = DontRollBack
    -- ^ No roll back needed.
  | RollBackToTip (WithOrigin (Tip blk))
    -- ^ Roll back to the tip, keeping it as the last block. When 'Origin',
    -- truncate all blocks.
  deriving (RollBackPoint blk -> RollBackPoint blk -> Bool
(RollBackPoint blk -> RollBackPoint blk -> Bool)
-> (RollBackPoint blk -> RollBackPoint blk -> Bool)
-> Eq (RollBackPoint blk)
forall blk.
StandardHash blk =>
RollBackPoint blk -> RollBackPoint blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
RollBackPoint blk -> RollBackPoint blk -> Bool
== :: RollBackPoint blk -> RollBackPoint blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
RollBackPoint blk -> RollBackPoint blk -> Bool
/= :: RollBackPoint blk -> RollBackPoint blk -> Bool
Eq, Int -> RollBackPoint blk -> ShowS
[RollBackPoint blk] -> ShowS
RollBackPoint blk -> String
(Int -> RollBackPoint blk -> ShowS)
-> (RollBackPoint blk -> String)
-> ([RollBackPoint blk] -> ShowS)
-> Show (RollBackPoint blk)
forall blk. StandardHash blk => Int -> RollBackPoint blk -> ShowS
forall blk. StandardHash blk => [RollBackPoint blk] -> ShowS
forall blk. StandardHash blk => RollBackPoint blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> RollBackPoint blk -> ShowS
showsPrec :: Int -> RollBackPoint blk -> ShowS
$cshow :: forall blk. StandardHash blk => RollBackPoint blk -> String
show :: RollBackPoint blk -> String
$cshowList :: forall blk. StandardHash blk => [RollBackPoint blk] -> ShowS
showList :: [RollBackPoint blk] -> ShowS
Show, (forall x. RollBackPoint blk -> Rep (RollBackPoint blk) x)
-> (forall x. Rep (RollBackPoint blk) x -> RollBackPoint blk)
-> Generic (RollBackPoint blk)
forall x. Rep (RollBackPoint blk) x -> RollBackPoint blk
forall x. RollBackPoint blk -> Rep (RollBackPoint blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (RollBackPoint blk) x -> RollBackPoint blk
forall blk x. RollBackPoint blk -> Rep (RollBackPoint blk) x
$cfrom :: forall blk x. RollBackPoint blk -> Rep (RollBackPoint blk) x
from :: forall x. RollBackPoint blk -> Rep (RollBackPoint blk) x
$cto :: forall blk x. Rep (RollBackPoint blk) x -> RollBackPoint blk
to :: forall x. Rep (RollBackPoint blk) x -> RollBackPoint blk
Generic)

-- | The earlier 'RollBackPoint' < the later 'RollBackPoint'.
instance StandardHash blk => Ord (RollBackPoint blk) where
  compare :: RollBackPoint blk -> RollBackPoint blk -> Ordering
compare RollBackPoint blk
r1 RollBackPoint blk
r2 = case (RollBackPoint blk
r1, RollBackPoint blk
r2) of
    (RollBackPoint blk
DontRollBack, RollBackPoint blk
DontRollBack)         -> Ordering
EQ
    (RollBackPoint blk
_,            RollBackPoint blk
DontRollBack)         -> Ordering
LT
    (RollBackPoint blk
DontRollBack, RollBackPoint blk
_)                    -> Ordering
GT
    (RollBackToTip WithOrigin (Tip blk)
t1, RollBackToTip WithOrigin (Tip blk)
t2) ->
      WithOrigin (CompareTip blk)
-> WithOrigin (CompareTip blk) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Tip blk -> CompareTip blk
forall blk. Tip blk -> CompareTip blk
CompareTip (Tip blk -> CompareTip blk)
-> WithOrigin (Tip blk) -> WithOrigin (CompareTip blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (Tip blk)
t1) (Tip blk -> CompareTip blk
forall blk. Tip blk -> CompareTip blk
CompareTip (Tip blk -> CompareTip blk)
-> WithOrigin (Tip blk) -> WithOrigin (CompareTip blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (Tip blk)
t2)

rollBack ::
     GetHeader blk
  => RollBackPoint blk -> DBModel blk -> DBModel blk
rollBack :: forall blk.
GetHeader blk =>
RollBackPoint blk -> DBModel blk -> DBModel blk
rollBack RollBackPoint blk
rbp DBModel blk
dbm = case RollBackPoint blk
rbp of
    RollBackPoint blk
DontRollBack      -> DBModel blk
dbm
    RollBackToTip WithOrigin (Tip blk)
tip -> WithOrigin (Tip blk) -> DBModel blk -> DBModel blk
forall blk.
GetHeader blk =>
WithOrigin (Tip blk) -> DBModel blk -> DBModel blk
rollBackToTip WithOrigin (Tip blk)
tip DBModel blk
dbm

findCorruptionRollBackPoint ::
     (HasHeader blk, GetHeader blk, EncodeDisk blk blk)
  => FileCorruption
  -> FsPath
  -> DBModel blk
  -> RollBackPoint blk
findCorruptionRollBackPoint :: forall blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk) =>
FileCorruption -> FsPath -> DBModel blk -> RollBackPoint blk
findCorruptionRollBackPoint FileCorruption
corr FsPath
file DBModel blk
dbm =
    case (Text -> String
Text.unpack (Text -> String)
-> ((FsPath, Text) -> Text) -> (FsPath, Text) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FsPath, Text) -> Text
forall a b. (a, b) -> b
snd ((FsPath, Text) -> String) -> Maybe (FsPath, Text) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FsPath -> Maybe (FsPath, Text)
fsPathSplit FsPath
file) Maybe String
-> (String -> Maybe (String, ChunkNo)) -> Maybe (String, ChunkNo)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe (String, ChunkNo)
parseDBFile of
      Just (String
"chunk",      ChunkNo
chunk) -> FileCorruption -> ChunkNo -> DBModel blk -> RollBackPoint blk
forall blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk) =>
FileCorruption -> ChunkNo -> DBModel blk -> RollBackPoint blk
findCorruptionRollBackForChunk FileCorruption
corr ChunkNo
chunk DBModel blk
dbm
      -- Index files are always recoverable
      Just (String
"primary",   ChunkNo
_chunk) -> RollBackPoint blk
forall blk. RollBackPoint blk
DontRollBack
      Just (String
"secondary", ChunkNo
_chunk) -> RollBackPoint blk
forall blk. RollBackPoint blk
DontRollBack
      Maybe (String, ChunkNo)
_                          -> String -> RollBackPoint blk
forall a. HasCallStack => String -> a
error String
"Invalid file to corrupt"

findCorruptionRollBackForChunk ::
     (HasHeader blk, GetHeader blk, EncodeDisk blk blk)
  => FileCorruption
  -> ChunkNo
  -> DBModel blk
  -> RollBackPoint blk
findCorruptionRollBackForChunk :: forall blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk) =>
FileCorruption -> ChunkNo -> DBModel blk -> RollBackPoint blk
findCorruptionRollBackForChunk FileCorruption
corr ChunkNo
chunk DBModel blk
dbm = case FileCorruption
corr of
    FileCorruption
DeleteFile      -> ChunkNo -> DBModel blk -> RollBackPoint blk
forall blk.
(HasHeader blk, GetHeader blk) =>
ChunkNo -> DBModel blk -> RollBackPoint blk
rollbackToLastFilledSlotBefore    ChunkNo
chunk DBModel blk
dbm

    DropLastBytes Word64
n -> Word64 -> ChunkNo -> DBModel blk -> RollBackPoint blk
forall blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk) =>
Word64 -> ChunkNo -> DBModel blk -> RollBackPoint blk
findRollBackPointForOffsetInChunk Word64
validBytes ChunkNo
chunk DBModel blk
dbm
      where
        validBytes :: Word64
validBytes | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
totalBytes = Word64
0
                   | Bool
otherwise       = Word64
totalBytes Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
n

    Corrupt Word64
n       -> Word64 -> ChunkNo -> DBModel blk -> RollBackPoint blk
forall blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk) =>
Word64 -> ChunkNo -> DBModel blk -> RollBackPoint blk
findRollBackPointForOffsetInChunk Word64
validBytes ChunkNo
chunk DBModel blk
dbm
      where
        validBytes :: Word64
validBytes = Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
totalBytes
  where
    totalBytes :: Word64
    totalBytes :: Word64
totalBytes =
          [Word64] -> Word64
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
        ([Word64] -> Word64)
-> (DBModel blk -> [Word64]) -> DBModel blk -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> Word64) -> [blk] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map (CodecConfig blk -> blk -> Word64
forall blk. EncodeDisk blk blk => CodecConfig blk -> blk -> Word64
computeBlockSize (DBModel blk -> CodecConfig blk
forall blk. DBModel blk -> CodecConfig blk
dbmCodecConfig DBModel blk
dbm))
        ([blk] -> [Word64])
-> (DBModel blk -> [blk]) -> DBModel blk -> [Word64]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChunkNo -> DBModel blk -> [blk]
forall blk. HasHeader blk => ChunkNo -> DBModel blk -> [blk]
blocksInChunk ChunkNo
chunk
        (DBModel blk -> Word64) -> DBModel blk -> Word64
forall a b. (a -> b) -> a -> b
$ DBModel blk
dbm

findRollBackPointForOffsetInChunk ::
     forall blk. (HasHeader blk, GetHeader blk, EncodeDisk blk blk)
  => Word64  -- ^ The number of valid bytes in the chunk, the corruption happens
             -- at the first byte after it.
  -> ChunkNo -> DBModel blk -> RollBackPoint blk
findRollBackPointForOffsetInChunk :: forall blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk) =>
Word64 -> ChunkNo -> DBModel blk -> RollBackPoint blk
findRollBackPointForOffsetInChunk Word64
validBytes ChunkNo
chunk dbm :: DBModel blk
dbm@DBModel { CodecConfig blk
dbmCodecConfig :: forall blk. DBModel blk -> CodecConfig blk
dbmCodecConfig :: CodecConfig blk
dbmCodecConfig }
    | [blk] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [blk]
blocksInThisChunk
      -- If the file is empty, no corruption happened, and we don't have to
      -- roll back
    = RollBackPoint blk
forall blk. RollBackPoint blk
DontRollBack
    | Just Tip blk
lastValidTip <- Maybe (Tip blk)
mbLastValidTip
    = WithOrigin (Tip blk) -> RollBackPoint blk
forall blk. WithOrigin (Tip blk) -> RollBackPoint blk
RollBackToTip (Tip blk -> WithOrigin (Tip blk)
forall t. t -> WithOrigin t
NotOrigin Tip blk
lastValidTip)
    | Bool
otherwise
      -- When there are no more filled slots in the epoch file, roll back to
      -- the last filled slot before the epoch.
    = ChunkNo -> DBModel blk -> RollBackPoint blk
forall blk.
(HasHeader blk, GetHeader blk) =>
ChunkNo -> DBModel blk -> RollBackPoint blk
rollbackToLastFilledSlotBefore ChunkNo
chunk DBModel blk
dbm
  where
    blocksInThisChunk :: [blk]
    blocksInThisChunk :: [blk]
blocksInThisChunk = ChunkNo -> DBModel blk -> [blk]
forall blk. HasHeader blk => ChunkNo -> DBModel blk -> [blk]
blocksInChunk ChunkNo
chunk DBModel blk
dbm

    mbLastValidTip :: Maybe (Tip blk)
    mbLastValidTip :: Maybe (Tip blk)
mbLastValidTip = Word64 -> Maybe (Tip blk) -> [blk] -> Maybe (Tip blk)
go Word64
0 Maybe (Tip blk)
forall a. Maybe a
Nothing [blk]
blocksInThisChunk
      where
        go :: Word64 -> Maybe (Tip blk) -> [blk] -> Maybe (Tip blk)
        go :: Word64 -> Maybe (Tip blk) -> [blk] -> Maybe (Tip blk)
go Word64
curOffset Maybe (Tip blk)
lastValid = \case
          [] -> Maybe (Tip blk)
lastValid
          blk
blk:[blk]
blks
              | let blockSize :: Word64
blockSize = CodecConfig blk -> blk -> Word64
forall blk. EncodeDisk blk blk => CodecConfig blk -> blk -> Word64
computeBlockSize CodecConfig blk
dbmCodecConfig blk
blk
              , Word64
curOffset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
blockSize Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
validBytes
              -> Word64 -> Maybe (Tip blk) -> [blk] -> Maybe (Tip blk)
go (Word64
curOffset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
blockSize) (Tip blk -> Maybe (Tip blk)
forall a. a -> Maybe a
Just (blk -> Tip blk
forall blk. GetHeader blk => blk -> Tip blk
blockToTip blk
blk)) [blk]
blks
              | Bool
otherwise
              -> Maybe (Tip blk)
lastValid

rollbackToLastFilledSlotBefore ::
     (HasHeader blk, GetHeader blk)
  => ChunkNo -> DBModel blk -> RollBackPoint blk
rollbackToLastFilledSlotBefore :: forall blk.
(HasHeader blk, GetHeader blk) =>
ChunkNo -> DBModel blk -> RollBackPoint blk
rollbackToLastFilledSlotBefore ChunkNo
chunk DBModel blk
dbm = case [blk] -> Maybe blk
forall a. [a] -> Maybe a
lastMaybe [blk]
beforeChunk of
    Maybe blk
Nothing              -> WithOrigin (Tip blk) -> RollBackPoint blk
forall blk. WithOrigin (Tip blk) -> RollBackPoint blk
RollBackToTip WithOrigin (Tip blk)
forall t. WithOrigin t
Origin
    Just blk
lastBlockBefore ->
      WithOrigin (Tip blk) -> RollBackPoint blk
forall blk. WithOrigin (Tip blk) -> RollBackPoint blk
RollBackToTip (Tip blk -> WithOrigin (Tip blk)
forall t. t -> WithOrigin t
NotOrigin (blk -> Tip blk
forall blk. GetHeader blk => blk -> Tip blk
blockToTip blk
lastBlockBefore))
  where
    ([blk]
beforeChunk, [blk]
_, [blk]
_) = ChunkNo -> DBModel blk -> ([blk], [blk], [blk])
forall blk.
HasHeader blk =>
ChunkNo -> DBModel blk -> ([blk], [blk], [blk])
blocksBeforeInAfterChunk ChunkNo
chunk DBModel blk
dbm

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

getTipModel ::
     GetHeader blk
  => DBModel blk -> WithOrigin (Tip blk)
getTipModel :: forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
getTipModel = DBModel blk -> WithOrigin (Tip blk)
forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip

-- | Close all open iterators and return the current tip
reopenModel ::
     GetHeader blk
  => DBModel blk -> (WithOrigin (Tip blk), DBModel blk)
reopenModel :: forall blk.
GetHeader blk =>
DBModel blk -> (WithOrigin (Tip blk), DBModel blk)
reopenModel DBModel blk
dbm = (DBModel blk -> WithOrigin (Tip blk)
forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip DBModel blk
dbm, DBModel blk -> DBModel blk
forall blk. DBModel blk -> DBModel blk
closeAllIterators DBModel blk
dbm)

deleteAfterModel ::
     GetHeader blk
  => WithOrigin (Tip blk) -> DBModel blk -> DBModel blk
deleteAfterModel :: forall blk.
GetHeader blk =>
WithOrigin (Tip blk) -> DBModel blk -> DBModel blk
deleteAfterModel WithOrigin (Tip blk)
tip = WithOrigin (Tip blk) -> DBModel blk -> DBModel blk
forall blk.
GetHeader blk =>
WithOrigin (Tip blk) -> DBModel blk -> DBModel blk
rollBackToTip WithOrigin (Tip blk)
tip (DBModel blk -> DBModel blk)
-> (DBModel blk -> DBModel blk) -> DBModel blk -> DBModel blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBModel blk -> DBModel blk
forall blk. DBModel blk -> DBModel blk
closeAllIterators

getHashForSlotModel ::
     (HasHeader blk)
  => SlotNo -> DBModel blk -> Maybe (HeaderHash blk)
getHashForSlotModel :: forall blk.
HasHeader blk =>
SlotNo -> DBModel blk -> Maybe (HeaderHash blk)
getHashForSlotModel SlotNo
slotNo DBModel blk
dbm = case SlotNo -> Map SlotNo (InSlot blk) -> Maybe (InSlot blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SlotNo
slotNo (DBModel blk -> Map SlotNo (InSlot blk)
forall blk. DBModel blk -> Map SlotNo (InSlot blk)
dbmSlots DBModel blk
dbm) of
    Just (InSlotBlock  blk
blk) -> HeaderHash blk -> Maybe (HeaderHash blk)
forall a. a -> Maybe a
Just (HeaderHash blk -> Maybe (HeaderHash blk))
-> HeaderHash blk -> Maybe (HeaderHash blk)
forall a b. (a -> b) -> a -> b
$ blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk
    Just (InSlotEBB    blk
blk) -> HeaderHash blk -> Maybe (HeaderHash blk)
forall a. a -> Maybe a
Just (HeaderHash blk -> Maybe (HeaderHash blk))
-> HeaderHash blk -> Maybe (HeaderHash blk)
forall a b. (a -> b) -> a -> b
$ blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk
    Just (InSlotBoth blk
_ blk
blk) -> HeaderHash blk -> Maybe (HeaderHash blk)
forall a. a -> Maybe a
Just (HeaderHash blk -> Maybe (HeaderHash blk))
-> HeaderHash blk -> Maybe (HeaderHash blk)
forall a b. (a -> b) -> a -> b
$ blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk
    Maybe (InSlot blk)
Nothing                 -> Maybe (HeaderHash blk)
forall a. Maybe a
Nothing

extractBlockComponent ::
     forall blk b.
     ( HasHeader blk
     , GetHeader blk
     , EncodeDisk blk blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     )
  => CodecConfig blk
  -> blk
  -> BlockComponent blk b
  -> b
extractBlockComponent :: forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
CodecConfig blk -> blk -> BlockComponent blk b -> b
extractBlockComponent CodecConfig blk
ccfg blk
blk = \case
    BlockComponent blk b
GetVerifiedBlock -> blk
b
blk  -- We don't verify
    BlockComponent blk b
GetBlock         -> blk
b
blk
    BlockComponent blk b
GetRawBlock      -> b
ByteString
rawBlk
    BlockComponent blk b
GetHeader        -> blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk
    BlockComponent blk b
GetRawHeader     -> b
ByteString
rawHdr
    BlockComponent blk b
GetHash          -> blk -> HeaderHash blk
forall b. HasHeader b => b -> HeaderHash b
blockHash blk
blk
    BlockComponent blk b
GetSlot          -> blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk
    BlockComponent blk b
GetIsEBB         -> blk -> IsEBB
forall blk. GetHeader blk => blk -> IsEBB
blockToIsEBB blk
blk
    BlockComponent blk b
GetBlockSize     -> Int64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> b) -> Int64 -> b
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
Lazy.length ByteString
rawBlk
    BlockComponent blk b
GetHeaderSize    -> Int64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> b) -> Int64 -> b
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
Lazy.length ByteString
rawHdr
    BlockComponent blk b
GetNestedCtxt    -> b
SomeSecond (NestedCtxt Header) blk
nestedCtxt
    GetPure b
a        -> b
a
    GetApply BlockComponent blk (a1 -> b)
f BlockComponent blk a1
bc    ->
      CodecConfig blk -> blk -> BlockComponent blk (a1 -> b) -> a1 -> b
forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
CodecConfig blk -> blk -> BlockComponent blk b -> b
extractBlockComponent CodecConfig blk
ccfg blk
blk BlockComponent blk (a1 -> b)
f (a1 -> b) -> a1 -> b
forall a b. (a -> b) -> a -> b
$
      CodecConfig blk -> blk -> BlockComponent blk a1 -> a1
forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
CodecConfig blk -> blk -> BlockComponent blk b -> b
extractBlockComponent CodecConfig blk
ccfg blk
blk BlockComponent blk a1
bc
  where
    rawBlk :: Lazy.ByteString
    rawBlk :: ByteString
rawBlk = Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ CodecConfig blk -> blk -> Encoding
forall blk a. EncodeDisk blk a => CodecConfig blk -> a -> Encoding
encodeDisk CodecConfig blk
ccfg blk
blk

    rawHdr :: Lazy.ByteString
    nestedCtxt :: SomeSecond (NestedCtxt Header) blk
    (SomeSecond (NestedCtxt Header) blk
nestedCtxt, ByteString
rawHdr) = case Header blk -> DepPair (NestedCtxt Header blk)
forall (f :: * -> *) blk.
HasNestedContent f blk =>
f blk -> DepPair (NestedCtxt f blk)
unnest (blk -> Header blk
forall blk. GetHeader blk => blk -> Header blk
getHeader blk
blk) of
        DepPair NestedCtxt Header blk a
ctxt a
h ->
          ( NestedCtxt Header blk a -> SomeSecond (NestedCtxt Header) blk
forall {k1} {k2} (f :: k1 -> k2 -> *) (a :: k1) (b :: k2).
f a b -> SomeSecond f a
SomeSecond NestedCtxt Header blk a
ctxt
          , Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ CodecConfig blk -> NestedCtxt Header blk a -> a -> Encoding
forall a.
CodecConfig blk -> NestedCtxt Header blk a -> a -> Encoding
forall (f :: * -> * -> *) blk a.
EncodeDiskDep f blk =>
CodecConfig blk -> f blk a -> a -> Encoding
encodeDiskDep CodecConfig blk
ccfg NestedCtxt Header blk a
ctxt a
h
          )

getBlockComponentModel ::
     ( HasHeader blk
     , GetHeader blk
     , EncodeDisk blk blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     )
  => BlockComponent blk b
  -> RealPoint blk
  -> DBModel blk
  -> Either (MissingBlock blk) b
getBlockComponentModel :: forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
BlockComponent blk b
-> RealPoint blk -> DBModel blk -> Either (MissingBlock blk) b
getBlockComponentModel BlockComponent blk b
blockComponent RealPoint blk
pt DBModel blk
dbm =
    (blk -> BlockComponent blk b -> b)
-> BlockComponent blk b -> blk -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CodecConfig blk -> blk -> BlockComponent blk b -> b
forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
CodecConfig blk -> blk -> BlockComponent blk b -> b
extractBlockComponent CodecConfig blk
ccfg) BlockComponent blk b
blockComponent
      (blk -> b)
-> Either (MissingBlock blk) blk -> Either (MissingBlock blk) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
forall blk.
(HasHeader blk, GetHeader blk) =>
RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
lookupBlock RealPoint blk
pt DBModel blk
dbm
  where
    DBModel { dbmCodecConfig :: forall blk. DBModel blk -> CodecConfig blk
dbmCodecConfig = CodecConfig blk
ccfg } = DBModel blk
dbm

appendBlockModel ::
     forall blk. (HasHeader blk, GetHeader blk, HasCallStack)
  => blk
  -> DBModel blk
  -> Either (ImmutableDBError blk) (DBModel blk)
appendBlockModel :: forall blk.
(HasHeader blk, GetHeader blk, HasCallStack) =>
blk -> DBModel blk -> Either (ImmutableDBError blk) (DBModel blk)
appendBlockModel blk
blk dbm :: DBModel blk
dbm@DBModel { Map SlotNo (InSlot blk)
dbmSlots :: forall blk. DBModel blk -> Map SlotNo (InSlot blk)
dbmSlots :: Map SlotNo (InSlot blk)
dbmSlots } = do
    -- Check that we're not appending to the past
    let inThePast :: Bool
inThePast =
          CompareTip blk -> WithOrigin (CompareTip blk)
forall t. t -> WithOrigin t
NotOrigin (Tip blk -> CompareTip blk
forall blk. Tip blk -> CompareTip blk
CompareTip Tip blk
blockTip) WithOrigin (CompareTip blk) -> WithOrigin (CompareTip blk) -> Bool
forall a. Ord a => a -> a -> Bool
<= (Tip blk -> CompareTip blk
forall blk. Tip blk -> CompareTip blk
CompareTip (Tip blk -> CompareTip blk)
-> WithOrigin (Tip blk) -> WithOrigin (CompareTip blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBModel blk -> WithOrigin (Tip blk)
forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip DBModel blk
dbm)

    Bool
-> Either (ImmutableDBError blk) ()
-> Either (ImmutableDBError blk) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
inThePast (Either (ImmutableDBError blk) ()
 -> Either (ImmutableDBError blk) ())
-> Either (ImmutableDBError blk) ()
-> Either (ImmutableDBError blk) ()
forall a b. (a -> b) -> a -> b
$
      ApiMisuse blk -> Either (ImmutableDBError blk) ()
forall blk (m :: * -> *) a.
(MonadError (ImmutableDBError blk) m, HasCallStack) =>
ApiMisuse blk -> m a
throwApiMisuse (ApiMisuse blk -> Either (ImmutableDBError blk) ())
-> ApiMisuse blk -> Either (ImmutableDBError blk) ()
forall a b. (a -> b) -> a -> b
$
        RealPoint blk -> Point blk -> ApiMisuse blk
forall blk. RealPoint blk -> Point blk -> ApiMisuse blk
AppendBlockNotNewerThanTipError
          (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk)
          (WithOrigin (Tip blk) -> Point blk
forall blk. WithOrigin (Tip blk) -> Point blk
tipToPoint (DBModel blk -> WithOrigin (Tip blk)
forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
dbmTip DBModel blk
dbm))

    DBModel blk -> Either (ImmutableDBError blk) (DBModel blk)
forall a. a -> Either (ImmutableDBError blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return DBModel blk
dbm { dbmSlots = insertInSlot blk dbmSlots }
  where
    blockTip :: Tip blk
blockTip = blk -> Tip blk
forall blk. GetHeader blk => blk -> Tip blk
blockToTip blk
blk

streamModel ::
     forall blk. (HasHeader blk, GetHeader blk, HasCallStack)
  => StreamFrom blk
  -> StreamTo   blk
  -> DBModel blk
  -> Either (ImmutableDBError blk)
            (Either (MissingBlock blk)
                    (IteratorId, DBModel blk))
streamModel :: forall blk.
(HasHeader blk, GetHeader blk, HasCallStack) =>
StreamFrom blk
-> StreamTo blk
-> DBModel blk
-> Either
     (ImmutableDBError blk)
     (Either (MissingBlock blk) (Int, DBModel blk))
streamModel StreamFrom blk
from StreamTo blk
to DBModel blk
dbm = Either
  (Either (ImmutableDBError blk) (MissingBlock blk))
  (Int, DBModel blk)
-> Either
     (ImmutableDBError blk)
     (Either (MissingBlock blk) (Int, DBModel blk))
forall a.
Either (Either (ImmutableDBError blk) (MissingBlock blk)) a
-> Either (ImmutableDBError blk) (Either (MissingBlock blk) a)
swizzle (Either
   (Either (ImmutableDBError blk) (MissingBlock blk))
   (Int, DBModel blk)
 -> Either
      (ImmutableDBError blk)
      (Either (MissingBlock blk) (Int, DBModel blk)))
-> Either
     (Either (ImmutableDBError blk) (MissingBlock blk))
     (Int, DBModel blk)
-> Either
     (ImmutableDBError blk)
     (Either (MissingBlock blk) (Int, DBModel blk))
forall a b. (a -> b) -> a -> b
$ do
    Bool
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
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) (Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
 -> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ())
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
forall a b. (a -> b) -> a -> b
$
      Either (ImmutableDBError blk) ()
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
forall {a} {c} {b}. Either a c -> Either (Either a b) c
liftLeft (Either (ImmutableDBError blk) ()
 -> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ())
-> Either (ImmutableDBError blk) ()
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
forall a b. (a -> b) -> a -> b
$ ApiMisuse blk -> Either (ImmutableDBError blk) ()
forall blk (m :: * -> *) a.
(MonadError (ImmutableDBError blk) m, HasCallStack) =>
ApiMisuse blk -> m a
throwApiMisuse (ApiMisuse blk -> Either (ImmutableDBError blk) ())
-> ApiMisuse blk -> Either (ImmutableDBError blk) ()
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

    -- The real implementation checks the end bound first, so we do the
    -- same to get the same errors
    Tip blk
toTip <- Either (MissingBlock blk) (Tip blk)
-> Either
     (Either (ImmutableDBError blk) (MissingBlock blk)) (Tip blk)
forall {a} {c} {a}. Either a c -> Either (Either a a) c
liftRight (Either (MissingBlock blk) (Tip blk)
 -> Either
      (Either (ImmutableDBError blk) (MissingBlock blk)) (Tip blk))
-> Either (MissingBlock blk) (Tip blk)
-> Either
     (Either (ImmutableDBError blk) (MissingBlock blk)) (Tip blk)
forall a b. (a -> b) -> a -> b
$ blk -> Tip blk
forall blk. GetHeader blk => blk -> Tip blk
blockToTip (blk -> Tip blk)
-> Either (MissingBlock blk) blk
-> Either (MissingBlock blk) (Tip blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case StreamTo blk
to of
      StreamToInclusive RealPoint blk
pt -> RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
forall blk.
(HasHeader blk, GetHeader blk) =>
RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
lookupBlock RealPoint blk
pt DBModel blk
dbm

    WithOrigin (Tip blk)
fromTip <- Either (MissingBlock blk) (WithOrigin (Tip blk))
-> Either
     (Either (ImmutableDBError blk) (MissingBlock blk))
     (WithOrigin (Tip blk))
forall {a} {c} {a}. Either a c -> Either (Either a a) c
liftRight (Either (MissingBlock blk) (WithOrigin (Tip blk))
 -> Either
      (Either (ImmutableDBError blk) (MissingBlock blk))
      (WithOrigin (Tip blk)))
-> Either (MissingBlock blk) (WithOrigin (Tip blk))
-> Either
     (Either (ImmutableDBError blk) (MissingBlock blk))
     (WithOrigin (Tip blk))
forall a b. (a -> b) -> a -> b
$ (blk -> Tip blk) -> WithOrigin blk -> WithOrigin (Tip blk)
forall a b. (a -> b) -> WithOrigin a -> WithOrigin b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap blk -> Tip blk
forall blk. GetHeader blk => blk -> Tip blk
blockToTip (WithOrigin blk -> WithOrigin (Tip blk))
-> Either (MissingBlock blk) (WithOrigin blk)
-> Either (MissingBlock blk) (WithOrigin (Tip blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case StreamFrom blk
from of
      StreamFromInclusive RealPoint blk
pt -> blk -> WithOrigin blk
forall t. t -> WithOrigin t
NotOrigin (blk -> WithOrigin blk)
-> Either (MissingBlock blk) blk
-> Either (MissingBlock blk) (WithOrigin blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
forall blk.
(HasHeader blk, GetHeader blk) =>
RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
lookupBlock RealPoint blk
pt DBModel blk
dbm
      StreamFromExclusive Point blk
pt -> case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
pt of
        WithOrigin (RealPoint blk)
Origin        -> WithOrigin blk -> Either (MissingBlock blk) (WithOrigin blk)
forall a. a -> Either (MissingBlock blk) a
forall (m :: * -> *) a. Monad m => a -> m a
return WithOrigin blk
forall t. WithOrigin t
Origin
        NotOrigin RealPoint blk
pt' -> blk -> WithOrigin blk
forall t. t -> WithOrigin t
NotOrigin (blk -> WithOrigin blk)
-> Either (MissingBlock blk) blk
-> Either (MissingBlock blk) (WithOrigin blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
forall blk.
(HasHeader blk, GetHeader blk) =>
RealPoint blk -> DBModel blk -> Either (MissingBlock blk) blk
lookupBlock RealPoint blk
pt' DBModel blk
dbm

    --  validBounds can't check based on the points that we're not trying to
    --  stream from the regular block to the EBB in the same slot, so do that
    --  now, like in the real implementation.
    Bool
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Tip blk -> CompareTip blk
forall blk. Tip blk -> CompareTip blk
CompareTip (Tip blk -> CompareTip blk)
-> WithOrigin (Tip blk) -> WithOrigin (CompareTip blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (Tip blk)
fromTip) WithOrigin (CompareTip blk) -> WithOrigin (CompareTip blk) -> Bool
forall a. Ord a => a -> a -> Bool
> CompareTip blk -> WithOrigin (CompareTip blk)
forall t. t -> WithOrigin t
NotOrigin (Tip blk -> CompareTip blk
forall blk. Tip blk -> CompareTip blk
CompareTip Tip blk
toTip)) (Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
 -> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ())
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
forall a b. (a -> b) -> a -> b
$
      Either (ImmutableDBError blk) ()
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
forall {a} {c} {b}. Either a c -> Either (Either a b) c
liftLeft (Either (ImmutableDBError blk) ()
 -> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ())
-> Either (ImmutableDBError blk) ()
-> Either (Either (ImmutableDBError blk) (MissingBlock blk)) ()
forall a b. (a -> b) -> a -> b
$ ApiMisuse blk -> Either (ImmutableDBError blk) ()
forall blk (m :: * -> *) a.
(MonadError (ImmutableDBError blk) m, HasCallStack) =>
ApiMisuse blk -> m a
throwApiMisuse (ApiMisuse blk -> Either (ImmutableDBError blk) ())
-> ApiMisuse blk -> Either (ImmutableDBError blk) ()
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

    let blks :: [blk]
blks =
            StreamTo blk -> [blk] -> [blk]
applyUpperBound StreamTo blk
to
          ([blk] -> [blk]) -> (DBModel blk -> [blk]) -> DBModel blk -> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamFrom blk -> [blk] -> [blk]
applyLowerBound StreamFrom blk
from
          ([blk] -> [blk]) -> (DBModel blk -> [blk]) -> DBModel blk -> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBModel blk -> [blk]
forall blk. DBModel blk -> [blk]
dbmBlocks
          (DBModel blk -> [blk]) -> DBModel blk -> [blk]
forall a b. (a -> b) -> a -> b
$ DBModel blk
dbm
        itm :: IteratorModel blk
itm  = [blk] -> IteratorModel blk
forall blk. [blk] -> IteratorModel blk
IteratorModel [blk]
blks
        itId :: Int
itId = Int
dbmNextIterator
        dbm' :: DBModel blk
dbm' = DBModel blk
dbm {
            dbmNextIterator = succ dbmNextIterator
          , dbmIterators    = Map.insert itId itm dbmIterators
          }
    (Int, DBModel blk)
-> Either
     (Either (ImmutableDBError blk) (MissingBlock blk))
     (Int, DBModel blk)
forall a.
a -> Either (Either (ImmutableDBError blk) (MissingBlock blk)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
itId, DBModel blk
dbm')
  where
    DBModel { Int
dbmNextIterator :: forall blk. DBModel blk -> Int
dbmNextIterator :: Int
dbmNextIterator, Map Int (IteratorModel blk)
dbmIterators :: forall blk. DBModel blk -> Map Int (IteratorModel blk)
dbmIterators :: Map Int (IteratorModel blk)
dbmIterators } = DBModel blk
dbm

    liftLeft :: Either a c -> Either (Either a b) c
liftLeft  = (a -> Either a b) -> Either a c -> Either (Either a b) c
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> Either a b
forall a b. a -> Either a b
Left
    liftRight :: Either a c -> Either (Either a a) c
liftRight = (a -> Either a a) -> Either a c -> Either (Either a a) c
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> Either a a
forall a b. b -> Either a b
Right

    swizzle :: Either (Either (ImmutableDBError blk) (MissingBlock blk)) a
            -> Either (ImmutableDBError blk) (Either (MissingBlock blk) a)
    swizzle :: forall a.
Either (Either (ImmutableDBError blk) (MissingBlock blk)) a
-> Either (ImmutableDBError blk) (Either (MissingBlock blk) a)
swizzle (Left (Left ImmutableDBError blk
e))  = ImmutableDBError blk
-> Either (ImmutableDBError blk) (Either (MissingBlock blk) a)
forall a b. a -> Either a b
Left ImmutableDBError blk
e
    swizzle (Left (Right MissingBlock blk
e)) = Either (MissingBlock blk) a
-> Either (ImmutableDBError blk) (Either (MissingBlock blk) a)
forall a b. b -> Either a b
Right (MissingBlock blk -> Either (MissingBlock blk) a
forall a b. a -> Either a b
Left MissingBlock blk
e)
    swizzle (Right a
a)        = Either (MissingBlock blk) a
-> Either (ImmutableDBError blk) (Either (MissingBlock blk) a)
forall a b. b -> Either a b
Right (a -> Either (MissingBlock blk) a
forall a b. b -> Either a b
Right a
a)

    applyLowerBound :: StreamFrom blk -> [blk] -> [blk]
    applyLowerBound :: StreamFrom blk -> [blk] -> [blk]
applyLowerBound = \case
        StreamFromExclusive Point blk
pt -> case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point blk
pt of
          WithOrigin (RealPoint blk)
Origin        -> [blk] -> [blk]
forall a. a -> a
id
          NotOrigin RealPoint blk
pt' -> Int -> [blk] -> [blk]
forall a. Int -> [a] -> [a]
drop Int
1 ([blk] -> [blk]) -> ([blk] -> [blk]) -> [blk] -> [blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (blk -> Bool) -> [blk] -> [blk]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((RealPoint blk -> RealPoint blk -> Bool
forall a. Eq a => a -> a -> Bool
/= RealPoint blk
pt') (RealPoint blk -> Bool) -> (blk -> RealPoint blk) -> blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint)
        StreamFromInclusive RealPoint blk
pt -> (blk -> Bool) -> [blk] -> [blk]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((RealPoint blk -> RealPoint blk -> Bool
forall a. Eq a => a -> a -> Bool
/= RealPoint blk
pt) (RealPoint blk -> Bool) -> (blk -> RealPoint blk) -> blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint)

    applyUpperBound :: StreamTo blk -> [blk] -> [blk]
    applyUpperBound :: StreamTo blk -> [blk] -> [blk]
applyUpperBound (StreamToInclusive RealPoint blk
pt) =
        (blk -> Bool) -> [blk] -> [blk]
forall a. (a -> Bool) -> [a] -> [a]
takeUntil ((RealPoint blk -> RealPoint blk -> Bool
forall a. Eq a => a -> a -> Bool
== RealPoint blk
pt) (RealPoint blk -> Bool) -> (blk -> RealPoint blk) -> blk -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint)

streamAllModel ::
     ( HasHeader blk
     , GetHeader blk
     , EncodeDisk blk blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     )
  => BlockComponent blk b
  -> DBModel blk
  -> [b]
streamAllModel :: forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
BlockComponent blk b -> DBModel blk -> [b]
streamAllModel BlockComponent blk b
blockComponent dbm :: DBModel blk
dbm@DBModel { dbmCodecConfig :: forall blk. DBModel blk -> CodecConfig blk
dbmCodecConfig = CodecConfig blk
ccfg } =
      (blk -> b) -> [blk] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map ((blk -> BlockComponent blk b -> b)
-> BlockComponent blk b -> blk -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (CodecConfig blk -> blk -> BlockComponent blk b -> b
forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
CodecConfig blk -> blk -> BlockComponent blk b -> b
extractBlockComponent CodecConfig blk
ccfg) BlockComponent blk b
blockComponent)
    ([blk] -> [b]) -> (DBModel blk -> [blk]) -> DBModel blk -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DBModel blk -> [blk]
forall blk. DBModel blk -> [blk]
dbmBlocks
    (DBModel blk -> [b]) -> DBModel blk -> [b]
forall a b. (a -> b) -> a -> b
$ DBModel blk
dbm

iteratorNextModel ::
     ( HasHeader blk
     , GetHeader blk
     , EncodeDisk blk blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     )
  => IteratorId
  -> BlockComponent blk b
  -> DBModel blk
  -> (IteratorResult b, DBModel blk)
iteratorNextModel :: forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
Int
-> BlockComponent blk b
-> DBModel blk
-> (IteratorResult b, DBModel blk)
iteratorNextModel Int
itId BlockComponent blk b
blockComponent DBModel blk
dbm =
    case Int -> Map Int (IteratorModel blk) -> Maybe (IteratorModel blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
itId Map Int (IteratorModel blk)
dbmIterators of
      Maybe (IteratorModel blk)
Nothing ->
          (IteratorResult b
forall b. IteratorResult b
IteratorExhausted, DBModel blk
dbm)

      Just (IteratorModel []) ->
          (IteratorResult b
forall b. IteratorResult b
IteratorExhausted, Int -> DBModel blk -> DBModel blk
forall blk. Int -> DBModel blk -> DBModel blk
iteratorCloseModel Int
itId DBModel blk
dbm)

      Just (IteratorModel (blk
blk:[blk]
blks)) ->
          (b -> IteratorResult b
forall b. b -> IteratorResult b
IteratorResult (CodecConfig blk -> blk -> BlockComponent blk b -> b
forall blk b.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk,
 EncodeDiskDep (NestedCtxt Header) blk) =>
CodecConfig blk -> blk -> BlockComponent blk b -> b
extractBlockComponent CodecConfig blk
ccfg blk
blk BlockComponent blk b
blockComponent), DBModel blk
dbm')
        where
          dbm' :: DBModel blk
dbm' = DBModel blk
dbm {
              dbmIterators = Map.insert itId (IteratorModel blks) dbmIterators
            }
  where
    DBModel { Map Int (IteratorModel blk)
dbmIterators :: forall blk. DBModel blk -> Map Int (IteratorModel blk)
dbmIterators :: Map Int (IteratorModel blk)
dbmIterators, dbmCodecConfig :: forall blk. DBModel blk -> CodecConfig blk
dbmCodecConfig = CodecConfig blk
ccfg } = DBModel blk
dbm

iteratorHasNextModel ::
     HasHeader blk
  => IteratorId
  -> DBModel blk
  -> Maybe (RealPoint blk)
iteratorHasNextModel :: forall blk.
HasHeader blk =>
Int -> DBModel blk -> Maybe (RealPoint blk)
iteratorHasNextModel Int
itId DBModel { Map Int (IteratorModel blk)
dbmIterators :: forall blk. DBModel blk -> Map Int (IteratorModel blk)
dbmIterators :: Map Int (IteratorModel blk)
dbmIterators } =
    case Int -> Map Int (IteratorModel blk) -> Maybe (IteratorModel blk)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
itId Map Int (IteratorModel blk)
dbmIterators of
      Maybe (IteratorModel blk)
Nothing                      -> Maybe (RealPoint blk)
forall a. Maybe a
Nothing
      Just (IteratorModel [])      -> Maybe (RealPoint blk)
forall a. Maybe a
Nothing
      Just (IteratorModel (blk
blk:[blk]
_)) -> RealPoint blk -> Maybe (RealPoint blk)
forall a. a -> Maybe a
Just (RealPoint blk -> Maybe (RealPoint blk))
-> RealPoint blk -> Maybe (RealPoint blk)
forall a b. (a -> b) -> a -> b
$ blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk

iteratorCloseModel :: IteratorId -> DBModel blk -> DBModel blk
iteratorCloseModel :: forall blk. Int -> DBModel blk -> DBModel blk
iteratorCloseModel Int
itId dbm :: DBModel blk
dbm@DBModel { Map Int (IteratorModel blk)
dbmIterators :: forall blk. DBModel blk -> Map Int (IteratorModel blk)
dbmIterators :: Map Int (IteratorModel blk)
dbmIterators } =
    DBModel blk
dbm { dbmIterators = Map.delete itId dbmIterators }