{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Ouroboros.Storage.LedgerDB.V1.BackingStore.Mock
  ( -- * Types
    Err (..)
  , ID (..)
  , Mock (..)
  , ValueHandle (..)
  , ValueHandleStatus (..)
  , emptyMock

    -- * Type classes
  , ApplyDiff (..)
  , DiffSize (..)
  , EmptyValues (..)
  , HasOps
  , KeysSize (..)
  , LookupKeys (..)
  , LookupKeysRange (..)
  , MakeDiff (..)
  , MakeInitHint (..)
  , MakeReadHint (..)
  , MakeSerializeTablesHint (..)
  , MakeWriteHint (..)
  , ValuesLength (..)

    -- * State monad to run the mock in
  , MockMonad (..)
  , runMockMonad

    -- * Mocked @'BackingStore'@ operations
  , mBSClose
  , mBSCopy
  , mBSInitFromCopy
  , mBSInitFromValues
  , mBSVHAtSlot
  , mBSVHClose
  , mBSVHRangeRead
  , mBSVHRead
  , mBSVHStat
  , mBSValueHandle
  , mBSWrite
  , mGuardBSClosed
  , mGuardBSVHClosed
  ) where

import Control.Monad
import Control.Monad.Except
  ( ExceptT (..)
  , MonadError (throwError)
  , runExceptT
  )
import Control.Monad.State
  ( MonadState
  , State
  , StateT (StateT)
  , gets
  , modify
  , runState
  )
import Data.Data (Proxy, Typeable)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Ouroboros.Consensus.Block.Abstract (SlotNo, WithOrigin (..))
import Ouroboros.Consensus.Ledger.Tables
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore as BS
import qualified System.FS.API.Types as FS

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

data Mock vs = Mock
  { forall vs. Mock vs -> vs
backingValues :: vs
  , forall vs. Mock vs -> WithOrigin SlotNo
backingSeqNo :: WithOrigin SlotNo
  , forall vs. Mock vs -> Map FsPath (WithOrigin SlotNo, vs)
copies :: Map FS.FsPath (WithOrigin SlotNo, vs)
  , forall vs. Mock vs -> Bool
isClosed :: Bool
  , forall vs. Mock vs -> Map ID ValueHandleStatus
valueHandles :: Map ID ValueHandleStatus
  -- ^ Track whether value handles have been closed.
  , forall vs. Mock vs -> ID
nextId :: ID
  -- ^ The next id to use if a new value handle is opened.
  }
  deriving stock (Int -> Mock vs -> ShowS
[Mock vs] -> ShowS
Mock vs -> String
(Int -> Mock vs -> ShowS)
-> (Mock vs -> String) -> ([Mock vs] -> ShowS) -> Show (Mock vs)
forall vs. Show vs => Int -> Mock vs -> ShowS
forall vs. Show vs => [Mock vs] -> ShowS
forall vs. Show vs => Mock vs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall vs. Show vs => Int -> Mock vs -> ShowS
showsPrec :: Int -> Mock vs -> ShowS
$cshow :: forall vs. Show vs => Mock vs -> String
show :: Mock vs -> String
$cshowList :: forall vs. Show vs => [Mock vs] -> ShowS
showList :: [Mock vs] -> ShowS
Show, Mock vs -> Mock vs -> Bool
(Mock vs -> Mock vs -> Bool)
-> (Mock vs -> Mock vs -> Bool) -> Eq (Mock vs)
forall vs. Eq vs => Mock vs -> Mock vs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall vs. Eq vs => Mock vs -> Mock vs -> Bool
== :: Mock vs -> Mock vs -> Bool
$c/= :: forall vs. Eq vs => Mock vs -> Mock vs -> Bool
/= :: Mock vs -> Mock vs -> Bool
Eq)

data ValueHandleStatus = Open | ClosedByStore | ClosedByHandle
  deriving stock (Int -> ValueHandleStatus -> ShowS
[ValueHandleStatus] -> ShowS
ValueHandleStatus -> String
(Int -> ValueHandleStatus -> ShowS)
-> (ValueHandleStatus -> String)
-> ([ValueHandleStatus] -> ShowS)
-> Show ValueHandleStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueHandleStatus -> ShowS
showsPrec :: Int -> ValueHandleStatus -> ShowS
$cshow :: ValueHandleStatus -> String
show :: ValueHandleStatus -> String
$cshowList :: [ValueHandleStatus] -> ShowS
showList :: [ValueHandleStatus] -> ShowS
Show, ValueHandleStatus -> ValueHandleStatus -> Bool
(ValueHandleStatus -> ValueHandleStatus -> Bool)
-> (ValueHandleStatus -> ValueHandleStatus -> Bool)
-> Eq ValueHandleStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValueHandleStatus -> ValueHandleStatus -> Bool
== :: ValueHandleStatus -> ValueHandleStatus -> Bool
$c/= :: ValueHandleStatus -> ValueHandleStatus -> Bool
/= :: ValueHandleStatus -> ValueHandleStatus -> Bool
Eq)

data ValueHandle values = ValueHandle
  { forall values. ValueHandle values -> ID
getId :: ID
  , forall values. ValueHandle values -> values
values :: values
  , forall values. ValueHandle values -> WithOrigin SlotNo
seqNo :: WithOrigin SlotNo
  }
  deriving stock Int -> ValueHandle values -> ShowS
[ValueHandle values] -> ShowS
ValueHandle values -> String
(Int -> ValueHandle values -> ShowS)
-> (ValueHandle values -> String)
-> ([ValueHandle values] -> ShowS)
-> Show (ValueHandle values)
forall values. Show values => Int -> ValueHandle values -> ShowS
forall values. Show values => [ValueHandle values] -> ShowS
forall values. Show values => ValueHandle values -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall values. Show values => Int -> ValueHandle values -> ShowS
showsPrec :: Int -> ValueHandle values -> ShowS
$cshow :: forall values. Show values => ValueHandle values -> String
show :: ValueHandle values -> String
$cshowList :: forall values. Show values => [ValueHandle values] -> ShowS
showList :: [ValueHandle values] -> ShowS
Show

instance Eq (ValueHandle vs) where
  ValueHandle vs
x == :: ValueHandle vs -> ValueHandle vs -> Bool
== ValueHandle vs
y = ValueHandle vs -> ID
forall values. ValueHandle values -> ID
getId ValueHandle vs
x ID -> ID -> Bool
forall a. Eq a => a -> a -> Bool
== ValueHandle vs -> ID
forall values. ValueHandle values -> ID
getId ValueHandle vs
y

instance Ord (ValueHandle vs) where
  ValueHandle vs
x <= :: ValueHandle vs -> ValueHandle vs -> Bool
<= ValueHandle vs
y = ValueHandle vs -> ID
forall values. ValueHandle values -> ID
getId ValueHandle vs
x ID -> ID -> Bool
forall a. Ord a => a -> a -> Bool
< ValueHandle vs -> ID
forall values. ValueHandle values -> ID
getId ValueHandle vs
y

-- | An ID for a mocked value handle.
newtype ID = ID Word
  deriving stock (Int -> ID -> ShowS
[ID] -> ShowS
ID -> String
(Int -> ID -> ShowS)
-> (ID -> String) -> ([ID] -> ShowS) -> Show ID
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ID -> ShowS
showsPrec :: Int -> ID -> ShowS
$cshow :: ID -> String
show :: ID -> String
$cshowList :: [ID] -> ShowS
showList :: [ID] -> ShowS
Show, ID -> ID -> Bool
(ID -> ID -> Bool) -> (ID -> ID -> Bool) -> Eq ID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ID -> ID -> Bool
== :: ID -> ID -> Bool
$c/= :: ID -> ID -> Bool
/= :: ID -> ID -> Bool
Eq, Eq ID
Eq ID =>
(ID -> ID -> Ordering)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> Bool)
-> (ID -> ID -> ID)
-> (ID -> ID -> ID)
-> Ord ID
ID -> ID -> Bool
ID -> ID -> Ordering
ID -> ID -> ID
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ID -> ID -> Ordering
compare :: ID -> ID -> Ordering
$c< :: ID -> ID -> Bool
< :: ID -> ID -> Bool
$c<= :: ID -> ID -> Bool
<= :: ID -> ID -> Bool
$c> :: ID -> ID -> Bool
> :: ID -> ID -> Bool
$c>= :: ID -> ID -> Bool
>= :: ID -> ID -> Bool
$cmax :: ID -> ID -> ID
max :: ID -> ID -> ID
$cmin :: ID -> ID -> ID
min :: ID -> ID -> ID
Ord)
  deriving newtype Integer -> ID
