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

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

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Storage.Serialisation (EncodeDisk (..),
                     HasBinaryBlockInfo (..))
import           Ouroboros.Consensus.Storage.VolatileDB hiding
                     (VolatileDbArgs (..))
import           Ouroboros.Consensus.Util ((.:))
import           Ouroboros.Consensus.Util.IOLike
import           Test.Ouroboros.Storage.VolatileDB.Model

openDBMock ::
     forall m blk.
     ( IOLike m
     , GetPrevHash blk
     , HasBinaryBlockInfo blk
     , EncodeDisk blk blk
     , HasNestedContent Header blk
     )
  => BlocksPerFile
  -> CodecConfig blk
  -> m (DBModel blk, VolatileDB m blk)
openDBMock :: forall (m :: * -> *) blk.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
 EncodeDisk blk blk, HasNestedContent Header blk) =>
BlocksPerFile
-> CodecConfig blk -> m (DBModel blk, VolatileDB m blk)
openDBMock BlocksPerFile
maxBlocksPerFile 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, VolatileDB m blk)
-> m (DBModel blk, VolatileDB m blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DBModel blk
dbModel, StrictTVar m (DBModel blk) -> VolatileDB m blk
db StrictTVar m (DBModel blk)
dbVar)
  where
    dbModel :: DBModel blk
dbModel = BlocksPerFile -> CodecConfig blk -> DBModel blk
forall blk. BlocksPerFile -> CodecConfig blk -> DBModel blk
initDBModel BlocksPerFile
maxBlocksPerFile CodecConfig blk
ccfg

    db :: StrictTVar m (DBModel blk) -> VolatileDB m blk
    db :: StrictTVar m (DBModel blk) -> VolatileDB m blk
