{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Ouroboros.Storage.ImmutableDB.Mock (openDBMock) where

import           Data.Bifunctor (first)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Storage.Common (BlockComponent)
import           Ouroboros.Consensus.Storage.ImmutableDB.API
import           Ouroboros.Consensus.Storage.ImmutableDB.Chunks
import           Ouroboros.Consensus.Storage.Serialisation
import           Ouroboros.Consensus.Util ((...:), (.:))
import           Ouroboros.Consensus.Util.IOLike
import           Test.Ouroboros.Storage.ImmutableDB.Model

openDBMock ::
     forall m blk.
     ( HasHeader blk
     , GetHeader blk
     , EncodeDisk blk blk
     , HasNestedContent Header blk
     , EncodeDiskDep (NestedCtxt Header) blk
     , IOLike m
     )
  => ChunkInfo
  -> CodecConfig blk
  -> m (DBModel blk, ImmutableDB m blk)
openDBMock :: forall (m :: * -> *) blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
 HasNestedContent Header blk, EncodeDiskDep (NestedCtxt Header) blk,
 IOLike m) =>
ChunkInfo -> CodecConfig blk -> m (DBModel blk, ImmutableDB m blk)
openDBMock ChunkInfo
chunkInfo CodecConfig blk
ccfg = do
    StrictTVar m (DBModel blk)
dbVar <- DBModel blk -> m (StrictTVar m (DBModel blk))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM DBModel blk
dbModel
    (DBModel blk, ImmutableDB m blk)
-> m (DBModel blk, ImmutableDB m blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DBModel blk
dbModel, StrictTVar m (DBModel blk) -> ImmutableDB m blk
immutableDB StrictTVar m (DBModel blk)
dbVar)
  where
    dbModel :: DBModel blk
dbModel = ChunkInfo -> CodecConfig blk -> DBModel blk
forall blk. ChunkInfo -> CodecConfig blk -> DBModel blk
initDBModel ChunkInfo
chunkInfo CodecConfig blk
ccfg

    immutableDB :: StrictTVar m (DBModel blk) -> ImmutableDB m blk
    immutableDB :: StrictTVar m (DBModel blk) -> ImmutableDB m blk
immutableDB StrictTVar m (DBModel blk)
dbVar = ImmutableDB {
          closeDB_ :: HasCallStack => m ()
closeDB_                = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , getTip_ :: HasCallStack => STM m (WithOrigin (Tip blk))
getTip_                 = (DBModel blk -> WithOrigin (Tip blk))
-> STM m (WithOrigin (Tip blk))
forall a. (DBModel blk -> a) -> STM m a
querySTM     ((DBModel blk -> WithOrigin (Tip blk))
 -> STM m (WithOrigin (Tip blk)))
-> (DBModel blk -> WithOrigin (Tip blk))
-> STM m (WithOrigin (Tip blk))
forall a b. (a -> b) -> a -> b
$ DBModel blk -> WithOrigin (Tip blk)
forall blk. GetHeader blk => DBModel blk -> WithOrigin (Tip blk)
getTipModel
        , getBlockComponent_ :: forall b.
HasCallStack =>
BlockComponent blk b
-> RealPoint blk -> m (Either (MissingBlock blk) b)
getBlockComponent_      = (DBModel blk -> Either (MissingBlock blk) b)
-> m (Either (MissingBlock blk) b)
forall a. (DBModel blk -> a) -> m a
query       ((DBModel blk -> Either (MissingBlock blk) b)
 -> m (Either (MissingBlock blk) b))
-> (BlockComponent blk b
    -> RealPoint blk -> DBModel blk -> Either (MissingBlock blk) b)
-> BlockComponent blk b
-> RealPoint blk
-> m (Either (MissingBlock blk) b)
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: BlockComponent blk b
-> RealPoint blk -> DBModel blk -> Either (MissingBlock blk) b
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
        , appendBlock_ :: HasCallStack => blk -> m ()
appendBlock_            = (DBModel blk -> Either (ImmutableDBError blk) (DBModel blk))
-> m ()
updateE_     ((DBModel blk -> Either (ImmutableDBError blk) (DBModel blk))
 -> m ())
-> (blk
    -> DBModel blk -> Either (ImmutableDBError blk) (DBModel blk))
-> blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> DBModel blk -> Either (ImmutableDBError blk) (DBModel blk)
forall blk.
(HasHeader blk, GetHeader blk, HasCallStack) =>
blk -> DBModel blk -> Either (ImmutableDBError blk) (DBModel blk)
appendBlockModel
        , stream_ :: forall b.
HasCallStack =>
ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
stream_                 = (DBModel blk
 -> Either
      (ImmutableDBError blk)
      (Either (MissingBlock blk) (Iterator m blk b, DBModel blk)))
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall e a.
(DBModel blk
 -> Either (ImmutableDBError blk) (Either e (a, DBModel blk)))
-> m (Either e a)
updateEE  ((DBModel blk
  -> Either
       (ImmutableDBError blk)
       (Either (MissingBlock blk) (Iterator m blk b, DBModel blk)))
 -> m (Either (MissingBlock blk) (Iterator m blk b)))
-> (ResourceRegistry m
    -> BlockComponent blk b
    -> StreamFrom blk
    -> StreamTo blk
    -> DBModel blk
    -> Either
         (ImmutableDBError blk)
         (Either (MissingBlock blk) (Iterator m blk b, DBModel blk)))
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (MissingBlock blk) (Iterator m blk b))
forall y z x0 x1 x2 x3.
(y -> z)
-> (x0 -> x1 -> x2 -> x3 -> y) -> x0 -> x1 -> x2 -> x3 -> z
...: \ResourceRegistry m
_rr BlockComponent blk b
bc StreamFrom blk
s StreamTo blk
e -> (Either (MissingBlock blk) (IteratorId, DBModel blk)
 -> Either (MissingBlock blk) (Iterator m blk b, DBModel blk))