ID -> ID
ID -> ID -> ID
(ID -> ID -> ID)
-> (ID -> ID -> ID)
-> (ID -> ID -> ID)
-> (ID -> ID)
-> (ID -> ID)
-> (ID -> ID)
-> (Integer -> ID)
-> Num ID
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: ID -> ID -> ID
+ :: ID -> ID -> ID
$c- :: ID -> ID -> ID
- :: ID -> ID -> ID
$c* :: ID -> ID -> ID
* :: ID -> ID -> ID
$cnegate :: ID -> ID
negate :: ID -> ID
$cabs :: ID -> ID
abs :: ID -> ID
$csignum :: ID -> ID
signum :: ID -> ID
$cfromInteger :: Integer -> ID
fromInteger :: Integer -> ID
Num

-- | An empty mock state.
emptyMock :: EmptyValues vs => Mock vs
emptyMock :: forall vs. EmptyValues vs => Mock vs
emptyMock =
  Mock
    { backingValues :: vs
backingValues = vs
forall vs. EmptyValues vs => vs
emptyValues
    , backingSeqNo :: WithOrigin SlotNo
backingSeqNo = WithOrigin SlotNo
forall t. WithOrigin t
Origin
    , copies :: Map FsPath (WithOrigin SlotNo, vs)
copies = Map FsPath (WithOrigin SlotNo, vs)
forall k a. Map k a
Map.empty
    , isClosed :: Bool
isClosed = Bool
False
    , valueHandles :: Map ID ValueHandleStatus
valueHandles = Map ID ValueHandleStatus
forall k a. Map k a
Map.empty
    , nextId :: ID
nextId = ID
0
    }