db StrictTVar m (DBModel blk)
dbVar = VolatileDB {
          closeDB :: HasCallStack => m ()
closeDB             = (DBModel blk -> DBModel blk) -> m ()
update_   ((DBModel blk -> DBModel blk) -> m ())
-> (DBModel blk -> DBModel blk) -> m ()
forall a b. (a -> b) -> a -> b
$ DBModel blk -> DBModel blk
forall blk. DBModel blk -> DBModel blk
closeModel
        , getBlockComponent :: forall b.
HasCallStack =>
BlockComponent blk b -> HeaderHash blk -> m (Maybe b)
getBlockComponent   = (DBModel blk -> Either (VolatileDBError blk) (Maybe b))
-> m (Maybe b)
forall a. (DBModel blk -> Either (VolatileDBError blk) a) -> m a
queryE   ((DBModel blk -> Either (VolatileDBError blk) (Maybe b))
 -> m (Maybe b))
-> (BlockComponent blk b
    -> HeaderHash blk
    -> DBModel blk
    -> Either (VolatileDBError blk) (Maybe b))
-> BlockComponent blk b
-> HeaderHash blk
-> m (Maybe b)
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: BlockComponent blk b
-> HeaderHash blk
-> DBModel blk
-> Either (VolatileDBError blk) (Maybe b)
forall blk b.
(HasHeader blk, GetHeader blk, HasBinaryBlockInfo blk,
 EncodeDisk blk blk, HasNestedContent Header blk) =>
BlockComponent blk b
-> HeaderHash blk
-> DBModel blk
-> Either (VolatileDBError blk) (Maybe b)
getBlockComponentModel
        , putBlock :: HasCallStack => blk -> m ()
putBlock            = (DBModel blk -> Either (VolatileDBError blk) (DBModel blk)) -> m ()
updateE_  ((DBModel blk -> Either (VolatileDBError blk) (DBModel blk))
 -> m ())
-> (blk
    -> DBModel blk -> Either (VolatileDBError blk) (DBModel blk))
-> blk
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> DBModel blk -> Either (VolatileDBError blk) (DBModel blk)
forall blk.
HasHeader blk =>
blk -> DBModel blk -> Either (VolatileDBError blk) (DBModel blk)
putBlockModel
        , garbageCollect :: HasCallStack => SlotNo -> m ()
garbageCollect      = (DBModel blk -> Either (VolatileDBError blk) (DBModel blk)) -> m ()
updateE_  ((DBModel blk -> Either (VolatileDBError blk) (DBModel blk))
 -> m ())
-> (SlotNo
    -> DBModel blk -> Either (VolatileDBError blk) (DBModel blk))
-> SlotNo
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> DBModel blk -> Either (VolatileDBError blk) (DBModel blk)
forall blk.
HasHeader blk =>
SlotNo -> DBModel blk -> Either (VolatileDBError blk) (DBModel blk)
garbageCollectModel
        , filterByPredecessor :: HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
filterByPredecessor = (DBModel blk
 -> Either
      (VolatileDBError blk) (ChainHash blk -> Set (HeaderHash blk)))
-> STM m (ChainHash blk -> Set (HeaderHash blk))
forall a.
(DBModel blk -> Either (VolatileDBError blk) a) -> STM m a
querySTME ((DBModel blk
  -> Either
       (VolatileDBError blk) (ChainHash blk -> Set (HeaderHash blk)))
 -> STM m (ChainHash blk -> Set (HeaderHash blk)))
-> (DBModel blk
    -> Either
         (VolatileDBError blk) (ChainHash blk -> Set (HeaderHash blk)))
-> STM m (ChainHash blk -> Set (HeaderHash blk))
forall a b. (a -> b) -> a -> b
$ DBModel blk
-> Either
     (VolatileDBError blk) (ChainHash blk -> Set (HeaderHash blk))
forall blk.
GetPrevHash blk =>
DBModel blk
-> Either
     (VolatileDBError blk) (ChainHash blk -> Set (HeaderHash blk))
filterByPredecessorModel
        , getBlockInfo :: HasCallStack => STM m (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfo        = (DBModel blk
 -> Either
      (VolatileDBError blk) (HeaderHash blk -> Maybe (BlockInfo blk)))
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
forall a.
(DBModel blk -> Either (VolatileDBError blk) a) -> STM m a
querySTME ((DBModel blk
  -> Either
       (VolatileDBError blk) (HeaderHash blk -> Maybe (BlockInfo blk)))
 -> STM m (HeaderHash blk -> Maybe (BlockInfo blk)))
-> (DBModel blk
    -> Either
         (VolatileDBError blk) (HeaderHash blk -> Maybe (BlockInfo blk)))
-> STM m (HeaderHash blk -> Maybe (BlockInfo blk))
forall a b. (a -> b) -> a -> b
$ DBModel blk
-> Either
     (VolatileDBError blk) (HeaderHash blk -> Maybe (BlockInfo blk))
forall blk.
(GetPrevHash blk, HasBinaryBlockInfo blk) =>
DBModel blk
-> Either
     (VolatileDBError blk) (HeaderHash blk -> Maybe (BlockInfo blk))
getBlockInfoModel
        , getMaxSlotNo :: HasCallStack => STM m MaxSlotNo
getMaxSlotNo        = (DBModel blk -> Either (VolatileDBError blk) MaxSlotNo)
-> STM m MaxSlotNo
forall a.
(DBModel blk -> Either (VolatileDBError blk) a) -> STM m a
querySTME ((DBModel blk -> Either (VolatileDBError blk) MaxSlotNo)
 -> STM m MaxSlotNo)
-> (DBModel blk -> Either (VolatileDBError blk) MaxSlotNo)
-> STM m MaxSlotNo
forall a b. (a -> b) -> a -> b
$ DBModel blk -> Either (VolatileDBError blk) MaxSlotNo
forall blk.
HasHeader blk =>
DBModel blk -> Either (VolatileDBError blk) MaxSlotNo
getMaxSlotNoModel
        }
      where
        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

        updateE_ :: (DBModel blk -> Either (VolatileDBError blk) (DBModel blk)) -> m ()
        updateE_ :: (DBModel blk -> Either (VolatileDBError blk) (DBModel blk)) -> m ()
updateE_ DBModel blk -> Either (VolatileDBError 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 -> Either (VolatileDBError blk) (DBModel blk)
f (DBModel blk -> Either (VolatileDBError blk) (DBModel blk))
-> STM m (DBModel blk)
-> STM m (Either (VolatileDBError blk) (DBModel blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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) STM m (Either (VolatileDBError blk) (DBModel blk))
-> (Either (VolatileDBError blk) (DBModel blk) -> STM m ())
-> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left  VolatileDBError blk
e   -> VolatileDBError blk -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM VolatileDBError 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'

        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

        queryE :: (DBModel blk -> Either (VolatileDBError blk) a) -> m a
        queryE :: forall a. (DBModel blk -> Either (VolatileDBError blk) a) -> m a
queryE DBModel blk -> Either (VolatileDBError blk) a
f = (DBModel blk -> Either (VolatileDBError blk) a)
-> m (Either (VolatileDBError blk) a)
forall a. (DBModel blk -> a) -> m a
query DBModel blk -> Either (VolatileDBError blk) a
f m (Either (VolatileDBError blk) a)
-> (Either (VolatileDBError blk) a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left  VolatileDBError blk
e -> VolatileDBError blk -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO VolatileDBError blk
e
          Right a
a -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

        querySTME :: (DBModel blk -> Either (VolatileDBError blk) a) -> STM m a
        querySTME :: forall a.
(DBModel blk -> Either (VolatileDBError blk) a) -> STM m a
querySTME DBModel blk -> Either (VolatileDBError blk) a
f =
          (DBModel blk -> Either (VolatileDBError blk) a
f (DBModel blk -> Either (VolatileDBError blk) a)
-> STM m (DBModel blk) -> STM m (Either (VolatileDBError blk) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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) STM m (Either (VolatileDBError blk) a)
-> (Either (VolatileDBError blk) a -> STM m a) -> STM m a
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left  VolatileDBError blk
e -> VolatileDBError blk -> STM m a
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM VolatileDBError blk
e
            Right a
a -> a -> STM m a
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a