-> Either
     (ImmutableDBError blk)
     (Either (MissingBlock blk) (IteratorId, DBModel blk))
-> Either
     (ImmutableDBError blk)
     (Either (MissingBlock blk) (Iterator m blk b, DBModel blk))
forall a b.
(a -> b)
-> Either (ImmutableDBError blk) a
-> Either (ImmutableDBError blk) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((IteratorId, DBModel blk) -> (Iterator m blk b, DBModel blk))
-> Either (MissingBlock blk) (IteratorId, DBModel blk)
-> Either (MissingBlock blk) (Iterator m blk b, DBModel blk)
forall a b.
(a -> b)
-> Either (MissingBlock blk) a -> Either (MissingBlock blk) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IteratorId -> Iterator m blk b)
-> (IteratorId, DBModel blk) -> (Iterator m blk b, DBModel blk)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (BlockComponent blk b -> IteratorId -> Iterator m blk b
forall b. BlockComponent blk b -> IteratorId -> Iterator m blk b
iterator BlockComponent blk b
bc))) (Either
   (ImmutableDBError blk)
   (Either (MissingBlock blk) (IteratorId, DBModel blk))
 -> Either
      (ImmutableDBError blk)
      (Either (MissingBlock blk) (Iterator m blk b, DBModel blk)))
-> (DBModel blk
    -> Either
         (ImmutableDBError blk)
         (Either (MissingBlock blk) (IteratorId, DBModel blk)))