data Err
  = ErrBackingStoreClosed
  | ErrBackingStoreValueHandleClosed
  | ErrCopyPathAlreadyExists
  | ErrCopyPathDoesNotExist
  | ErrNonMonotonicSeqNo (WithOrigin SlotNo) (WithOrigin SlotNo)
  deriving stock (Int -> Err -> ShowS
[Err] -> ShowS
Err -> String
(Int -> Err -> ShowS)
-> (Err -> String) -> ([Err] -> ShowS) -> Show Err
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Err -> ShowS
showsPrec :: Int -> Err -> ShowS
$cshow :: Err -> String
show :: Err -> String
$cshowList :: [Err] -> ShowS
showList :: [Err] -> ShowS
Show, Err -> Err -> Bool
(Err -> Err -> Bool) -> (Err -> Err -> Bool) -> Eq Err
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Err -> Err -> Bool
== :: Err -> Err -> Bool
$c/= :: Err -> Err -> Bool
/= :: Err -> Err -> Bool
Eq)

{-------------------------------------------------------------------------------
  Type classes
-------------------------------------------------------------------------------}

-- | Abstract over interactions between values, keys and diffs.
class
  ( EmptyValues vs
  , ApplyDiff vs d
  , LookupKeysRange ks vs
  , LookupKeys ks vs
  , ValuesLength vs
  , MakeDiff vs d
  , DiffSize d
  , KeysSize ks
  , MakeInitHint vs
  , MakeWriteHint d
  , MakeReadHint vs
  , MakeSerializeTablesHint vs
  , Show ks
  , Show vs
  , Show d
  , Show (BS.InitHint vs)
  , Show (BS.WriteHint d)
  , Show (BS.ReadHint vs)
  , Show (SerializeTablesHint vs)
  , Eq ks
  , Eq vs
  , Eq d
  , Eq (BS.InitHint vs)
  , Eq (BS.WriteHint d)
  , Eq (BS.ReadHint vs)
  , Eq (SerializeTablesHint vs)
  , Typeable ks
  , Typeable vs
  , Typeable d
  , Typeable (BS.InitHint vs)
  , Typeable (BS.WriteHint d)
  , Typeable (BS.ReadHint vs)
  , Typeable (SerializeTablesHint vs)
  ) =>
  HasOps ks vs d

class EmptyValues vs where
  emptyValues :: vs

class ApplyDiff vs d where
  applyDiff :: vs -> d -> vs

class LookupKeysRange ks vs where
  lookupKeysRange :: Maybe ks -> Int -> vs -> vs

class LookupKeys ks vs where
  lookupKeys :: ks -> vs -> vs

class ValuesLength vs where
  valuesLength :: vs -> Int

class MakeDiff vs d where
  diff :: vs -> vs -> d

-- | Counts how many diffs are there. Not to be confused with how many values
-- result from the diffs.
class DiffSize d where
  diffSize :: d -> Int

class KeysSize ks where
  keysSize :: ks -> Int

class MakeInitHint vs where
  makeInitHint :: Proxy vs -> BS.InitHint vs

class MakeWriteHint d where
  makeWriteHint :: Proxy d -> BS.WriteHint d

class MakeReadHint vs where
  makeReadHint :: Proxy vs -> BS.ReadHint vs

class MakeSerializeTablesHint vs where
  makeSerializeTablesHint :: Proxy vs -> SerializeTablesHint vs

{-------------------------------------------------------------------------------
  State monad to run the mock in
-------------------------------------------------------------------------------}

-- | State within which the mock runs.
newtype MockMonad ks vs d a
  = MockMonad (ExceptT Err (State (Mock vs)) a)
  deriving stock (forall a b.
 (a -> b) -> MockMonad ks vs d a -> MockMonad ks vs d b)
-> (forall a b. a -> MockMonad ks vs d b -> MockMonad ks vs d a)
-> Functor (MockMonad ks vs d)
forall a b. a -> MockMonad ks vs d b -> MockMonad ks vs d a
forall a b. (a -> b) -> MockMonad ks vs d a -> MockMonad ks vs d b
forall ks vs d a b. a -> MockMonad ks vs d b -> MockMonad ks vs d a
forall ks vs d a b.
(a -> b) -> MockMonad ks vs d a -> MockMonad ks vs d b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall ks vs d a b.
(a -> b) -> MockMonad ks vs d a -> MockMonad ks vs d b
fmap :: forall a b. (a -> b) -> MockMonad ks vs d a -> MockMonad ks vs d b
$c<$ :: forall ks vs d a b. a -> MockMonad ks vs d b -> MockMonad ks vs d a
<$ :: forall a b. a -> MockMonad ks vs d b -> MockMonad ks vs d a
Functor
  deriving newtype
    ( Functor (MockMonad ks vs d)
Functor (MockMonad ks vs d) =>
(forall a. a -> MockMonad ks vs d a)
-> (forall a b.
    MockMonad ks vs d (a -> b)
    -> MockMonad ks vs d a -> MockMonad ks vs d b)
-> (forall a b c.
    (a -> b -> c)
    -> MockMonad ks vs d a
    -> MockMonad ks vs d b
    -> MockMonad ks vs d c)
-> (forall a b.
    MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b)
-> (forall a b.
    MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d a)
-> Applicative (MockMonad ks vs d)
forall a. a -> MockMonad ks vs d a
forall a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d a
forall a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b
forall a b.
MockMonad ks vs d (a -> b)
-> MockMonad ks vs d a -> MockMonad ks vs d b
forall ks vs d. Functor (MockMonad ks vs d)
forall a b c.
(a -> b -> c)
-> MockMonad ks vs d a
-> MockMonad ks vs d b
-> MockMonad ks vs d c
forall ks vs d a. a -> MockMonad ks vs d a
forall ks vs d a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d a
forall ks vs d a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b
forall ks vs d a b.
MockMonad ks vs d (a -> b)
-> MockMonad ks vs d a -> MockMonad ks vs d b
forall ks vs d a b c.
(a -> b -> c)
-> MockMonad ks vs d a
-> MockMonad ks vs d b
-> MockMonad ks vs d c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall ks vs d a. a -> MockMonad ks vs d a
pure :: forall a. a -> MockMonad ks vs d a
$c<*> :: forall ks vs d a b.
MockMonad ks vs d (a -> b)
-> MockMonad ks vs d a -> MockMonad ks vs d b
<*> :: forall a b.
MockMonad ks vs d (a -> b)
-> MockMonad ks vs d a -> MockMonad ks vs d b
$cliftA2 :: forall ks vs d a b c.
(a -> b -> c)
-> MockMonad ks vs d a
-> MockMonad ks vs d b
-> MockMonad ks vs d c
liftA2 :: forall a b c.
(a -> b -> c)
-> MockMonad ks vs d a
-> MockMonad ks vs d b
-> MockMonad ks vs d c
$c*> :: forall ks vs d a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b
*> :: forall a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b
$c<* :: forall ks vs d a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d a
<* :: forall a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d a
Applicative
    , Applicative (MockMonad ks vs d)
Applicative (MockMonad ks vs d) =>
(forall a b.
 MockMonad ks vs d a
 -> (a -> MockMonad ks vs d b) -> MockMonad ks vs d b)
-> (forall a b.
    MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b)
-> (forall a. a -> MockMonad ks vs d a)
-> Monad (MockMonad ks vs d)
forall a. a -> MockMonad ks vs d a
forall a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b
forall a b.
MockMonad ks vs d a
-> (a -> MockMonad ks vs d b) -> MockMonad ks vs d b
forall ks vs d. Applicative (MockMonad ks vs d)
forall ks vs d a. a -> MockMonad ks vs d a
forall ks vs d a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b
forall ks vs d a b.
MockMonad ks vs d a
-> (a -> MockMonad ks vs d b) -> MockMonad ks vs d b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall ks vs d a b.
MockMonad ks vs d a
-> (a -> MockMonad ks vs d b) -> MockMonad ks vs d b
>>= :: forall a b.
MockMonad ks vs d a
-> (a -> MockMonad ks vs d b) -> MockMonad ks vs d b
$c>> :: forall ks vs d a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b
>> :: forall a b.
MockMonad ks vs d a -> MockMonad ks vs d b -> MockMonad ks vs d b
$creturn :: forall ks vs d a. a -> MockMonad ks vs d a
return :: forall a. a -> MockMonad ks vs d a
Monad
    , MonadState (Mock vs)
    , MonadError Err
    )