-> DBModel blk
-> Either
     (ImmutableDBError blk)
     (Either (MissingBlock blk) (Iterator m blk b, DBModel blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamFrom blk
-> StreamTo blk
-> DBModel blk
-> Either
     (ImmutableDBError blk)
     (Either (MissingBlock blk) (IteratorId, DBModel blk))
forall blk.
(HasHeader blk, GetHeader blk, HasCallStack) =>
StreamFrom blk
-> StreamTo blk
-> DBModel blk
-> Either
     (ImmutableDBError blk)
     (Either (MissingBlock blk) (IteratorId, DBModel blk))
streamModel StreamFrom blk
s StreamTo blk
e
        }
      where
        iterator :: BlockComponent blk b -> IteratorId -> Iterator m blk b
        iterator :: forall b. BlockComponent blk b -> IteratorId -> Iterator m blk b
iterator BlockComponent blk b
blockComponent IteratorId
itId = Iterator
          { iteratorNext :: HasCallStack => m (IteratorResult b)
iteratorNext    = (DBModel blk -> (IteratorResult b, DBModel blk))
-> m (IteratorResult b)
forall a. (DBModel blk -> (a, DBModel blk)) -> m a
update   ((DBModel blk -> (IteratorResult b, DBModel blk))
 -> m (IteratorResult b))
-> (DBModel blk -> (IteratorResult b, DBModel blk))
-> m (IteratorResult b)
forall a b. (a -> b) -> a -> b
$ IteratorId
-> BlockComponent blk b
-> DBModel blk
-> (IteratorResult b, DBModel blk)
forall blk b.
(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    IteratorId
itId BlockComponent blk b
blockComponent
          , iteratorHasNext :: HasCallStack => STM m (Maybe (RealPoint blk))
iteratorHasNext = (DBModel blk -> Maybe (RealPoint blk))
-> STM m (Maybe (RealPoint blk))
forall a. (DBModel blk -> a) -> STM m a
querySTM ((DBModel blk -> Maybe (RealPoint blk))
 -> STM m (Maybe (RealPoint blk)))
-> (DBModel blk -> Maybe (RealPoint blk))
-> STM m (Maybe (RealPoint blk))
forall a b. (a -> b) -> a -> b
$ IteratorId -> DBModel blk -> Maybe (RealPoint blk)
forall blk.
HasHeader blk =>
IteratorId -> DBModel blk -> Maybe (RealPoint blk)
iteratorHasNextModel IteratorId
itId
          , iteratorClose :: HasCallStack => m ()
iteratorClose   = (DBModel blk -> DBModel blk) -> m ()
update_  ((DBModel blk -> DBModel blk) -> m ())
-> (DBModel blk -> DBModel blk) -> m ()
forall a b. (a -> b) -> a -> b
$ IteratorId -> DBModel blk -> DBModel blk
forall blk. IteratorId -> DBModel blk -> DBModel blk
iteratorCloseModel   IteratorId
itId
          }

        update_ :: (DBModel blk -> DBModel blk) -> m ()
        update_ :: (DBModel blk -> DBModel blk) -> m ()
update_ DBModel blk -> DBModel blk
f = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (DBModel blk)
-> (DBModel blk -> DBModel blk) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (DBModel blk)
dbVar DBModel blk -> DBModel blk
f

        update :: (DBModel blk -> (a, DBModel blk)) -> m a
        update :: forall a. (DBModel blk -> (a, DBModel blk)) -> m a
update DBModel blk -> (a, DBModel blk)
f = STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ StrictTVar m (DBModel blk)
-> (DBModel blk -> (a, DBModel blk)) -> STM m a
forall (m :: * -> *) s a.
MonadSTM m =>
StrictTVar m s -> (s -> (a, s)) -> STM m a
stateTVar StrictTVar m (DBModel blk)
dbVar DBModel blk -> (a, DBModel blk)
f

        updateE_ :: (DBModel blk -> Either (ImmutableDBError blk) (DBModel blk)) -> m ()
        updateE_ :: (DBModel blk -> Either (ImmutableDBError blk) (DBModel blk))
-> m ()
updateE_ DBModel blk -> Either (ImmutableDBError blk) (DBModel blk)
f = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          DBModel blk
db <- StrictTVar m (DBModel blk) -> STM m (DBModel blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (DBModel blk)
dbVar
          case DBModel blk -> Either (ImmutableDBError blk) (DBModel blk)
f DBModel blk
db of
            Left  ImmutableDBError blk
e   -> ImmutableDBError blk -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM ImmutableDBError blk
e
            Right DBModel blk
db' -> StrictTVar m (DBModel blk) -> DBModel blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (DBModel blk)
dbVar DBModel blk
db'

        updateEE ::
             (DBModel blk -> Either (ImmutableDBError blk) (Either e (a, DBModel blk)))
          -> m (Either e a)
        updateEE :: forall e a.
(DBModel blk
 -> Either (ImmutableDBError blk) (Either e (a, DBModel blk)))
-> m (Either e a)
updateEE DBModel blk
-> Either (ImmutableDBError blk) (Either e (a, DBModel blk))
f = STM m (Either e a) -> m (Either e a)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either e a) -> m (Either e a))
-> STM m (Either e a) -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ do
          DBModel blk
db <- StrictTVar m (DBModel blk) -> STM m (DBModel blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (DBModel blk)
dbVar
          case DBModel blk
-> Either (ImmutableDBError blk) (Either e (a, DBModel blk))
f DBModel blk
db of
            Left  ImmutableDBError blk
e                -> ImmutableDBError blk -> STM m (Either e a)
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM ImmutableDBError blk
e
            Right (Left e
e)         -> Either e a -> STM m (Either e a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e a
forall a b. a -> Either a b
Left e
e)
            Right (Right (a
a, DBModel blk
db')) -> StrictTVar m (DBModel blk) -> DBModel blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (DBModel blk)
dbVar DBModel blk
db' STM m () -> STM m (Either e a) -> STM m (Either e a)
forall a b. STM m a -> STM m b -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either e a -> STM m (Either e a)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either e a
forall a b. b -> Either a b
Right a
a)

        query :: (DBModel blk -> a) -> m a
        query :: forall a. (DBModel blk -> a) -> m a
query DBModel blk -> a
f = (DBModel blk -> a) -> m (DBModel blk) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DBModel blk -> a
f (m (DBModel blk) -> m a) -> m (DBModel blk) -> m a
forall a b. (a -> b) -> a -> b
$ STM m (DBModel blk) -> m (DBModel blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (DBModel blk) -> m (DBModel blk))
-> STM m (DBModel blk) -> m (DBModel blk)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (DBModel blk) -> STM m (DBModel blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (DBModel blk)
dbVar

        querySTM :: (DBModel blk -> a) -> STM m a
        querySTM :: forall a. (DBModel blk -> a) -> STM m a
querySTM DBModel blk -> a
f = (DBModel blk -> a) -> STM m (DBModel blk) -> STM m a
forall a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DBModel blk -> a
f (STM m (DBModel blk) -> STM m a) -> STM m (DBModel blk) -> STM m a
forall a b. (a -> b) -> a -> b
$ StrictTVar m (DBModel blk) -> STM m (DBModel blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (DBModel blk)
dbVar