runMockMonad ::
  MockMonad ks vs d a ->
  Mock vs ->
  (Either Err a, Mock vs)
runMockMonad :: forall ks vs d a.
MockMonad ks vs d a -> Mock vs -> (Either Err a, Mock vs)
runMockMonad (MockMonad ExceptT Err (State (Mock vs)) a
t) = State (Mock vs) (Either Err a)
-> Mock vs -> (Either Err a, Mock vs)
forall s a. State s a -> s -> (a, s)
runState (State (Mock vs) (Either Err a)
 -> Mock vs -> (Either Err a, Mock vs))
-> (ExceptT Err (State (Mock vs)) a
    -> State (Mock vs) (Either Err a))
-> ExceptT Err (State (Mock vs)) a
-> Mock vs
-> (Either Err a, Mock vs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Err (State (Mock vs)) a -> State (Mock vs) (Either Err a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Err (State (Mock vs)) a
 -> Mock vs -> (Either Err a, Mock vs))
-> ExceptT Err (State (Mock vs)) a
-> Mock vs
-> (Either Err a, Mock vs)
forall a b. (a -> b) -> a -> b
$ ExceptT Err (State (Mock vs)) a
t

{------------------------------------------------------------------------------
  Mocked @'BackingStore'@ operations
------------------------------------------------------------------------------}

mBSInitFromValues ::
  forall vs m.
  MonadState (Mock vs) m =>
  WithOrigin SlotNo ->
  BS.InitHint vs ->
  vs ->
  m ()
mBSInitFromValues :: forall vs (m :: * -> *).
MonadState (Mock vs) m =>
WithOrigin SlotNo -> InitHint vs -> vs -> m ()
mBSInitFromValues WithOrigin SlotNo
sl InitHint vs
_st vs
vs =
  (Mock vs -> Mock vs) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
    ( \Mock vs
m ->
        Mock vs
m
          { backingValues = vs
          , backingSeqNo = sl
          , isClosed = False
          }
    )

mBSInitFromCopy ::
  forall vs m.
  (MonadState (Mock vs) m, MonadError Err m) =>
  BS.InitHint vs ->
  FS.FsPath ->
  m ()
mBSInitFromCopy :: forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
InitHint vs -> FsPath -> m ()
mBSInitFromCopy InitHint vs
_st FsPath
bsp = do
  cps <- (Mock vs -> Map FsPath (WithOrigin SlotNo, vs))
-> m (Map FsPath (WithOrigin SlotNo, vs))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Mock vs -> Map FsPath (WithOrigin SlotNo, vs)
forall vs. Mock vs -> Map FsPath (WithOrigin SlotNo, vs)
copies
  case Map.lookup bsp cps of
    Maybe (WithOrigin SlotNo, vs)
Nothing -> Err -> m ()
forall a. Err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Err
ErrCopyPathDoesNotExist
    Just (WithOrigin SlotNo
sl, vs
vs) ->
      (Mock vs -> Mock vs) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
        ( \Mock vs
m ->
            Mock vs
m
              { backingValues = vs
              , backingSeqNo = sl
              , isClosed = False
              }
        )

-- | Throw an error if the backing store has been closed.
mGuardBSClosed :: (MonadState (Mock vs) m, MonadError Err m) => m ()
mGuardBSClosed :: forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
m ()
mGuardBSClosed = do
  closed <- (Mock vs -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Mock vs -> Bool
forall vs. Mock vs -> Bool
isClosed
  when closed $
    throwError ErrBackingStoreClosed

-- | Close the backing store.
--
-- Closing is idempotent.
mBSClose :: MonadState (Mock vs) m => m ()
mBSClose :: forall vs (m :: * -> *). MonadState (Mock vs) m => m ()
mBSClose = do
  closed <- (Mock vs -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Mock vs -> Bool
forall vs. Mock vs -> Bool
isClosed
  unless closed $
    modify
      ( \Mock vs
m ->
          Mock vs
m
            { isClosed = True
            , valueHandles = fmap (const ClosedByStore) (valueHandles m)
            }
      )

-- | Copy the contents of the backing store to the given path.
mBSCopy ::
  (MonadState (Mock vs) m, MonadError Err m) => SerializeTablesHint vs -> FS.FsPath -> m ()
mBSCopy :: forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
SerializeTablesHint vs -> FsPath -> m ()
mBSCopy SerializeTablesHint vs
_ FsPath
bsp = do
  m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
m ()
mGuardBSClosed
  cps <- (Mock vs -> Map FsPath (WithOrigin SlotNo, vs))
-> m (Map FsPath (WithOrigin SlotNo, vs))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Mock vs -> Map FsPath (WithOrigin SlotNo, vs)
forall vs. Mock vs -> Map FsPath (WithOrigin SlotNo, vs)
copies
  when (bsp `Map.member` cps) $
    throwError ErrCopyPathAlreadyExists
  modify
    ( \Mock vs
m ->
        Mock vs
m
          { copies = Map.insert bsp (backingSeqNo m, backingValues m) (copies m)
          }
    )

-- | Open a new value handle, which captures the state of the backing store
-- at the time of opening the handle.
mBSValueHandle ::
  (MonadState (Mock vs) m, MonadError Err m) =>
  m (ValueHandle vs)
mBSValueHandle :: forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
m (ValueHandle vs)
mBSValueHandle = do
  m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
m ()
mGuardBSClosed
  vs <- (Mock vs -> vs) -> m vs
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Mock vs -> vs
forall vs. Mock vs -> vs
backingValues
  seqNo <- gets backingSeqNo
  nxt <- gets nextId
  let
    vh = ID -> vs -> WithOrigin SlotNo -> ValueHandle vs
forall values.
ID -> values -> WithOrigin SlotNo -> ValueHandle values
ValueHandle ID
nxt vs
vs WithOrigin SlotNo
seqNo
  modify
    ( \Mock vs
m ->
        Mock vs
m
          { valueHandles = Map.insert nxt Open (valueHandles m)
          , nextId = nxt + 1
          }
    )

  pure vh

-- | Write a diff to the backing store.
mBSWrite ::
  (MonadState (Mock vs) m, MonadError Err m, ApplyDiff vs d) =>
  SlotNo ->
  BS.WriteHint d ->
  d ->
  m ()
mBSWrite :: forall vs (m :: * -> *) d.
(MonadState (Mock vs) m, MonadError Err m, ApplyDiff vs d) =>
SlotNo -> WriteHint d -> d -> m ()
mBSWrite SlotNo
sl WriteHint d
_st d
d = do
  m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
m ()
mGuardBSClosed
  vs <- (Mock vs -> vs) -> m vs
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Mock vs -> vs
forall vs. Mock vs -> vs
backingValues
  seqNo <- gets backingSeqNo
  when (seqNo > NotOrigin sl) $
    throwError $
      ErrNonMonotonicSeqNo (NotOrigin sl) seqNo
  modify
    ( \Mock vs
m ->
        Mock vs
m
          { backingValues = applyDiff vs d
          , backingSeqNo = NotOrigin sl
          }
    )

-- | Throw an error if the given backing store value handle has been closed.
mGuardBSVHClosed ::
  (MonadState (Mock vs) m, MonadError Err m) =>
  ValueHandle vs ->
  m ()
mGuardBSVHClosed :: forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
ValueHandle vs -> m ()
mGuardBSVHClosed ValueHandle vs
vh = do
  status <- ValueHandle vs -> m ValueHandleStatus
forall vs (m :: * -> *).
MonadState (Mock vs) m =>
ValueHandle vs -> m ValueHandleStatus
mLookupValueHandle ValueHandle vs
vh
  case status of
    ValueHandleStatus
ClosedByStore -> Err -> m ()
forall a. Err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Err
ErrBackingStoreClosed
    ValueHandleStatus
ClosedByHandle -> Err -> m ()
forall a. Err -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Err
ErrBackingStoreValueHandleClosed
    ValueHandleStatus
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

mLookupValueHandle ::
  MonadState (Mock vs) m =>
  ValueHandle vs ->
  m ValueHandleStatus
mLookupValueHandle :: forall vs (m :: * -> *).
MonadState (Mock vs) m =>
ValueHandle vs -> m ValueHandleStatus
mLookupValueHandle ValueHandle vs
vh = do
  vhs <- (Mock vs -> Map ID ValueHandleStatus)
-> m (Map ID ValueHandleStatus)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Mock vs -> Map ID ValueHandleStatus
forall vs. Mock vs -> Map ID ValueHandleStatus
valueHandles
  case Map.lookup (getId vh) vhs of
    Maybe ValueHandleStatus
Nothing -> String -> m ValueHandleStatus
forall a. HasCallStack => String -> a
error String
"Value handle not found"
    Just ValueHandleStatus
status -> ValueHandleStatus -> m ValueHandleStatus
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValueHandleStatus
status

-- | Close a backing store value handle.
--
-- Closing is idempotent.
mBSVHClose ::
  MonadState (Mock vs) m =>
  ValueHandle vs ->
  m ()
mBSVHClose :: forall vs (m :: * -> *).
MonadState (Mock vs) m =>
ValueHandle vs -> m ()
mBSVHClose ValueHandle vs
vh = do
  status <- ValueHandle vs -> m ValueHandleStatus
forall vs (m :: * -> *).
MonadState (Mock vs) m =>
ValueHandle vs -> m ValueHandleStatus
mLookupValueHandle ValueHandle vs
vh
  case status of
    ValueHandleStatus
ClosedByStore -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ValueHandleStatus
ClosedByHandle -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ValueHandleStatus
_ ->
      (Mock vs -> Mock vs) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify
        ( \Mock vs
m ->
            Mock vs
m
              { valueHandles = Map.adjust (const ClosedByHandle) (getId vh) (valueHandles m)
              }
        )

-- | Perform a range read on a backing store value handle.
mBSVHRangeRead ::
  (MonadState (Mock vs) m, MonadError Err m, LookupKeysRange ks vs) =>
  ValueHandle vs ->
  BS.ReadHint vs ->
  BS.RangeQuery ks ->
  m vs
mBSVHRangeRead :: forall vs (m :: * -> *) ks.
(MonadState (Mock vs) m, MonadError Err m,
 LookupKeysRange ks vs) =>
ValueHandle vs -> ReadHint vs -> RangeQuery ks -> m vs
mBSVHRangeRead ValueHandle vs
vh ReadHint vs
_ BS.RangeQuery{Maybe ks
rqPrev :: Maybe ks
rqPrev :: forall keys. RangeQuery keys -> Maybe keys
BS.rqPrev, Int
rqCount :: Int
rqCount :: forall keys. RangeQuery keys -> Int
BS.rqCount} = do
  m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
m ()
mGuardBSClosed
  ValueHandle vs -> m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
ValueHandle vs -> m ()
mGuardBSVHClosed ValueHandle vs
vh
  let
    vs :: vs
vs = ValueHandle vs -> vs
forall values. ValueHandle values -> values
values ValueHandle vs
vh
  vs -> m vs
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (vs -> m vs) -> vs -> m vs
forall a b. (a -> b) -> a -> b
$ Maybe ks -> Int -> vs -> vs
forall ks vs. LookupKeysRange ks vs => Maybe ks -> Int -> vs -> vs
lookupKeysRange Maybe ks
rqPrev Int
rqCount vs
vs

-- | Perform a regular read on a backing store value handle
mBSVHRead ::
  (MonadState (Mock vs) m, MonadError Err m, LookupKeys ks vs) =>
  ValueHandle vs ->
  BS.ReadHint vs ->
  ks ->
  m vs
mBSVHRead :: forall vs (m :: * -> *) ks.
(MonadState (Mock vs) m, MonadError Err m, LookupKeys ks vs) =>
ValueHandle vs -> ReadHint vs -> ks -> m vs
mBSVHRead ValueHandle vs
vh ReadHint vs
_ ks
ks = do
  m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
m ()
mGuardBSClosed
  ValueHandle vs -> m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
ValueHandle vs -> m ()
mGuardBSVHClosed ValueHandle vs
vh
  let vs :: vs
vs = ValueHandle vs -> vs
forall values. ValueHandle values -> values
values ValueHandle vs
vh
  vs -> m vs
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (vs -> m vs) -> vs -> m vs
forall a b. (a -> b) -> a -> b
$ ks -> vs -> vs
forall ks vs. LookupKeys ks vs => ks -> vs -> vs
lookupKeys ks
ks vs
vs

-- | Read the slot number out of a value handle
mBSVHAtSlot :: Monad m => ValueHandle vs -> m (WithOrigin SlotNo)
mBSVHAtSlot :: forall (m :: * -> *) vs.
Monad m =>
ValueHandle vs -> m (WithOrigin SlotNo)
mBSVHAtSlot = WithOrigin SlotNo -> m (WithOrigin SlotNo)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithOrigin SlotNo -> m (WithOrigin SlotNo))
-> (ValueHandle vs -> WithOrigin SlotNo)
-> ValueHandle vs
-> m (WithOrigin SlotNo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueHandle vs -> WithOrigin SlotNo
forall values. ValueHandle values -> WithOrigin SlotNo
seqNo

-- | Retrieve statistics for the backing store value handle.
mBSVHStat ::
  (MonadState (Mock vs) m, MonadError Err m, ValuesLength vs) =>
  ValueHandle vs ->
  m BS.Statistics
mBSVHStat :: forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m, ValuesLength vs) =>
ValueHandle vs -> m Statistics
mBSVHStat ValueHandle vs
vh = do
  m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
m ()
mGuardBSClosed
  ValueHandle vs -> m ()
forall vs (m :: * -> *).
(MonadState (Mock vs) m, MonadError Err m) =>
ValueHandle vs -> m ()
mGuardBSVHClosed ValueHandle vs
vh
  Statistics -> m Statistics
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Statistics -> m Statistics) -> Statistics -> m Statistics
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> Int -> Statistics
BS.Statistics (ValueHandle vs -> WithOrigin SlotNo
forall values. ValueHandle values -> WithOrigin SlotNo
seqNo ValueHandle vs
vh) (vs -> Int
forall vs. ValuesLength vs => vs -> Int
valuesLength (vs -> Int) -> vs -> Int
forall a b. (a -> b) -> a -> b
$ ValueHandle vs -> vs
forall values. ValueHandle values -> values
values ValueHandle vs
vh)