{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif
module Test.Ouroboros.Storage.LedgerDB.OnDisk (
showLabelledExamples
, tests
) where
import Codec.Serialise (Serialise)
import qualified Codec.Serialise as S
import Control.Concurrent.Class.MonadSTM.Strict (newTMVar)
import Control.Monad.Except (Except, runExcept)
import Control.Monad.State (StateT (..))
import qualified Control.Monad.State as State
import Control.Tracer (nullTracer)
import Data.Bifunctor
import Data.Foldable (toList)
import Data.Functor.Classes
import qualified Data.List as L
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.TreeDiff
import Data.Word
import GHC.Generics (Generic)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Storage.ImmutableDB.Stream
import Ouroboros.Consensus.Storage.LedgerDB
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.IOLike
import Prelude hiding (elem)
import System.FS.API
import qualified System.FS.Sim.MockFS as MockFS
import System.FS.Sim.STM
import System.Random (getStdRandom, randomR)
import Test.Ouroboros.Storage.LedgerDB.InMemory ()
import Test.Ouroboros.Storage.LedgerDB.OrphanArbitrary ()
import qualified Test.QuickCheck as QC
import Test.QuickCheck (Gen)
import qualified Test.QuickCheck.Monadic as QC
import qualified Test.QuickCheck.Random as QC
import Test.StateMachine hiding (showLabelledExamples)
import qualified Test.StateMachine.Labelling as C
import qualified Test.StateMachine.Types as QSM
import qualified Test.StateMachine.Types.Rank2 as Rank2
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Test.Util.Range
import Test.Util.TestBlock hiding (TestBlock, TestBlockCodecConfig,
TestBlockStorageConfig)
import Test.Util.ToExpr ()
tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"OnDisk" [
TestName -> (SecurityParam -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"LedgerSimple" SecurityParam -> Property
prop_sequential
]
type TestBlock = TestBlockWith Tx
data Tx = Tx {
Tx -> Token
consumed :: Token
, Tx -> (Token, TValue)
produced :: (Token, TValue)
}
deriving stock (Int -> Tx -> ShowS
[Tx] -> ShowS
Tx -> TestName
(Int -> Tx -> ShowS)
-> (Tx -> TestName) -> ([Tx] -> ShowS) -> Show Tx
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tx -> ShowS
showsPrec :: Int -> Tx -> ShowS
$cshow :: Tx -> TestName
show :: Tx -> TestName
$cshowList :: [Tx] -> ShowS
showList :: [Tx] -> ShowS
Show, Tx -> Tx -> Bool
(Tx -> Tx -> Bool) -> (Tx -> Tx -> Bool) -> Eq Tx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tx -> Tx -> Bool
== :: Tx -> Tx -> Bool
$c/= :: Tx -> Tx -> Bool
/= :: Tx -> Tx -> Bool
Eq, Eq Tx
Eq Tx =>
(Tx -> Tx -> Ordering)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Bool)
-> (Tx -> Tx -> Tx)
-> (Tx -> Tx -> Tx)
-> Ord Tx
Tx -> Tx -> Bool
Tx -> Tx -> Ordering
Tx -> Tx -> Tx
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 :: Tx -> Tx -> Ordering
compare :: Tx -> Tx -> Ordering
$c< :: Tx -> Tx -> Bool
< :: Tx -> Tx -> Bool
$c<= :: Tx -> Tx -> Bool
<= :: Tx -> Tx -> Bool
$c> :: Tx -> Tx -> Bool
> :: Tx -> Tx -> Bool
$c>= :: Tx -> Tx -> Bool
>= :: Tx -> Tx -> Bool
$cmax :: Tx -> Tx -> Tx
max :: Tx -> Tx -> Tx
$cmin :: Tx -> Tx -> Tx
min :: Tx -> Tx -> Tx
Ord, (forall x. Tx -> Rep Tx x)
-> (forall x. Rep Tx x -> Tx) -> Generic Tx
forall x. Rep Tx x -> Tx
forall x. Tx -> Rep Tx x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Tx -> Rep Tx x
from :: forall x. Tx -> Rep Tx x
$cto :: forall x. Rep Tx x -> Tx
to :: forall x. Rep Tx x -> Tx
Generic)
deriving anyclass ([Tx] -> Encoding
Tx -> Encoding
(Tx -> Encoding)
-> (forall s. Decoder s Tx)
-> ([Tx] -> Encoding)
-> (forall s. Decoder s [Tx])
-> Serialise Tx
forall s. Decoder s [Tx]
forall s. Decoder s Tx
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Tx -> Encoding
encode :: Tx -> Encoding
$cdecode :: forall s. Decoder s Tx
decode :: forall s. Decoder s Tx
$cencodeList :: [Tx] -> Encoding
encodeList :: [Tx] -> Encoding
$cdecodeList :: forall s. Decoder s [Tx]
decodeList :: forall s. Decoder s [Tx]
Serialise, Context -> Tx -> IO (Maybe ThunkInfo)
Proxy Tx -> TestName
(Context -> Tx -> IO (Maybe ThunkInfo))
-> (Context -> Tx -> IO (Maybe ThunkInfo))
-> (Proxy Tx -> TestName)
-> NoThunks Tx
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
noThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Tx -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Tx -> TestName
showTypeOf :: Proxy Tx -> TestName
NoThunks, [Tx] -> Expr
Tx -> Expr
(Tx -> Expr) -> ([Tx] -> Expr) -> ToExpr Tx
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: Tx -> Expr
toExpr :: Tx -> Expr
$clistToExpr :: [Tx] -> Expr
listToExpr :: [Tx] -> Expr
ToExpr)
newtype Token = Token { Token -> Point TestBlock
unToken :: Point TestBlock }
deriving stock (Int -> Token -> ShowS
[Token] -> ShowS
Token -> TestName
(Int -> Token -> ShowS)
-> (Token -> TestName) -> ([Token] -> ShowS) -> Show Token
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Token -> ShowS
showsPrec :: Int -> Token -> ShowS
$cshow :: Token -> TestName
show :: Token -> TestName
$cshowList :: [Token] -> ShowS
showList :: [Token] -> ShowS
Show, Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq, Eq Token
Eq Token =>
(Token -> Token -> Ordering)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Bool)
-> (Token -> Token -> Token)
-> (Token -> Token -> Token)
-> Ord Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
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 :: Token -> Token -> Ordering
compare :: Token -> Token -> Ordering
$c< :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
>= :: Token -> Token -> Bool
$cmax :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
min :: Token -> Token -> Token
Ord, (forall x. Token -> Rep Token x)
-> (forall x. Rep Token x -> Token) -> Generic Token
forall x. Rep Token x -> Token
forall x. Token -> Rep Token x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Token -> Rep Token x
from :: forall x. Token -> Rep Token x
$cto :: forall x. Rep Token x -> Token
to :: forall x. Rep Token x -> Token
Generic)
deriving newtype ([Token] -> Encoding
Token -> Encoding
(Token -> Encoding)
-> (forall s. Decoder s Token)
-> ([Token] -> Encoding)
-> (forall s. Decoder s [Token])
-> Serialise Token
forall s. Decoder s [Token]
forall s. Decoder s Token
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: Token -> Encoding
encode :: Token -> Encoding
$cdecode :: forall s. Decoder s Token
decode :: forall s. Decoder s Token
$cencodeList :: [Token] -> Encoding
encodeList :: [Token] -> Encoding
$cdecodeList :: forall s. Decoder s [Token]
decodeList :: forall s. Decoder s [Token]
Serialise, Context -> Token -> IO (Maybe ThunkInfo)
Proxy Token -> TestName
(Context -> Token -> IO (Maybe ThunkInfo))
-> (Context -> Token -> IO (Maybe ThunkInfo))
-> (Proxy Token -> TestName)
-> NoThunks Token
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> Token -> IO (Maybe ThunkInfo)
noThunks :: Context -> Token -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Token -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Token -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Token -> TestName
showTypeOf :: Proxy Token -> TestName
NoThunks, [Token] -> Expr
Token -> Expr
(Token -> Expr) -> ([Token] -> Expr) -> ToExpr Token
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: Token -> Expr
toExpr :: Token -> Expr
$clistToExpr :: [Token] -> Expr
listToExpr :: [Token] -> Expr
ToExpr)
newtype TValue = TValue (WithOrigin SlotNo)
deriving stock (Int -> TValue -> ShowS
[TValue] -> ShowS
TValue -> TestName
(Int -> TValue -> ShowS)
-> (TValue -> TestName) -> ([TValue] -> ShowS) -> Show TValue
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TValue -> ShowS
showsPrec :: Int -> TValue -> ShowS
$cshow :: TValue -> TestName
show :: TValue -> TestName
$cshowList :: [TValue] -> ShowS
showList :: [TValue] -> ShowS
Show, TValue -> TValue -> Bool
(TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool) -> Eq TValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TValue -> TValue -> Bool
== :: TValue -> TValue -> Bool
$c/= :: TValue -> TValue -> Bool
/= :: TValue -> TValue -> Bool
Eq, Eq TValue
Eq TValue =>
(TValue -> TValue -> Ordering)
-> (TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool)
-> (TValue -> TValue -> Bool)
-> (TValue -> TValue -> TValue)
-> (TValue -> TValue -> TValue)
-> Ord TValue
TValue -> TValue -> Bool
TValue -> TValue -> Ordering
TValue -> TValue -> TValue
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 :: TValue -> TValue -> Ordering
compare :: TValue -> TValue -> Ordering
$c< :: TValue -> TValue -> Bool
< :: TValue -> TValue -> Bool
$c<= :: TValue -> TValue -> Bool
<= :: TValue -> TValue -> Bool
$c> :: TValue -> TValue -> Bool
> :: TValue -> TValue -> Bool
$c>= :: TValue -> TValue -> Bool
>= :: TValue -> TValue -> Bool
$cmax :: TValue -> TValue -> TValue
max :: TValue -> TValue -> TValue
$cmin :: TValue -> TValue -> TValue
min :: TValue -> TValue -> TValue
Ord, (forall x. TValue -> Rep TValue x)
-> (forall x. Rep TValue x -> TValue) -> Generic TValue
forall x. Rep TValue x -> TValue
forall x. TValue -> Rep TValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TValue -> Rep TValue x
from :: forall x. TValue -> Rep TValue x
$cto :: forall x. Rep TValue x -> TValue
to :: forall x. Rep TValue x -> TValue
Generic)
deriving newtype ([TValue] -> Encoding
TValue -> Encoding
(TValue -> Encoding)
-> (forall s. Decoder s TValue)
-> ([TValue] -> Encoding)
-> (forall s. Decoder s [TValue])
-> Serialise TValue
forall s. Decoder s [TValue]
forall s. Decoder s TValue
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TValue -> Encoding
encode :: TValue -> Encoding
$cdecode :: forall s. Decoder s TValue
decode :: forall s. Decoder s TValue
$cencodeList :: [TValue] -> Encoding
encodeList :: [TValue] -> Encoding
$cdecodeList :: forall s. Decoder s [TValue]
decodeList :: forall s. Decoder s [TValue]
Serialise, Context -> TValue -> IO (Maybe ThunkInfo)
Proxy TValue -> TestName
(Context -> TValue -> IO (Maybe ThunkInfo))
-> (Context -> TValue -> IO (Maybe ThunkInfo))
-> (Proxy TValue -> TestName)
-> NoThunks TValue
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> TValue -> IO (Maybe ThunkInfo)
noThunks :: Context -> TValue -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TValue -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TValue -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TValue -> TestName
showTypeOf :: Proxy TValue -> TestName
NoThunks, [TValue] -> Expr
TValue -> Expr
(TValue -> Expr) -> ([TValue] -> Expr) -> ToExpr TValue
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: TValue -> Expr
toExpr :: TValue -> Expr
$clistToExpr :: [TValue] -> Expr
listToExpr :: [TValue] -> Expr
ToExpr)
data UTxTok = UTxTok { UTxTok -> Map Token TValue
utxtok :: Map Token TValue
,
UTxTok -> Set Token
utxhist :: Set Token
}
deriving stock ((forall x. UTxTok -> Rep UTxTok x)
-> (forall x. Rep UTxTok x -> UTxTok) -> Generic UTxTok
forall x. Rep UTxTok x -> UTxTok
forall x. UTxTok -> Rep UTxTok x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UTxTok -> Rep UTxTok x
from :: forall x. UTxTok -> Rep UTxTok x
$cto :: forall x. Rep UTxTok x -> UTxTok
to :: forall x. Rep UTxTok x -> UTxTok
Generic, UTxTok -> UTxTok -> Bool
(UTxTok -> UTxTok -> Bool)
-> (UTxTok -> UTxTok -> Bool) -> Eq UTxTok
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UTxTok -> UTxTok -> Bool
== :: UTxTok -> UTxTok -> Bool
$c/= :: UTxTok -> UTxTok -> Bool
/= :: UTxTok -> UTxTok -> Bool
Eq, Int -> UTxTok -> ShowS
[UTxTok] -> ShowS
UTxTok -> TestName
(Int -> UTxTok -> ShowS)
-> (UTxTok -> TestName) -> ([UTxTok] -> ShowS) -> Show UTxTok
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UTxTok -> ShowS
showsPrec :: Int -> UTxTok -> ShowS
$cshow :: UTxTok -> TestName
show :: UTxTok -> TestName
$cshowList :: [UTxTok] -> ShowS
showList :: [UTxTok] -> ShowS
Show)
deriving anyclass (Context -> UTxTok -> IO (Maybe ThunkInfo)
Proxy UTxTok -> TestName
(Context -> UTxTok -> IO (Maybe ThunkInfo))
-> (Context -> UTxTok -> IO (Maybe ThunkInfo))
-> (Proxy UTxTok -> TestName)
-> NoThunks UTxTok
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> UTxTok -> IO (Maybe ThunkInfo)
noThunks :: Context -> UTxTok -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> UTxTok -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> UTxTok -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy UTxTok -> TestName
showTypeOf :: Proxy UTxTok -> TestName
NoThunks, [UTxTok] -> Encoding
UTxTok -> Encoding
(UTxTok -> Encoding)
-> (forall s. Decoder s UTxTok)
-> ([UTxTok] -> Encoding)
-> (forall s. Decoder s [UTxTok])
-> Serialise UTxTok
forall s. Decoder s [UTxTok]
forall s. Decoder s UTxTok
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: UTxTok -> Encoding
encode :: UTxTok -> Encoding
$cdecode :: forall s. Decoder s UTxTok
decode :: forall s. Decoder s UTxTok
$cencodeList :: [UTxTok] -> Encoding
encodeList :: [UTxTok] -> Encoding
$cdecodeList :: forall s. Decoder s [UTxTok]
decodeList :: forall s. Decoder s [UTxTok]
Serialise, [UTxTok] -> Expr
UTxTok -> Expr
(UTxTok -> Expr) -> ([UTxTok] -> Expr) -> ToExpr UTxTok
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: UTxTok -> Expr
toExpr :: UTxTok -> Expr
$clistToExpr :: [UTxTok] -> Expr
listToExpr :: [UTxTok] -> Expr
ToExpr)
data TxErr
= TokenWasAlreadyCreated Token
| TokenDoesNotExist Token
deriving stock ((forall x. TxErr -> Rep TxErr x)
-> (forall x. Rep TxErr x -> TxErr) -> Generic TxErr
forall x. Rep TxErr x -> TxErr
forall x. TxErr -> Rep TxErr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TxErr -> Rep TxErr x
from :: forall x. TxErr -> Rep TxErr x
$cto :: forall x. Rep TxErr x -> TxErr
to :: forall x. Rep TxErr x -> TxErr
Generic, TxErr -> TxErr -> Bool
(TxErr -> TxErr -> Bool) -> (TxErr -> TxErr -> Bool) -> Eq TxErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TxErr -> TxErr -> Bool
== :: TxErr -> TxErr -> Bool
$c/= :: TxErr -> TxErr -> Bool
/= :: TxErr -> TxErr -> Bool
Eq, Int -> TxErr -> ShowS
[TxErr] -> ShowS
TxErr -> TestName
(Int -> TxErr -> ShowS)
-> (TxErr -> TestName) -> ([TxErr] -> ShowS) -> Show TxErr
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxErr -> ShowS
showsPrec :: Int -> TxErr -> ShowS
$cshow :: TxErr -> TestName
show :: TxErr -> TestName
$cshowList :: [TxErr] -> ShowS
showList :: [TxErr] -> ShowS
Show)
deriving anyclass (Context -> TxErr -> IO (Maybe ThunkInfo)
Proxy TxErr -> TestName
(Context -> TxErr -> IO (Maybe ThunkInfo))
-> (Context -> TxErr -> IO (Maybe ThunkInfo))
-> (Proxy TxErr -> TestName)
-> NoThunks TxErr
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> TxErr -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxErr -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TxErr -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TxErr -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TxErr -> TestName
showTypeOf :: Proxy TxErr -> TestName
NoThunks, [TxErr] -> Encoding
TxErr -> Encoding
(TxErr -> Encoding)
-> (forall s. Decoder s TxErr)
-> ([TxErr] -> Encoding)
-> (forall s. Decoder s [TxErr])
-> Serialise TxErr
forall s. Decoder s [TxErr]
forall s. Decoder s TxErr
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TxErr -> Encoding
encode :: TxErr -> Encoding
$cdecode :: forall s. Decoder s TxErr
decode :: forall s. Decoder s TxErr
$cencodeList :: [TxErr] -> Encoding
encodeList :: [TxErr] -> Encoding
$cdecodeList :: forall s. Decoder s [TxErr]
decodeList :: forall s. Decoder s [TxErr]
Serialise, [TxErr] -> Expr
TxErr -> Expr
(TxErr -> Expr) -> ([TxErr] -> Expr) -> ToExpr TxErr
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: TxErr -> Expr
toExpr :: TxErr -> Expr
$clistToExpr :: [TxErr] -> Expr
listToExpr :: [TxErr] -> Expr
ToExpr)
instance PayloadSemantics Tx where
type PayloadDependentState Tx = UTxTok
type PayloadDependentError Tx = TxErr
applyPayload :: PayloadDependentState Tx
-> Tx
-> Either (PayloadDependentError Tx) (PayloadDependentState Tx)
applyPayload PayloadDependentState Tx
st Tx{Token
consumed :: Tx -> Token
consumed :: Token
consumed, (Token, TValue)
produced :: Tx -> (Token, TValue)
produced :: (Token, TValue)
produced} =
Token -> UTxTok -> Either TxErr UTxTok
delete Token
consumed PayloadDependentState Tx
UTxTok
st Either TxErr UTxTok
-> (UTxTok -> Either TxErr UTxTok) -> Either TxErr UTxTok
forall a b.
Either TxErr a -> (a -> Either TxErr b) -> Either TxErr b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Token -> TValue -> UTxTok -> Either TxErr UTxTok)
-> (Token, TValue) -> UTxTok -> Either TxErr UTxTok
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Token -> TValue -> UTxTok -> Either TxErr UTxTok
insert (Token, TValue)
produced
where
insert :: Token -> TValue -> UTxTok -> Either TxErr UTxTok
insert :: Token -> TValue -> UTxTok -> Either TxErr UTxTok
insert Token
tok TValue
val UTxTok{Map Token TValue
utxtok :: UTxTok -> Map Token TValue
utxtok :: Map Token TValue
utxtok, Set Token
utxhist :: UTxTok -> Set Token
utxhist :: Set Token
utxhist} =
if Token
tok Token -> Set Token -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Token
utxhist
then TxErr -> Either TxErr UTxTok
forall a b. a -> Either a b
Left (TxErr -> Either TxErr UTxTok) -> TxErr -> Either TxErr UTxTok
forall a b. (a -> b) -> a -> b
$ Token -> TxErr
TokenWasAlreadyCreated Token
tok
else UTxTok -> Either TxErr UTxTok
forall a b. b -> Either a b
Right (UTxTok -> Either TxErr UTxTok) -> UTxTok -> Either TxErr UTxTok
forall a b. (a -> b) -> a -> b
$ UTxTok { utxtok :: Map Token TValue
utxtok = Token -> TValue -> Map Token TValue -> Map Token TValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Token
tok TValue
val Map Token TValue
utxtok
, utxhist :: Set Token
utxhist = Token -> Set Token -> Set Token
forall a. Ord a => a -> Set a -> Set a
Set.insert Token
tok Set Token
utxhist
}
delete :: Token -> UTxTok -> Either TxErr UTxTok
delete :: Token -> UTxTok -> Either TxErr UTxTok
delete Token
tok st' :: UTxTok
st'@UTxTok{Map Token TValue
utxtok :: UTxTok -> Map Token TValue
utxtok :: Map Token TValue
utxtok} =
if Token
tok Token -> Map Token TValue -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map Token TValue
utxtok
then UTxTok -> Either TxErr UTxTok
forall a b. b -> Either a b
Right (UTxTok -> Either TxErr UTxTok) -> UTxTok -> Either TxErr UTxTok
forall a b. (a -> b) -> a -> b
$ UTxTok
st' { utxtok = Map.delete tok utxtok }
else TxErr -> Either TxErr UTxTok
forall a b. a -> Either a b
Left (TxErr -> Either TxErr UTxTok) -> TxErr -> Either TxErr UTxTok
forall a b. (a -> b) -> a -> b
$ Token -> TxErr
TokenDoesNotExist Token
tok
initialTestLedgerState :: UTxTok
initialTestLedgerState :: UTxTok
initialTestLedgerState = UTxTok {
utxtok :: Map Token TValue
utxtok = Token -> TValue -> Map Token TValue
forall k a. k -> a -> Map k a
Map.singleton Token
initialToken (Token -> TValue
pointTValue Token
initialToken)
, utxhist :: Set Token
utxhist = Token -> Set Token
forall a. a -> Set a
Set.singleton Token
initialToken
}
where
initialToken :: Token
initialToken = Point TestBlock -> Token
Token Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint
pointTValue :: Token -> TValue
pointTValue :: Token -> TValue
pointTValue = WithOrigin SlotNo -> TValue
TValue (WithOrigin SlotNo -> TValue)
-> (Token -> WithOrigin SlotNo) -> Token -> TValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point TestBlock -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot (Point TestBlock -> WithOrigin SlotNo)
-> (Token -> Point TestBlock) -> Token -> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Token -> Point TestBlock
unToken
genBlocks ::
Word64
-> Point TestBlock
-> [TestBlock]
genBlocks :: Word64 -> Point TestBlock -> [TestBlock]
genBlocks Word64
n Point TestBlock
pt0 = Int -> [TestBlock] -> [TestBlock]
forall a. Int -> [a] -> [a]
take (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) (Point TestBlock -> [TestBlock]
go Point TestBlock
pt0)
where
go :: Point TestBlock -> [TestBlock]
go Point TestBlock
pt = let b :: TestBlock
b = Point TestBlock -> TestBlock
genBlock Point TestBlock
pt in TestBlock
b TestBlock -> [TestBlock] -> [TestBlock]
forall a. a -> [a] -> [a]
: Point TestBlock -> [TestBlock]
go (TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b)
genBlock ::
Point TestBlock -> TestBlock
genBlock :: Point TestBlock -> TestBlock
genBlock Point TestBlock
pt =
Point TestBlock -> Tx -> TestBlock
forall ptype.
Point (TestBlockWith ptype) -> ptype -> TestBlockWith ptype
mkBlockFrom Point TestBlock
pt Tx { consumed :: Token
consumed = Point TestBlock -> Token
Token Point TestBlock
pt
, produced :: (Token, TValue)
produced = ( Point TestBlock -> Token
Token Point TestBlock
pt', WithOrigin SlotNo -> TValue
TValue (Point TestBlock -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point TestBlock
pt'))
}
where
mkBlockFrom :: Point (TestBlockWith ptype) -> ptype -> (TestBlockWith ptype)
mkBlockFrom :: forall ptype.
Point (TestBlockWith ptype) -> ptype -> TestBlockWith ptype
mkBlockFrom Point (TestBlockWith ptype)
GenesisPoint = Word64 -> ptype -> TestBlockWith ptype
forall ptype. Word64 -> ptype -> TestBlockWith ptype
firstBlockWithPayload Word64
0
mkBlockFrom (BlockPoint SlotNo
slot HeaderHash (TestBlockWith ptype)
hash) = TestHash -> SlotNo -> ptype -> TestBlockWith ptype
forall ptype. TestHash -> SlotNo -> ptype -> TestBlockWith ptype
successorBlockWithPayload HeaderHash (TestBlockWith ptype)
TestHash
hash SlotNo
slot
pt' :: Point (TestBlockWith Tx)
pt' :: Point TestBlock
pt' = Point (TestBlockWith ()) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (TestBlockWith () -> Point (TestBlockWith ())
forall block. HasHeader block => block -> Point block
blockPoint TestBlockWith ()
dummyBlk)
where
dummyBlk :: TestBlockWith ()
dummyBlk :: TestBlockWith ()
dummyBlk = Point (TestBlockWith ()) -> () -> TestBlockWith ()
forall ptype.
Point (TestBlockWith ptype) -> ptype -> TestBlockWith ptype
mkBlockFrom (Point TestBlock -> Point (TestBlockWith ())
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point TestBlock
pt) ()
genBlockFromLedgerState :: ExtLedgerState TestBlock -> Gen TestBlock
genBlockFromLedgerState :: ExtLedgerState TestBlock -> Gen TestBlock
genBlockFromLedgerState = TestBlock -> Gen TestBlock
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestBlock -> Gen TestBlock)
-> (ExtLedgerState TestBlock -> TestBlock)
-> ExtLedgerState TestBlock
-> Gen TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point TestBlock -> TestBlock
genBlock (Point TestBlock -> TestBlock)
-> (ExtLedgerState TestBlock -> Point TestBlock)
-> ExtLedgerState TestBlock
-> TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState TestBlock -> Point TestBlock
forall ptype.
LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
lastAppliedPoint (LedgerState TestBlock -> Point TestBlock)
-> (ExtLedgerState TestBlock -> LedgerState TestBlock)
-> ExtLedgerState TestBlock
-> Point TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState TestBlock -> LedgerState TestBlock
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState
extLedgerDbConfig :: SecurityParam -> LedgerDbCfg (ExtLedgerState TestBlock)
extLedgerDbConfig :: SecurityParam -> LedgerDbCfg (ExtLedgerState TestBlock)
extLedgerDbConfig SecurityParam
secParam = LedgerDbCfg {
ledgerDbCfgSecParam :: SecurityParam
ledgerDbCfgSecParam = SecurityParam
secParam
, ledgerDbCfg :: LedgerCfg (ExtLedgerState TestBlock)
ledgerDbCfg = TopLevelConfig TestBlock -> ExtLedgerCfg TestBlock
forall blk. TopLevelConfig blk -> ExtLedgerCfg blk
ExtLedgerCfg (TopLevelConfig TestBlock -> ExtLedgerCfg TestBlock)
-> TopLevelConfig TestBlock -> ExtLedgerCfg TestBlock
forall a b. (a -> b) -> a -> b
$ CodecConfig TestBlock
-> StorageConfig TestBlock
-> SecurityParam
-> GenesisWindow
-> TopLevelConfig TestBlock
forall ptype.
CodecConfig (TestBlockWith ptype)
-> StorageConfig (TestBlockWith ptype)
-> SecurityParam
-> GenesisWindow
-> TopLevelConfig (TestBlockWith ptype)
singleNodeTestConfigWith CodecConfig TestBlock
TestBlockCodecConfig StorageConfig TestBlock
TestBlockStorageConfig SecurityParam
secParam (Word64 -> GenesisWindow
GenesisWindow (Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* SecurityParam -> Word64
maxRollbacks SecurityParam
secParam))
}
data instance CodecConfig TestBlock = TestBlockCodecConfig
deriving (Int -> CodecConfig TestBlock -> ShowS
[CodecConfig TestBlock] -> ShowS
CodecConfig TestBlock -> TestName
(Int -> CodecConfig TestBlock -> ShowS)
-> (CodecConfig TestBlock -> TestName)
-> ([CodecConfig TestBlock] -> ShowS)
-> Show (CodecConfig TestBlock)
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CodecConfig TestBlock -> ShowS
showsPrec :: Int -> CodecConfig TestBlock -> ShowS
$cshow :: CodecConfig TestBlock -> TestName
show :: CodecConfig TestBlock -> TestName
$cshowList :: [CodecConfig TestBlock] -> ShowS
showList :: [CodecConfig TestBlock] -> ShowS
Show, (forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x)
-> (forall x.
Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock)
-> Generic (CodecConfig TestBlock)
forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
from :: forall x. CodecConfig TestBlock -> Rep (CodecConfig TestBlock) x
$cto :: forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
to :: forall x. Rep (CodecConfig TestBlock) x -> CodecConfig TestBlock
Generic, Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
Proxy (CodecConfig TestBlock) -> TestName
(Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (CodecConfig TestBlock) -> TestName)
-> NoThunks (CodecConfig TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> CodecConfig TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (CodecConfig TestBlock) -> TestName
showTypeOf :: Proxy (CodecConfig TestBlock) -> TestName
NoThunks)
data instance StorageConfig TestBlock = TestBlockStorageConfig
deriving (Int -> StorageConfig TestBlock -> ShowS
[StorageConfig TestBlock] -> ShowS
StorageConfig TestBlock -> TestName
(Int -> StorageConfig TestBlock -> ShowS)
-> (StorageConfig TestBlock -> TestName)
-> ([StorageConfig TestBlock] -> ShowS)
-> Show (StorageConfig TestBlock)
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StorageConfig TestBlock -> ShowS
showsPrec :: Int -> StorageConfig TestBlock -> ShowS
$cshow :: StorageConfig TestBlock -> TestName
show :: StorageConfig TestBlock -> TestName
$cshowList :: [StorageConfig TestBlock] -> ShowS
showList :: [StorageConfig TestBlock] -> ShowS
Show, (forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x)
-> (forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock)
-> Generic (StorageConfig TestBlock)
forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
from :: forall x.
StorageConfig TestBlock -> Rep (StorageConfig TestBlock) x
$cto :: forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
to :: forall x.
Rep (StorageConfig TestBlock) x -> StorageConfig TestBlock
Generic, Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
Proxy (StorageConfig TestBlock) -> TestName
(Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo))
-> (Proxy (StorageConfig TestBlock) -> TestName)
-> NoThunks (StorageConfig TestBlock)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> TestName)
-> NoThunks a
$cnoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
noThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> StorageConfig TestBlock -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (StorageConfig TestBlock) -> TestName
showTypeOf :: Proxy (StorageConfig TestBlock) -> TestName
NoThunks)
data Corruption =
Delete
| Truncate
deriving (Int -> Corruption -> ShowS
[Corruption] -> ShowS
Corruption -> TestName
(Int -> Corruption -> ShowS)
-> (Corruption -> TestName)
-> ([Corruption] -> ShowS)
-> Show Corruption
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Corruption -> ShowS
showsPrec :: Int -> Corruption -> ShowS
$cshow :: Corruption -> TestName
show :: Corruption -> TestName
$cshowList :: [Corruption] -> ShowS
showList :: [Corruption] -> ShowS
Show, Corruption -> Corruption -> Bool
(Corruption -> Corruption -> Bool)
-> (Corruption -> Corruption -> Bool) -> Eq Corruption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Corruption -> Corruption -> Bool
== :: Corruption -> Corruption -> Bool
$c/= :: Corruption -> Corruption -> Bool
/= :: Corruption -> Corruption -> Bool
Eq, (forall x. Corruption -> Rep Corruption x)
-> (forall x. Rep Corruption x -> Corruption) -> Generic Corruption
forall x. Rep Corruption x -> Corruption
forall x. Corruption -> Rep Corruption x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Corruption -> Rep Corruption x
from :: forall x. Corruption -> Rep Corruption x
$cto :: forall x. Rep Corruption x -> Corruption
to :: forall x. Rep Corruption x -> Corruption
Generic, [Corruption] -> Expr
Corruption -> Expr
(Corruption -> Expr) -> ([Corruption] -> Expr) -> ToExpr Corruption
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: Corruption -> Expr
toExpr :: Corruption -> Expr
$clistToExpr :: [Corruption] -> Expr
listToExpr :: [Corruption] -> Expr
ToExpr)
data Cmd ss =
Current
| Push TestBlock
| Switch Word64 [TestBlock]
| Snap
| Restore
| Corrupt Corruption ss
| Drop Word64
deriving (Int -> Cmd ss -> ShowS
[Cmd ss] -> ShowS
Cmd ss -> TestName
(Int -> Cmd ss -> ShowS)
-> (Cmd ss -> TestName) -> ([Cmd ss] -> ShowS) -> Show (Cmd ss)
forall ss. Show ss => Int -> Cmd ss -> ShowS
forall ss. Show ss => [Cmd ss] -> ShowS
forall ss. Show ss => Cmd ss -> TestName
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ss. Show ss => Int -> Cmd ss -> ShowS
showsPrec :: Int -> Cmd ss -> ShowS
$cshow :: forall ss. Show ss => Cmd ss -> TestName
show :: Cmd ss -> TestName
$cshowList :: forall ss. Show ss => [Cmd ss] -> ShowS
showList :: [Cmd ss] -> ShowS
Show, Cmd ss -> Cmd ss -> Bool
(Cmd ss -> Cmd ss -> Bool)
-> (Cmd ss -> Cmd ss -> Bool) -> Eq (Cmd ss)
forall ss. Eq ss => Cmd ss -> Cmd ss -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall ss. Eq ss => Cmd ss -> Cmd ss -> Bool
== :: Cmd ss -> Cmd ss -> Bool
$c/= :: forall ss. Eq ss => Cmd ss -> Cmd ss -> Bool
/= :: Cmd ss -> Cmd ss -> Bool
Eq, (forall a b. (a -> b) -> Cmd a -> Cmd b)
-> (forall a b. a -> Cmd b -> Cmd a) -> Functor Cmd
forall a b. a -> Cmd b -> Cmd a
forall a b. (a -> b) -> Cmd a -> Cmd b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Cmd a -> Cmd b
fmap :: forall a b. (a -> b) -> Cmd a -> Cmd b
$c<$ :: forall a b. a -> Cmd b -> Cmd a
<$ :: forall a b. a -> Cmd b -> Cmd a
Functor, (forall m. Monoid m => Cmd m -> m)
-> (forall m a. Monoid m => (a -> m) -> Cmd a -> m)
-> (forall m a. Monoid m => (a -> m) -> Cmd a -> m)
-> (forall a b. (a -> b -> b) -> b -> Cmd a -> b)
-> (forall a b. (a -> b -> b) -> b -> Cmd a -> b)
-> (forall b a. (b -> a -> b) -> b -> Cmd a -> b)
-> (forall b a. (b -> a -> b) -> b -> Cmd a -> b)
-> (forall a. (a -> a -> a) -> Cmd a -> a)
-> (forall a. (a -> a -> a) -> Cmd a -> a)
-> (forall a. Cmd a -> [a])
-> (forall a. Cmd a -> Bool)
-> (forall a. Cmd a -> Int)
-> (forall a. Eq a => a -> Cmd a -> Bool)
-> (forall a. Ord a => Cmd a -> a)
-> (forall a. Ord a => Cmd a -> a)
-> (forall a. Num a => Cmd a -> a)
-> (forall a. Num a => Cmd a -> a)
-> Foldable Cmd
forall a. Eq a => a -> Cmd a -> Bool
forall a. Num a => Cmd a -> a
forall a. Ord a => Cmd a -> a
forall m. Monoid m => Cmd m -> m
forall a. Cmd a -> Bool
forall a. Cmd a -> Int
forall a. Cmd a -> [a]
forall a. (a -> a -> a) -> Cmd a -> a
forall m a. Monoid m => (a -> m) -> Cmd a -> m
forall b a. (b -> a -> b) -> b -> Cmd a -> b
forall a b. (a -> b -> b) -> b -> Cmd a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Cmd m -> m
fold :: forall m. Monoid m => Cmd m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Cmd a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Cmd a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Cmd a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Cmd a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Cmd a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Cmd a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Cmd a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Cmd a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Cmd a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Cmd a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Cmd a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Cmd a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Cmd a -> a
foldr1 :: forall a. (a -> a -> a) -> Cmd a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Cmd a -> a
foldl1 :: forall a. (a -> a -> a) -> Cmd a -> a
$ctoList :: forall a. Cmd a -> [a]
toList :: forall a. Cmd a -> [a]
$cnull :: forall a. Cmd a -> Bool
null :: forall a. Cmd a -> Bool
$clength :: forall a. Cmd a -> Int
length :: forall a. Cmd a -> Int
$celem :: forall a. Eq a => a -> Cmd a -> Bool
elem :: forall a. Eq a => a -> Cmd a -> Bool
$cmaximum :: forall a. Ord a => Cmd a -> a
maximum :: forall a. Ord a => Cmd a -> a
$cminimum :: forall a. Ord a => Cmd a -> a
minimum :: forall a. Ord a => Cmd a -> a
$csum :: forall a. Num a => Cmd a -> a
sum :: forall a. Num a => Cmd a -> a
$cproduct :: forall a. Num a => Cmd a -> a
product :: forall a. Num a => Cmd a -> a
Foldable, Functor Cmd
Foldable Cmd
(Functor Cmd, Foldable Cmd) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cmd a -> f (Cmd b))
-> (forall (f :: * -> *) a.
Applicative f =>
Cmd (f a) -> f (Cmd a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cmd a -> m (Cmd b))
-> (forall (m :: * -> *) a. Monad m => Cmd (m a) -> m (Cmd a))
-> Traversable Cmd
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Cmd (m a) -> m (Cmd a)
forall (f :: * -> *) a. Applicative f => Cmd (f a) -> f (Cmd a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cmd a -> m (Cmd b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cmd a -> f (Cmd b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cmd a -> f (Cmd b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cmd a -> f (Cmd b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Cmd (f a) -> f (Cmd a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Cmd (f a) -> f (Cmd a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cmd a -> m (Cmd b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cmd a -> m (Cmd b)
$csequence :: forall (m :: * -> *) a. Monad m => Cmd (m a) -> m (Cmd a)
sequence :: forall (m :: * -> *) a. Monad m => Cmd (m a) -> m (Cmd a)
Traversable)
data Success ss =
Unit ()
| MaybeErr (Either (ExtValidationError TestBlock) ())
| Ledger (ExtLedgerState TestBlock)
| Snapped (Maybe (ss, RealPoint TestBlock))
| Restored (MockInitLog ss, ExtLedgerState TestBlock)
deriving (Int -> Success ss -> ShowS
[Success ss] -> ShowS
Success ss -> TestName
(Int -> Success ss -> ShowS)
-> (Success ss -> TestName)
-> ([Success ss] -> ShowS)
-> Show (Success ss)
forall ss. Show ss => Int -> Success ss -> ShowS
forall ss. Show ss => [Success ss] -> ShowS
forall ss. Show ss => Success ss -> TestName
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ss. Show ss => Int -> Success ss -> ShowS
showsPrec :: Int -> Success ss -> ShowS
$cshow :: forall ss. Show ss => Success ss -> TestName
show :: Success ss -> TestName
$cshowList :: forall ss. Show ss => [Success ss] -> ShowS
showList :: [Success ss] -> ShowS
Show, Success ss -> Success ss -> Bool
(Success ss -> Success ss -> Bool)
-> (Success ss -> Success ss -> Bool) -> Eq (Success ss)
forall ss. Eq ss => Success ss -> Success ss -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall ss. Eq ss => Success ss -> Success ss -> Bool
== :: Success ss -> Success ss -> Bool
$c/= :: forall ss. Eq ss => Success ss -> Success ss -> Bool
/= :: Success ss -> Success ss -> Bool
Eq, (forall a b. (a -> b) -> Success a -> Success b)
-> (forall a b. a -> Success b -> Success a) -> Functor Success
forall a b. a -> Success b -> Success a
forall a b. (a -> b) -> Success a -> Success b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Success a -> Success b
fmap :: forall a b. (a -> b) -> Success a -> Success b
$c<$ :: forall a b. a -> Success b -> Success a
<$ :: forall a b. a -> Success b -> Success a
Functor, (forall m. Monoid m => Success m -> m)
-> (forall m a. Monoid m => (a -> m) -> Success a -> m)
-> (forall m a. Monoid m => (a -> m) -> Success a -> m)
-> (forall a b. (a -> b -> b) -> b -> Success a -> b)
-> (forall a b. (a -> b -> b) -> b -> Success a -> b)
-> (forall b a. (b -> a -> b) -> b -> Success a -> b)
-> (forall b a. (b -> a -> b) -> b -> Success a -> b)
-> (forall a. (a -> a -> a) -> Success a -> a)
-> (forall a. (a -> a -> a) -> Success a -> a)
-> (forall a. Success a -> [a])
-> (forall a. Success a -> Bool)
-> (forall a. Success a -> Int)
-> (forall a. Eq a => a -> Success a -> Bool)
-> (forall a. Ord a => Success a -> a)
-> (forall a. Ord a => Success a -> a)
-> (forall a. Num a => Success a -> a)
-> (forall a. Num a => Success a -> a)
-> Foldable Success
forall a. Eq a => a -> Success a -> Bool
forall a. Num a => Success a -> a
forall a. Ord a => Success a -> a
forall m. Monoid m => Success m -> m
forall a. Success a -> Bool
forall a. Success a -> Int
forall a. Success a -> [a]
forall a. (a -> a -> a) -> Success a -> a
forall m a. Monoid m => (a -> m) -> Success a -> m
forall b a. (b -> a -> b) -> b -> Success a -> b
forall a b. (a -> b -> b) -> b -> Success a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Success m -> m
fold :: forall m. Monoid m => Success m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Success a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Success a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Success a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Success a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Success a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Success a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Success a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Success a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Success a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Success a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Success a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Success a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Success a -> a
foldr1 :: forall a. (a -> a -> a) -> Success a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Success a -> a
foldl1 :: forall a. (a -> a -> a) -> Success a -> a
$ctoList :: forall a. Success a -> [a]
toList :: forall a. Success a -> [a]
$cnull :: forall a. Success a -> Bool
null :: forall a. Success a -> Bool
$clength :: forall a. Success a -> Int
length :: forall a. Success a -> Int
$celem :: forall a. Eq a => a -> Success a -> Bool
elem :: forall a. Eq a => a -> Success a -> Bool
$cmaximum :: forall a. Ord a => Success a -> a
maximum :: forall a. Ord a => Success a -> a
$cminimum :: forall a. Ord a => Success a -> a
minimum :: forall a. Ord a => Success a -> a
$csum :: forall a. Num a => Success a -> a
sum :: forall a. Num a => Success a -> a
$cproduct :: forall a. Num a => Success a -> a
product :: forall a. Num a => Success a -> a
Foldable, Functor Success
Foldable Success
(Functor Success, Foldable Success) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Success a -> f (Success b))
-> (forall (f :: * -> *) a.
Applicative f =>
Success (f a) -> f (Success a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Success a -> m (Success b))
-> (forall (m :: * -> *) a.
Monad m =>
Success (m a) -> m (Success a))
-> Traversable Success
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Success (m a) -> m (Success a)
forall (f :: * -> *) a.
Applicative f =>
Success (f a) -> f (Success a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Success a -> m (Success b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Success a -> f (Success b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Success a -> f (Success b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Success a -> f (Success b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Success (f a) -> f (Success a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Success (f a) -> f (Success a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Success a -> m (Success b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Success a -> m (Success b)
$csequence :: forall (m :: * -> *) a. Monad m => Success (m a) -> m (Success a)
sequence :: forall (m :: * -> *) a. Monad m => Success (m a) -> m (Success a)
Traversable)
newtype Resp ss = Resp (Success ss)
deriving (Int -> Resp ss -> ShowS
[Resp ss] -> ShowS
Resp ss -> TestName
(Int -> Resp ss -> ShowS)
-> (Resp ss -> TestName) -> ([Resp ss] -> ShowS) -> Show (Resp ss)
forall ss. Show ss => Int -> Resp ss -> ShowS
forall ss. Show ss => [Resp ss] -> ShowS
forall ss. Show ss => Resp ss -> TestName
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ss. Show ss => Int -> Resp ss -> ShowS
showsPrec :: Int -> Resp ss -> ShowS
$cshow :: forall ss. Show ss => Resp ss -> TestName
show :: Resp ss -> TestName
$cshowList :: forall ss. Show ss => [Resp ss] -> ShowS
showList :: [Resp ss] -> ShowS
Show, Resp ss -> Resp ss -> Bool
(Resp ss -> Resp ss -> Bool)
-> (Resp ss -> Resp ss -> Bool) -> Eq (Resp ss)
forall ss. Eq ss => Resp ss -> Resp ss -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall ss. Eq ss => Resp ss -> Resp ss -> Bool
== :: Resp ss -> Resp ss -> Bool
$c/= :: forall ss. Eq ss => Resp ss -> Resp ss -> Bool
/= :: Resp ss -> Resp ss -> Bool
Eq, (forall a b. (a -> b) -> Resp a -> Resp b)
-> (forall a b. a -> Resp b -> Resp a) -> Functor Resp
forall a b. a -> Resp b -> Resp a
forall a b. (a -> b) -> Resp a -> Resp b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Resp a -> Resp b
fmap :: forall a b. (a -> b) -> Resp a -> Resp b
$c<$ :: forall a b. a -> Resp b -> Resp a
<$ :: forall a b. a -> Resp b -> Resp a
Functor, (forall m. Monoid m => Resp m -> m)
-> (forall m a. Monoid m => (a -> m) -> Resp a -> m)
-> (forall m a. Monoid m => (a -> m) -> Resp a -> m)
-> (forall a b. (a -> b -> b) -> b -> Resp a -> b)
-> (forall a b. (a -> b -> b) -> b -> Resp a -> b)
-> (forall b a. (b -> a -> b) -> b -> Resp a -> b)
-> (forall b a. (b -> a -> b) -> b -> Resp a -> b)
-> (forall a. (a -> a -> a) -> Resp a -> a)
-> (forall a. (a -> a -> a) -> Resp a -> a)
-> (forall a. Resp a -> [a])
-> (forall a. Resp a -> Bool)
-> (forall a. Resp a -> Int)
-> (forall a. Eq a => a -> Resp a -> Bool)
-> (forall a. Ord a => Resp a -> a)
-> (forall a. Ord a => Resp a -> a)
-> (forall a. Num a => Resp a -> a)
-> (forall a. Num a => Resp a -> a)
-> Foldable Resp
forall a. Eq a => a -> Resp a -> Bool
forall a. Num a => Resp a -> a
forall a. Ord a => Resp a -> a
forall m. Monoid m => Resp m -> m
forall a. Resp a -> Bool
forall a. Resp a -> Int
forall a. Resp a -> [a]
forall a. (a -> a -> a) -> Resp a -> a
forall m a. Monoid m => (a -> m) -> Resp a -> m
forall b a. (b -> a -> b) -> b -> Resp a -> b
forall a b. (a -> b -> b) -> b -> Resp a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Resp m -> m
fold :: forall m. Monoid m => Resp m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Resp a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Resp a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Resp a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Resp a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Resp a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Resp a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Resp a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Resp a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Resp a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Resp a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Resp a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Resp a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Resp a -> a
foldr1 :: forall a. (a -> a -> a) -> Resp a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Resp a -> a
foldl1 :: forall a. (a -> a -> a) -> Resp a -> a
$ctoList :: forall a. Resp a -> [a]
toList :: forall a. Resp a -> [a]
$cnull :: forall a. Resp a -> Bool
null :: forall a. Resp a -> Bool
$clength :: forall a. Resp a -> Int
length :: forall a. Resp a -> Int
$celem :: forall a. Eq a => a -> Resp a -> Bool
elem :: forall a. Eq a => a -> Resp a -> Bool
$cmaximum :: forall a. Ord a => Resp a -> a
maximum :: forall a. Ord a => Resp a -> a
$cminimum :: forall a. Ord a => Resp a -> a
minimum :: forall a. Ord a => Resp a -> a
$csum :: forall a. Num a => Resp a -> a
sum :: forall a. Num a => Resp a -> a
$cproduct :: forall a. Num a => Resp a -> a
product :: forall a. Num a => Resp a -> a
Foldable, Functor Resp
Foldable Resp
(Functor Resp, Foldable Resp) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp a -> f (Resp b))
-> (forall (f :: * -> *) a.
Applicative f =>
Resp (f a) -> f (Resp a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Resp a -> m (Resp b))
-> (forall (m :: * -> *) a. Monad m => Resp (m a) -> m (Resp a))
-> Traversable Resp
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Resp (m a) -> m (Resp a)
forall (f :: * -> *) a. Applicative f => Resp (f a) -> f (Resp a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Resp a -> m (Resp b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp a -> f (Resp b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp a -> f (Resp b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp a -> f (Resp b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Resp (f a) -> f (Resp a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Resp (f a) -> f (Resp a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Resp a -> m (Resp b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Resp a -> m (Resp b)
$csequence :: forall (m :: * -> *) a. Monad m => Resp (m a) -> m (Resp a)
sequence :: forall (m :: * -> *) a. Monad m => Resp (m a) -> m (Resp a)
Traversable)
type MockLedger = [(TestBlock, ExtLedgerState TestBlock)]
newtype MockSnap = MockSnap Word64
deriving stock (Int -> MockSnap -> ShowS
[MockSnap] -> ShowS
MockSnap -> TestName
(Int -> MockSnap -> ShowS)
-> (MockSnap -> TestName) -> ([MockSnap] -> ShowS) -> Show MockSnap
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockSnap -> ShowS
showsPrec :: Int -> MockSnap -> ShowS
$cshow :: MockSnap -> TestName
show :: MockSnap -> TestName
$cshowList :: [MockSnap] -> ShowS
showList :: [MockSnap] -> ShowS
Show, MockSnap -> MockSnap -> Bool
(MockSnap -> MockSnap -> Bool)
-> (MockSnap -> MockSnap -> Bool) -> Eq MockSnap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MockSnap -> MockSnap -> Bool
== :: MockSnap -> MockSnap -> Bool
$c/= :: MockSnap -> MockSnap -> Bool
/= :: MockSnap -> MockSnap -> Bool
Eq, Eq MockSnap
Eq MockSnap =>
(MockSnap -> MockSnap -> Ordering)
-> (MockSnap -> MockSnap -> Bool)
-> (MockSnap -> MockSnap -> Bool)
-> (MockSnap -> MockSnap -> Bool)
-> (MockSnap -> MockSnap -> Bool)
-> (MockSnap -> MockSnap -> MockSnap)
-> (MockSnap -> MockSnap -> MockSnap)
-> Ord MockSnap
MockSnap -> MockSnap -> Bool
MockSnap -> MockSnap -> Ordering
MockSnap -> MockSnap -> MockSnap
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 :: MockSnap -> MockSnap -> Ordering
compare :: MockSnap -> MockSnap -> Ordering
$c< :: MockSnap -> MockSnap -> Bool
< :: MockSnap -> MockSnap -> Bool
$c<= :: MockSnap -> MockSnap -> Bool
<= :: MockSnap -> MockSnap -> Bool
$c> :: MockSnap -> MockSnap -> Bool
> :: MockSnap -> MockSnap -> Bool
$c>= :: MockSnap -> MockSnap -> Bool
>= :: MockSnap -> MockSnap -> Bool
$cmax :: MockSnap -> MockSnap -> MockSnap
max :: MockSnap -> MockSnap -> MockSnap
$cmin :: MockSnap -> MockSnap -> MockSnap
min :: MockSnap -> MockSnap -> MockSnap
Ord, (forall x. MockSnap -> Rep MockSnap x)
-> (forall x. Rep MockSnap x -> MockSnap) -> Generic MockSnap
forall x. Rep MockSnap x -> MockSnap
forall x. MockSnap -> Rep MockSnap x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MockSnap -> Rep MockSnap x
from :: forall x. MockSnap -> Rep MockSnap x
$cto :: forall x. Rep MockSnap x -> MockSnap
to :: forall x. Rep MockSnap x -> MockSnap
Generic)
deriving newtype ([MockSnap] -> Expr
MockSnap -> Expr
(MockSnap -> Expr) -> ([MockSnap] -> Expr) -> ToExpr MockSnap
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: MockSnap -> Expr
toExpr :: MockSnap -> Expr
$clistToExpr :: [MockSnap] -> Expr
listToExpr :: [MockSnap] -> Expr
ToExpr)
type MockSnaps = Map MockSnap (RealPoint TestBlock, SnapState)
data Mock = Mock {
Mock -> MockLedger
mockLedger :: MockLedger
, Mock -> MockSnaps
mockSnaps :: MockSnaps
, Mock -> Point TestBlock
mockRestore :: Point TestBlock
, Mock -> SecurityParam
mockSecParam :: SecurityParam
}
deriving (Int -> Mock -> ShowS
[Mock] -> ShowS
Mock -> TestName
(Int -> Mock -> ShowS)
-> (Mock -> TestName) -> ([Mock] -> ShowS) -> Show Mock
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mock -> ShowS
showsPrec :: Int -> Mock -> ShowS
$cshow :: Mock -> TestName
show :: Mock -> TestName
$cshowList :: [Mock] -> ShowS
showList :: [Mock] -> ShowS
Show, (forall x. Mock -> Rep Mock x)
-> (forall x. Rep Mock x -> Mock) -> Generic Mock
forall x. Rep Mock x -> Mock
forall x. Mock -> Rep Mock x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Mock -> Rep Mock x
from :: forall x. Mock -> Rep Mock x
$cto :: forall x. Rep Mock x -> Mock
to :: forall x. Rep Mock x -> Mock
Generic, [Mock] -> Expr
Mock -> Expr
(Mock -> Expr) -> ([Mock] -> Expr) -> ToExpr Mock
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: Mock -> Expr
toExpr :: Mock -> Expr
$clistToExpr :: [Mock] -> Expr
listToExpr :: [Mock] -> Expr
ToExpr)
data SnapState = SnapOk | SnapCorrupted
deriving (Int -> SnapState -> ShowS
[SnapState] -> ShowS
SnapState -> TestName
(Int -> SnapState -> ShowS)
-> (SnapState -> TestName)
-> ([SnapState] -> ShowS)
-> Show SnapState
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapState -> ShowS
showsPrec :: Int -> SnapState -> ShowS
$cshow :: SnapState -> TestName
show :: SnapState -> TestName
$cshowList :: [SnapState] -> ShowS
showList :: [SnapState] -> ShowS
Show, SnapState -> SnapState -> Bool
(SnapState -> SnapState -> Bool)
-> (SnapState -> SnapState -> Bool) -> Eq SnapState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapState -> SnapState -> Bool
== :: SnapState -> SnapState -> Bool
$c/= :: SnapState -> SnapState -> Bool
/= :: SnapState -> SnapState -> Bool
Eq, (forall x. SnapState -> Rep SnapState x)
-> (forall x. Rep SnapState x -> SnapState) -> Generic SnapState
forall x. Rep SnapState x -> SnapState
forall x. SnapState -> Rep SnapState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SnapState -> Rep SnapState x
from :: forall x. SnapState -> Rep SnapState x
$cto :: forall x. Rep SnapState x -> SnapState
to :: forall x. Rep SnapState x -> SnapState
Generic, [SnapState] -> Expr
SnapState -> Expr
(SnapState -> Expr) -> ([SnapState] -> Expr) -> ToExpr SnapState
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
$ctoExpr :: SnapState -> Expr
toExpr :: SnapState -> Expr
$clistToExpr :: [SnapState] -> Expr
listToExpr :: [SnapState] -> Expr
ToExpr)
mockInit :: SecurityParam -> Mock
mockInit :: SecurityParam -> Mock
mockInit = MockLedger -> MockSnaps -> Point TestBlock -> SecurityParam -> Mock
Mock [] MockSnaps
forall k a. Map k a
Map.empty Point TestBlock
forall {k} (block :: k). Point block
GenesisPoint
mockCurrent :: Mock -> ExtLedgerState TestBlock
mockCurrent :: Mock -> ExtLedgerState TestBlock
mockCurrent Mock{MockLedger
MockSnaps
Point TestBlock
SecurityParam
mockLedger :: Mock -> MockLedger
mockSnaps :: Mock -> MockSnaps
mockRestore :: Mock -> Point TestBlock
mockSecParam :: Mock -> SecurityParam
mockLedger :: MockLedger
mockSnaps :: MockSnaps
mockRestore :: Point TestBlock
mockSecParam :: SecurityParam
..} =
case MockLedger
mockLedger of
[] -> PayloadDependentState Tx -> ExtLedgerState TestBlock
forall ptype.
PayloadDependentState ptype -> ExtLedgerState (TestBlockWith ptype)
testInitExtLedgerWithState PayloadDependentState Tx
UTxTok
initialTestLedgerState
(TestBlock
_, ExtLedgerState TestBlock
l):MockLedger
_ -> ExtLedgerState TestBlock
l
mockChainLength :: Mock -> Word64
mockChainLength :: Mock -> Word64
mockChainLength Mock{MockLedger
MockSnaps
Point TestBlock
SecurityParam
mockLedger :: Mock -> MockLedger
mockSnaps :: Mock -> MockSnaps
mockRestore :: Mock -> Point TestBlock
mockSecParam :: Mock -> SecurityParam
mockLedger :: MockLedger
mockSnaps :: MockSnaps
mockRestore :: Point TestBlock
mockSecParam :: SecurityParam
..} = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (MockLedger -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length MockLedger
mockLedger)
mockRollback :: Word64 -> Mock -> Mock
mockRollback :: Word64 -> Mock -> Mock
mockRollback Word64
n mock :: Mock
mock@Mock{MockLedger
MockSnaps
Point TestBlock
SecurityParam
mockLedger :: Mock -> MockLedger
mockSnaps :: Mock -> MockSnaps
mockRestore :: Mock -> Point TestBlock
mockSecParam :: Mock -> SecurityParam
mockLedger :: MockLedger
mockSnaps :: MockSnaps
mockRestore :: Point TestBlock
mockSecParam :: SecurityParam
..} = Mock
mock {
mockLedger = drop (fromIntegral n) mockLedger
}
mockUpdateLedger :: StateT MockLedger (Except (ExtValidationError TestBlock)) a
-> Mock -> (Either (ExtValidationError TestBlock) a, Mock)
mockUpdateLedger :: forall a.
StateT MockLedger (Except (ExtValidationError TestBlock)) a
-> Mock -> (Either (ExtValidationError TestBlock) a, Mock)
mockUpdateLedger StateT MockLedger (Except (ExtValidationError TestBlock)) a
f Mock
mock =
case Except (ExtValidationError TestBlock) (a, MockLedger)
-> Either (ExtValidationError TestBlock) (a, MockLedger)
forall e a. Except e a -> Either e a
runExcept (StateT MockLedger (Except (ExtValidationError TestBlock)) a
-> MockLedger
-> Except (ExtValidationError TestBlock) (a, MockLedger)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT MockLedger (Except (ExtValidationError TestBlock)) a
f (Mock -> MockLedger
mockLedger Mock
mock)) of
Left ExtValidationError TestBlock
err -> (ExtValidationError TestBlock
-> Either (ExtValidationError TestBlock) a
forall a b. a -> Either a b
Left ExtValidationError TestBlock
err, Mock
mock)
Right (a
a, MockLedger
ledger') -> (a -> Either (ExtValidationError TestBlock) a
forall a b. b -> Either a b
Right a
a, Mock
mock { mockLedger = ledger' })
mockRecentSnap :: Mock -> Maybe SnapState
mockRecentSnap :: Mock -> Maybe SnapState
mockRecentSnap Mock{MockLedger
MockSnaps
Point TestBlock
SecurityParam
mockLedger :: Mock -> MockLedger
mockSnaps :: Mock -> MockSnaps
mockRestore :: Mock -> Point TestBlock
mockSecParam :: Mock -> SecurityParam
mockLedger :: MockLedger
mockSnaps :: MockSnaps
mockRestore :: Point TestBlock
mockSecParam :: SecurityParam
..} = (RealPoint TestBlock, SnapState) -> SnapState
forall a b. (a, b) -> b
snd ((RealPoint TestBlock, SnapState) -> SnapState)
-> ((MockSnap, (RealPoint TestBlock, SnapState))
-> (RealPoint TestBlock, SnapState))
-> (MockSnap, (RealPoint TestBlock, SnapState))
-> SnapState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MockSnap, (RealPoint TestBlock, SnapState))
-> (RealPoint TestBlock, SnapState)
forall a b. (a, b) -> b
snd ((MockSnap, (RealPoint TestBlock, SnapState)) -> SnapState)
-> Maybe (MockSnap, (RealPoint TestBlock, SnapState))
-> Maybe SnapState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockSnaps -> Maybe (MockSnap, (RealPoint TestBlock, SnapState))
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax MockSnaps
mockSnaps
data MockInitLog ss =
MockFromGenesis
| MockFromSnapshot ss (RealPoint TestBlock)
| MockReadFailure ss (MockInitLog ss)
| MockTooRecent ss (RealPoint TestBlock) (MockInitLog ss)
| MockGenesisSnapshot ss (MockInitLog ss)
deriving (Int -> MockInitLog ss -> ShowS
[MockInitLog ss] -> ShowS
MockInitLog ss -> TestName
(Int -> MockInitLog ss -> ShowS)
-> (MockInitLog ss -> TestName)
-> ([MockInitLog ss] -> ShowS)
-> Show (MockInitLog ss)
forall ss. Show ss => Int -> MockInitLog ss -> ShowS
forall ss. Show ss => [MockInitLog ss] -> ShowS
forall ss. Show ss => MockInitLog ss -> TestName
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ss. Show ss => Int -> MockInitLog ss -> ShowS
showsPrec :: Int -> MockInitLog ss -> ShowS
$cshow :: forall ss. Show ss => MockInitLog ss -> TestName
show :: MockInitLog ss -> TestName
$cshowList :: forall ss. Show ss => [MockInitLog ss] -> ShowS
showList :: [MockInitLog ss] -> ShowS
Show, MockInitLog ss -> MockInitLog ss -> Bool
(MockInitLog ss -> MockInitLog ss -> Bool)
-> (MockInitLog ss -> MockInitLog ss -> Bool)
-> Eq (MockInitLog ss)
forall ss. Eq ss => MockInitLog ss -> MockInitLog ss -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall ss. Eq ss => MockInitLog ss -> MockInitLog ss -> Bool
== :: MockInitLog ss -> MockInitLog ss -> Bool
$c/= :: forall ss. Eq ss => MockInitLog ss -> MockInitLog ss -> Bool
/= :: MockInitLog ss -> MockInitLog ss -> Bool
Eq, (forall a b. (a -> b) -> MockInitLog a -> MockInitLog b)
-> (forall a b. a -> MockInitLog b -> MockInitLog a)
-> Functor MockInitLog
forall a b. a -> MockInitLog b -> MockInitLog a
forall a b. (a -> b) -> MockInitLog a -> MockInitLog b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> MockInitLog a -> MockInitLog b
fmap :: forall a b. (a -> b) -> MockInitLog a -> MockInitLog b
$c<$ :: forall a b. a -> MockInitLog b -> MockInitLog a
<$ :: forall a b. a -> MockInitLog b -> MockInitLog a
Functor, (forall m. Monoid m => MockInitLog m -> m)
-> (forall m a. Monoid m => (a -> m) -> MockInitLog a -> m)
-> (forall m a. Monoid m => (a -> m) -> MockInitLog a -> m)
-> (forall a b. (a -> b -> b) -> b -> MockInitLog a -> b)
-> (forall a b. (a -> b -> b) -> b -> MockInitLog a -> b)
-> (forall b a. (b -> a -> b) -> b -> MockInitLog a -> b)
-> (forall b a. (b -> a -> b) -> b -> MockInitLog a -> b)
-> (forall a. (a -> a -> a) -> MockInitLog a -> a)
-> (forall a. (a -> a -> a) -> MockInitLog a -> a)
-> (forall a. MockInitLog a -> [a])
-> (forall a. MockInitLog a -> Bool)
-> (forall a. MockInitLog a -> Int)
-> (forall a. Eq a => a -> MockInitLog a -> Bool)
-> (forall a. Ord a => MockInitLog a -> a)
-> (forall a. Ord a => MockInitLog a -> a)
-> (forall a. Num a => MockInitLog a -> a)
-> (forall a. Num a => MockInitLog a -> a)
-> Foldable MockInitLog
forall a. Eq a => a -> MockInitLog a -> Bool
forall a. Num a => MockInitLog a -> a
forall a. Ord a => MockInitLog a -> a
forall m. Monoid m => MockInitLog m -> m
forall a. MockInitLog a -> Bool
forall a. MockInitLog a -> Int
forall a. MockInitLog a -> [a]
forall a. (a -> a -> a) -> MockInitLog a -> a
forall m a. Monoid m => (a -> m) -> MockInitLog a -> m
forall b a. (b -> a -> b) -> b -> MockInitLog a -> b
forall a b. (a -> b -> b) -> b -> MockInitLog a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => MockInitLog m -> m
fold :: forall m. Monoid m => MockInitLog m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> MockInitLog a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> MockInitLog a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> MockInitLog a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> MockInitLog a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> MockInitLog a -> b
foldr :: forall a b. (a -> b -> b) -> b -> MockInitLog a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> MockInitLog a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> MockInitLog a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> MockInitLog a -> b
foldl :: forall b a. (b -> a -> b) -> b -> MockInitLog a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> MockInitLog a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> MockInitLog a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> MockInitLog a -> a
foldr1 :: forall a. (a -> a -> a) -> MockInitLog a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> MockInitLog a -> a
foldl1 :: forall a. (a -> a -> a) -> MockInitLog a -> a
$ctoList :: forall a. MockInitLog a -> [a]
toList :: forall a. MockInitLog a -> [a]
$cnull :: forall a. MockInitLog a -> Bool
null :: forall a. MockInitLog a -> Bool
$clength :: forall a. MockInitLog a -> Int
length :: forall a. MockInitLog a -> Int
$celem :: forall a. Eq a => a -> MockInitLog a -> Bool
elem :: forall a. Eq a => a -> MockInitLog a -> Bool
$cmaximum :: forall a. Ord a => MockInitLog a -> a
maximum :: forall a. Ord a => MockInitLog a -> a
$cminimum :: forall a. Ord a => MockInitLog a -> a
minimum :: forall a. Ord a => MockInitLog a -> a
$csum :: forall a. Num a => MockInitLog a -> a
sum :: forall a. Num a => MockInitLog a -> a
$cproduct :: forall a. Num a => MockInitLog a -> a
product :: forall a. Num a => MockInitLog a -> a
Foldable, Functor MockInitLog
Foldable MockInitLog
(Functor MockInitLog, Foldable MockInitLog) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MockInitLog a -> f (MockInitLog b))
-> (forall (f :: * -> *) a.
Applicative f =>
MockInitLog (f a) -> f (MockInitLog a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MockInitLog a -> m (MockInitLog b))
-> (forall (m :: * -> *) a.
Monad m =>
MockInitLog (m a) -> m (MockInitLog a))
-> Traversable MockInitLog
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
MockInitLog (m a) -> m (MockInitLog a)
forall (f :: * -> *) a.
Applicative f =>
MockInitLog (f a) -> f (MockInitLog a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MockInitLog a -> m (MockInitLog b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MockInitLog a -> f (MockInitLog b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MockInitLog a -> f (MockInitLog b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MockInitLog a -> f (MockInitLog b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
MockInitLog (f a) -> f (MockInitLog a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
MockInitLog (f a) -> f (MockInitLog a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MockInitLog a -> m (MockInitLog b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MockInitLog a -> m (MockInitLog b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
MockInitLog (m a) -> m (MockInitLog a)
sequence :: forall (m :: * -> *) a.
Monad m =>
MockInitLog (m a) -> m (MockInitLog a)
Traversable)
fromInitLog :: InitLog TestBlock -> MockInitLog DiskSnapshot
fromInitLog :: InitLog TestBlock -> MockInitLog DiskSnapshot
fromInitLog InitLog TestBlock
InitFromGenesis = MockInitLog DiskSnapshot
forall ss. MockInitLog ss
MockFromGenesis
fromInitLog (InitFromSnapshot DiskSnapshot
ss RealPoint TestBlock
tip) = DiskSnapshot -> RealPoint TestBlock -> MockInitLog DiskSnapshot
forall ss. ss -> RealPoint TestBlock -> MockInitLog ss
MockFromSnapshot DiskSnapshot
ss RealPoint TestBlock
tip
fromInitLog (InitFailure DiskSnapshot
ss SnapshotFailure TestBlock
err InitLog TestBlock
log') =
case SnapshotFailure TestBlock
err of
InitFailureRead ReadIncrementalErr
_err -> DiskSnapshot
-> MockInitLog DiskSnapshot -> MockInitLog DiskSnapshot
forall ss. ss -> MockInitLog ss -> MockInitLog ss
MockReadFailure DiskSnapshot
ss (InitLog TestBlock -> MockInitLog DiskSnapshot
fromInitLog InitLog TestBlock
log')
InitFailureTooRecent RealPoint TestBlock
tip -> DiskSnapshot
-> RealPoint TestBlock
-> MockInitLog DiskSnapshot
-> MockInitLog DiskSnapshot
forall ss.
ss -> RealPoint TestBlock -> MockInitLog ss -> MockInitLog ss
MockTooRecent DiskSnapshot
ss RealPoint TestBlock
tip (InitLog TestBlock -> MockInitLog DiskSnapshot
fromInitLog InitLog TestBlock
log')
SnapshotFailure TestBlock
InitFailureGenesis -> DiskSnapshot
-> MockInitLog DiskSnapshot -> MockInitLog DiskSnapshot
forall ss. ss -> MockInitLog ss -> MockInitLog ss
MockGenesisSnapshot DiskSnapshot
ss (InitLog TestBlock -> MockInitLog DiskSnapshot
fromInitLog InitLog TestBlock
log')
mockInitLog :: Mock -> MockInitLog MockSnap
mockInitLog :: Mock -> MockInitLog MockSnap
mockInitLog Mock{MockLedger
MockSnaps
Point TestBlock
SecurityParam
mockLedger :: Mock -> MockLedger
mockSnaps :: Mock -> MockSnaps
mockRestore :: Mock -> Point TestBlock
mockSecParam :: Mock -> SecurityParam
mockLedger :: MockLedger
mockSnaps :: MockSnaps
mockRestore :: Point TestBlock
mockSecParam :: SecurityParam
..} = [(MockSnap, (RealPoint TestBlock, SnapState))]
-> MockInitLog MockSnap
go (MockSnaps -> [(MockSnap, (RealPoint TestBlock, SnapState))]
forall k a. Map k a -> [(k, a)]
Map.toDescList MockSnaps
mockSnaps)
where
go :: [(MockSnap, (RealPoint TestBlock, SnapState))] -> MockInitLog MockSnap
go :: [(MockSnap, (RealPoint TestBlock, SnapState))]
-> MockInitLog MockSnap
go [] = MockInitLog MockSnap
forall ss. MockInitLog ss
MockFromGenesis
go ((MockSnap
snap, (RealPoint TestBlock
pt, SnapState
state)):[(MockSnap, (RealPoint TestBlock, SnapState))]
snaps) =
case SnapState
state of
SnapState
SnapCorrupted ->
MockSnap -> MockInitLog MockSnap -> MockInitLog MockSnap
forall ss. ss -> MockInitLog ss -> MockInitLog ss
MockReadFailure MockSnap
snap (MockInitLog MockSnap -> MockInitLog MockSnap)
-> MockInitLog MockSnap -> MockInitLog MockSnap
forall a b. (a -> b) -> a -> b
$ [(MockSnap, (RealPoint TestBlock, SnapState))]
-> MockInitLog MockSnap
go [(MockSnap, (RealPoint TestBlock, SnapState))]
snaps
SnapState
SnapOk ->
if RealPoint TestBlock -> Bool
onChain RealPoint TestBlock
pt
then MockSnap -> RealPoint TestBlock -> MockInitLog MockSnap
forall ss. ss -> RealPoint TestBlock -> MockInitLog ss
MockFromSnapshot MockSnap
snap RealPoint TestBlock
pt
else MockSnap
-> RealPoint TestBlock
-> MockInitLog MockSnap
-> MockInitLog MockSnap
forall ss.
ss -> RealPoint TestBlock -> MockInitLog ss -> MockInitLog ss
MockTooRecent MockSnap
snap RealPoint TestBlock
pt (MockInitLog MockSnap -> MockInitLog MockSnap)
-> MockInitLog MockSnap -> MockInitLog MockSnap
forall a b. (a -> b) -> a -> b
$ [(MockSnap, (RealPoint TestBlock, SnapState))]
-> MockInitLog MockSnap
go [(MockSnap, (RealPoint TestBlock, SnapState))]
snaps
onChain :: RealPoint TestBlock -> Bool
onChain :: RealPoint TestBlock -> Bool
onChain RealPoint TestBlock
pt = ((TestBlock, ExtLedgerState TestBlock) -> Bool)
-> MockLedger -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(TestBlock
b, ExtLedgerState TestBlock
_) -> TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b RealPoint TestBlock -> RealPoint TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
== RealPoint TestBlock
pt) MockLedger
mockLedger
applyMockLog :: MockInitLog MockSnap -> Mock -> Mock
applyMockLog :: MockInitLog MockSnap -> Mock -> Mock
applyMockLog = MockInitLog MockSnap -> Mock -> Mock
go
where
go :: MockInitLog MockSnap -> Mock -> Mock
go :: MockInitLog MockSnap -> Mock -> Mock
go MockInitLog MockSnap
MockFromGenesis Mock
mock = Mock
mock { mockRestore = GenesisPoint }
go (MockFromSnapshot MockSnap
_ RealPoint TestBlock
tip) Mock
mock = Mock
mock { mockRestore = realPointToPoint tip }
go (MockReadFailure MockSnap
ss MockInitLog MockSnap
log') Mock
mock = MockInitLog MockSnap -> Mock -> Mock
go MockInitLog MockSnap
log' (Mock -> Mock) -> Mock -> Mock
forall a b. (a -> b) -> a -> b
$ MockSnap -> Mock -> Mock
deleteSnap MockSnap
ss Mock
mock
go (MockTooRecent MockSnap
ss RealPoint TestBlock
_ MockInitLog MockSnap
log') Mock
mock = MockInitLog MockSnap -> Mock -> Mock
go MockInitLog MockSnap
log' (Mock -> Mock) -> Mock -> Mock
forall a b. (a -> b) -> a -> b
$ MockSnap -> Mock -> Mock
deleteSnap MockSnap
ss Mock
mock
go (MockGenesisSnapshot MockSnap
ss MockInitLog MockSnap
log') Mock
mock = MockInitLog MockSnap -> Mock -> Mock
go MockInitLog MockSnap
log' (Mock -> Mock) -> Mock -> Mock
forall a b. (a -> b) -> a -> b
$ MockSnap -> Mock -> Mock
deleteSnap MockSnap
ss Mock
mock
deleteSnap :: MockSnap -> Mock -> Mock
deleteSnap :: MockSnap -> Mock -> Mock
deleteSnap MockSnap
ss Mock
mock = Mock
mock {
mockSnaps = Map.alter delete ss (mockSnaps mock)
}
delete :: Maybe (RealPoint TestBlock, SnapState)
-> Maybe (RealPoint TestBlock, SnapState)
delete :: Maybe (RealPoint TestBlock, SnapState)
-> Maybe (RealPoint TestBlock, SnapState)
delete Maybe (RealPoint TestBlock, SnapState)
Nothing = TestName -> Maybe (RealPoint TestBlock, SnapState)
forall a. HasCallStack => TestName -> a
error TestName
"setIsDeleted: impossible"
delete (Just (RealPoint TestBlock, SnapState)
_) = Maybe (RealPoint TestBlock, SnapState)
forall a. Maybe a
Nothing
mockMaxRollback :: Mock -> Word64
mockMaxRollback :: Mock -> Word64
mockMaxRollback Mock{MockLedger
MockSnaps
Point TestBlock
SecurityParam
mockLedger :: Mock -> MockLedger
mockSnaps :: Mock -> MockSnaps
mockRestore :: Mock -> Point TestBlock
mockSecParam :: Mock -> SecurityParam
mockLedger :: MockLedger
mockSnaps :: MockSnaps
mockRestore :: Point TestBlock
mockSecParam :: SecurityParam
..} = MockLedger -> Word64
go MockLedger
mockLedger
where
go :: MockLedger -> Word64
go :: MockLedger -> Word64
go ((TestBlock
b, ExtLedgerState TestBlock
_l):MockLedger
bs)
| TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint TestBlock
b Point TestBlock -> Point TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
== Point TestBlock
mockRestore = Word64
0
| Bool
otherwise = Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ MockLedger -> Word64
go MockLedger
bs
go [] = Word64
0
runMock :: Cmd MockSnap -> Mock -> (Resp MockSnap, Mock)
runMock :: Cmd MockSnap -> Mock -> (Resp MockSnap, Mock)
runMock Cmd MockSnap
cmd Mock
initMock =
(Success MockSnap -> Resp MockSnap)
-> (Success MockSnap, Mock) -> (Resp MockSnap, Mock)
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 Success MockSnap -> Resp MockSnap
forall ss. Success ss -> Resp ss
Resp ((Success MockSnap, Mock) -> (Resp MockSnap, Mock))
-> (Success MockSnap, Mock) -> (Resp MockSnap, Mock)
forall a b. (a -> b) -> a -> b
$ Cmd MockSnap -> Mock -> (Success MockSnap, Mock)
go Cmd MockSnap
cmd Mock
initMock
where
cfg :: LedgerDbCfg (ExtLedgerState TestBlock)
cfg :: LedgerDbCfg (ExtLedgerState TestBlock)
cfg = SecurityParam -> LedgerDbCfg (ExtLedgerState TestBlock)
extLedgerDbConfig (Mock -> SecurityParam
mockSecParam Mock
initMock)
go :: Cmd MockSnap -> Mock -> (Success MockSnap, Mock)
go :: Cmd MockSnap -> Mock -> (Success MockSnap, Mock)
go Cmd MockSnap
Current Mock
mock = (ExtLedgerState TestBlock -> Success MockSnap
forall ss. ExtLedgerState TestBlock -> Success ss
Ledger (MockLedger -> ExtLedgerState TestBlock
cur (Mock -> MockLedger
mockLedger Mock
mock)), Mock
mock)
go (Push TestBlock
b) Mock
mock = (Either (ExtValidationError TestBlock) () -> Success MockSnap)
-> (Either (ExtValidationError TestBlock) (), Mock)
-> (Success MockSnap, Mock)
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 Either (ExtValidationError TestBlock) () -> Success MockSnap
forall ss. Either (ExtValidationError TestBlock) () -> Success ss
MaybeErr ((Either (ExtValidationError TestBlock) (), Mock)
-> (Success MockSnap, Mock))
-> (Either (ExtValidationError TestBlock) (), Mock)
-> (Success MockSnap, Mock)
forall a b. (a -> b) -> a -> b
$ StateT MockLedger (Except (ExtValidationError TestBlock)) ()
-> Mock -> (Either (ExtValidationError TestBlock) (), Mock)
forall a.
StateT MockLedger (Except (ExtValidationError TestBlock)) a
-> Mock -> (Either (ExtValidationError TestBlock) a, Mock)
mockUpdateLedger (TestBlock
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
push TestBlock
b) Mock
mock
go (Switch Word64
n [TestBlock]
bs) Mock
mock = (Either (ExtValidationError TestBlock) () -> Success MockSnap)
-> (Either (ExtValidationError TestBlock) (), Mock)
-> (Success MockSnap, Mock)
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 Either (ExtValidationError TestBlock) () -> Success MockSnap
forall ss. Either (ExtValidationError TestBlock) () -> Success ss
MaybeErr ((Either (ExtValidationError TestBlock) (), Mock)
-> (Success MockSnap, Mock))
-> (Either (ExtValidationError TestBlock) (), Mock)
-> (Success MockSnap, Mock)
forall a b. (a -> b) -> a -> b
$ StateT MockLedger (Except (ExtValidationError TestBlock)) ()
-> Mock -> (Either (ExtValidationError TestBlock) (), Mock)
forall a.
StateT MockLedger (Except (ExtValidationError TestBlock)) a
-> Mock -> (Either (ExtValidationError TestBlock) a, Mock)
mockUpdateLedger (Word64
-> [TestBlock]
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
switch Word64
n [TestBlock]
bs) Mock
mock
go Cmd MockSnap
Restore Mock
mock = ((MockInitLog MockSnap, ExtLedgerState TestBlock)
-> Success MockSnap
forall ss. (MockInitLog ss, ExtLedgerState TestBlock) -> Success ss
Restored (MockInitLog MockSnap
initLog, MockLedger -> ExtLedgerState TestBlock
cur (Mock -> MockLedger
mockLedger Mock
mock')), Mock
mock')
where
initLog :: MockInitLog MockSnap
initLog = Mock -> MockInitLog MockSnap
mockInitLog Mock
mock
mock' :: Mock
mock' = MockInitLog MockSnap -> Mock -> Mock
applyMockLog MockInitLog MockSnap
initLog Mock
mock
go Cmd MockSnap
Snap Mock
mock = case Maybe (RealPoint TestBlock)
mbSnapshot of
Just RealPoint TestBlock
pt
| let mockSnap :: MockSnap
mockSnap = Word64 -> MockSnap
MockSnap (SlotNo -> Word64
unSlotNo (RealPoint TestBlock -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint TestBlock
pt))
, MockSnap -> MockSnaps -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.notMember MockSnap
mockSnap (Mock -> MockSnaps
mockSnaps Mock
mock)
-> ( Maybe (MockSnap, RealPoint TestBlock) -> Success MockSnap
forall ss. Maybe (ss, RealPoint TestBlock) -> Success ss
Snapped ((MockSnap, RealPoint TestBlock)
-> Maybe (MockSnap, RealPoint TestBlock)
forall a. a -> Maybe a
Just (MockSnap
mockSnap, RealPoint TestBlock
pt))
, Mock
mock {
mockSnaps =
Map.insert mockSnap (pt, SnapOk) (mockSnaps mock)
}
)
Maybe (RealPoint TestBlock)
_otherwise
-> (Maybe (MockSnap, RealPoint TestBlock) -> Success MockSnap
forall ss. Maybe (ss, RealPoint TestBlock) -> Success ss
Snapped Maybe (MockSnap, RealPoint TestBlock)
forall a. Maybe a
Nothing, Mock
mock)
where
mbSnapshot :: Maybe (RealPoint TestBlock)
mbSnapshot :: Maybe (RealPoint TestBlock)
mbSnapshot = case Int -> MockLedger -> MockLedger
forall a. Int -> [a] -> [a]
drop Int
k MockLedger
untilRestore of
(TestBlock
blk, ExtLedgerState TestBlock
_):MockLedger
_ -> RealPoint TestBlock -> Maybe (RealPoint TestBlock)
forall a. a -> Maybe a
Just (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
blk)
[] -> case Point TestBlock -> WithOrigin (RealPoint TestBlock)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint (Mock -> Point TestBlock
mockRestore Mock
mock) of
WithOrigin (RealPoint TestBlock)
Origin -> Maybe (RealPoint TestBlock)
forall a. Maybe a
Nothing
NotOrigin RealPoint TestBlock
pt -> RealPoint TestBlock -> Maybe (RealPoint TestBlock)
forall a. a -> Maybe a
Just RealPoint TestBlock
pt
where
k :: Int
k :: Int
k = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64
maxRollbacks (SecurityParam -> Word64) -> SecurityParam -> Word64
forall a b. (a -> b) -> a -> b
$ Mock -> SecurityParam
mockSecParam Mock
mock
untilRestore :: [(TestBlock, ExtLedgerState TestBlock)]
untilRestore :: MockLedger
untilRestore =
((TestBlock, ExtLedgerState TestBlock) -> Bool)
-> MockLedger -> MockLedger
forall a. (a -> Bool) -> [a] -> [a]
takeWhile
((Point TestBlock -> Point TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
/= (Mock -> Point TestBlock
mockRestore Mock
mock)) (Point TestBlock -> Bool)
-> ((TestBlock, ExtLedgerState TestBlock) -> Point TestBlock)
-> (TestBlock, ExtLedgerState TestBlock)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Point TestBlock
forall block. HasHeader block => block -> Point block
blockPoint (TestBlock -> Point TestBlock)
-> ((TestBlock, ExtLedgerState TestBlock) -> TestBlock)
-> (TestBlock, ExtLedgerState TestBlock)
-> Point TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestBlock, ExtLedgerState TestBlock) -> TestBlock
forall a b. (a, b) -> a
fst)
(Mock -> MockLedger
mockLedger Mock
mock)
go (Corrupt Corruption
c MockSnap
ss) Mock
mock = (
() -> Success MockSnap
forall ss. () -> Success ss
Unit ()
, Mock
mock { mockSnaps = Map.alter corrupt ss (mockSnaps mock) }
)
where
corrupt :: Maybe (RealPoint TestBlock, SnapState)
-> Maybe (RealPoint TestBlock, SnapState)
corrupt :: Maybe (RealPoint TestBlock, SnapState)
-> Maybe (RealPoint TestBlock, SnapState)
corrupt Maybe (RealPoint TestBlock, SnapState)
Nothing = TestName -> Maybe (RealPoint TestBlock, SnapState)
forall a. HasCallStack => TestName -> a
error TestName
"corrupt: impossible"
corrupt (Just (RealPoint TestBlock
ref, SnapState
_)) = case Corruption
c of
Corruption
Delete -> Maybe (RealPoint TestBlock, SnapState)
forall a. Maybe a
Nothing
Corruption
Truncate -> (RealPoint TestBlock, SnapState)
-> Maybe (RealPoint TestBlock, SnapState)
forall a. a -> Maybe a
Just (RealPoint TestBlock
ref, SnapState
SnapCorrupted)
go (Drop Word64
n) Mock
mock =
Cmd MockSnap -> Mock -> (Success MockSnap, Mock)
go Cmd MockSnap
forall ss. Cmd ss
Restore (Mock -> (Success MockSnap, Mock))
-> Mock -> (Success MockSnap, Mock)
forall a b. (a -> b) -> a -> b
$ Mock
mock {
mockLedger = drop (fromIntegral n) (mockLedger mock)
}
push :: TestBlock -> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
push :: TestBlock
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
push TestBlock
b = do
MockLedger
ls <- StateT
MockLedger (Except (ExtValidationError TestBlock)) MockLedger
forall s (m :: * -> *). MonadState s m => m s
State.get
ExtLedgerState TestBlock
l' <- Except (ExtValidationError TestBlock) (ExtLedgerState TestBlock)
-> StateT
MockLedger
(Except (ExtValidationError TestBlock))
(ExtLedgerState TestBlock)
forall (m :: * -> *) a. Monad m => m a -> StateT MockLedger m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
State.lift (Except (ExtValidationError TestBlock) (ExtLedgerState TestBlock)
-> StateT
MockLedger
(Except (ExtValidationError TestBlock))
(ExtLedgerState TestBlock))
-> Except (ExtValidationError TestBlock) (ExtLedgerState TestBlock)
-> StateT
MockLedger
(Except (ExtValidationError TestBlock))
(ExtLedgerState TestBlock)
forall a b. (a -> b) -> a -> b
$ LedgerCfg (ExtLedgerState TestBlock)
-> TestBlock
-> ExtLedgerState TestBlock
-> Except
(LedgerErr (ExtLedgerState TestBlock)) (ExtLedgerState TestBlock)
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply (LedgerDbCfg (ExtLedgerState TestBlock)
-> LedgerCfg (ExtLedgerState TestBlock)
forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg LedgerDbCfg (ExtLedgerState TestBlock)
cfg) TestBlock
b (MockLedger -> ExtLedgerState TestBlock
cur MockLedger
ls)
MockLedger
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put ((TestBlock
b, ExtLedgerState TestBlock
l')(TestBlock, ExtLedgerState TestBlock) -> MockLedger -> MockLedger
forall a. a -> [a] -> [a]
:MockLedger
ls)
switch :: Word64
-> [TestBlock]
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
switch :: Word64
-> [TestBlock]
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
switch Word64
n [TestBlock]
bs = do
(MockLedger -> MockLedger)
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((MockLedger -> MockLedger)
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ())
-> (MockLedger -> MockLedger)
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
forall a b. (a -> b) -> a -> b
$ Int -> MockLedger -> MockLedger
forall a. Int -> [a] -> [a]
drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
(TestBlock
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ())
-> [TestBlock]
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TestBlock
-> StateT MockLedger (Except (ExtValidationError TestBlock)) ()
push [TestBlock]
bs
cur :: MockLedger -> ExtLedgerState TestBlock
cur :: MockLedger -> ExtLedgerState TestBlock
cur [] = PayloadDependentState Tx -> ExtLedgerState TestBlock
forall ptype.
PayloadDependentState ptype -> ExtLedgerState (TestBlockWith ptype)
testInitExtLedgerWithState PayloadDependentState Tx
UTxTok
initialTestLedgerState
cur ((TestBlock
_, ExtLedgerState TestBlock
l):MockLedger
_) = ExtLedgerState TestBlock
l
data DbEnv m = DbEnv {
forall (m :: * -> *). DbEnv m -> SomeHasFS m
dbHasFS :: SomeHasFS m
, forall (m :: * -> *). DbEnv m -> SecurityParam
dbSecParam :: SecurityParam
}
data StandaloneDB m = DB {
forall (m :: * -> *). StandaloneDB m -> DbEnv m
dbEnv :: DbEnv m
, forall (m :: * -> *).
StandaloneDB m
-> StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbBlocks :: StrictTVar m (Map (RealPoint TestBlock) TestBlock)
, forall (m :: * -> *).
StandaloneDB m
-> StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState :: StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
, forall (m :: * -> *). StandaloneDB m -> ResolveBlock m TestBlock
dbResolve :: ResolveBlock m TestBlock
, forall (m :: * -> *).
StandaloneDB m -> LedgerDbCfg (ExtLedgerState TestBlock)
dbLedgerDbCfg :: LedgerDbCfg (ExtLedgerState TestBlock)
}
initStandaloneDB :: forall m. IOLike m => DbEnv m -> m (StandaloneDB m)
initStandaloneDB :: forall (m :: * -> *). IOLike m => DbEnv m -> m (StandaloneDB m)
initStandaloneDB dbEnv :: DbEnv m
dbEnv@DbEnv{SomeHasFS m
SecurityParam
dbHasFS :: forall (m :: * -> *). DbEnv m -> SomeHasFS m
dbSecParam :: forall (m :: * -> *). DbEnv m -> SecurityParam
dbHasFS :: SomeHasFS m
dbSecParam :: SecurityParam
..} = do
StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbBlocks <- Map (RealPoint TestBlock) TestBlock
-> m (StrictTVar m (Map (RealPoint TestBlock) TestBlock))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map (RealPoint TestBlock) TestBlock
forall k a. Map k a
Map.empty
StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState <- ([RealPoint TestBlock], LedgerDB' TestBlock)
-> m (StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM ([RealPoint TestBlock]
initChain, LedgerDB' TestBlock
initDB)
let dbResolve :: ResolveBlock m TestBlock
dbResolve :: ResolveBlock m TestBlock
dbResolve RealPoint TestBlock
r = STM m TestBlock -> m TestBlock
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m TestBlock -> m TestBlock) -> STM m TestBlock -> m TestBlock
forall a b. (a -> b) -> a -> b
$ RealPoint TestBlock
-> Map (RealPoint TestBlock) TestBlock -> TestBlock
getBlock RealPoint TestBlock
r (Map (RealPoint TestBlock) TestBlock -> TestBlock)
-> STM m (Map (RealPoint TestBlock) TestBlock) -> STM m TestBlock
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map (RealPoint TestBlock) TestBlock)
-> STM m (Map (RealPoint TestBlock) TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbBlocks
dbLedgerDbCfg :: LedgerDbCfg (ExtLedgerState TestBlock)
dbLedgerDbCfg :: LedgerDbCfg (ExtLedgerState TestBlock)
dbLedgerDbCfg = SecurityParam -> LedgerDbCfg (ExtLedgerState TestBlock)
extLedgerDbConfig SecurityParam
dbSecParam
StandaloneDB m -> m (StandaloneDB m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DB{StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
StrictTVar m (Map (RealPoint TestBlock) TestBlock)
LedgerDbCfg (ExtLedgerState TestBlock)
DbEnv m
ResolveBlock m TestBlock
dbEnv :: DbEnv m
dbBlocks :: StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbState :: StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbResolve :: ResolveBlock m TestBlock
dbLedgerDbCfg :: LedgerDbCfg (ExtLedgerState TestBlock)
dbEnv :: DbEnv m
dbBlocks :: StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbState :: StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbResolve :: ResolveBlock m TestBlock
dbLedgerDbCfg :: LedgerDbCfg (ExtLedgerState TestBlock)
..}
where
initChain :: [RealPoint TestBlock]
initChain :: [RealPoint TestBlock]
initChain = []
initDB :: LedgerDB' TestBlock
initDB :: LedgerDB' TestBlock
initDB = ExtLedgerState TestBlock -> LedgerDB' TestBlock
forall l. GetTip l => l -> LedgerDB l
ledgerDbWithAnchor (PayloadDependentState Tx -> ExtLedgerState TestBlock
forall ptype.
PayloadDependentState ptype -> ExtLedgerState (TestBlockWith ptype)
testInitExtLedgerWithState PayloadDependentState Tx
UTxTok
initialTestLedgerState)
getBlock ::
RealPoint TestBlock
-> Map (RealPoint TestBlock) TestBlock
-> TestBlock
getBlock :: RealPoint TestBlock
-> Map (RealPoint TestBlock) TestBlock -> TestBlock
getBlock = TestBlock
-> RealPoint TestBlock
-> Map (RealPoint TestBlock) TestBlock
-> TestBlock
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (TestName -> TestBlock
forall a. HasCallStack => TestName -> a
error TestName
blockNotFound)
blockNotFound :: String
blockNotFound :: TestName
blockNotFound = Context -> TestName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
TestName
"dbConf: "
, TestName
"invariant violation: "
, TestName
"block in dbChain not in dbBlocks, "
, TestName
"or LedgerDB not re-initialized after chain truncation"
]
dbStreamAPI :: forall m. IOLike m => StandaloneDB m -> StreamAPI m TestBlock TestBlock
dbStreamAPI :: forall (m :: * -> *).
IOLike m =>
StandaloneDB m -> StreamAPI m TestBlock TestBlock
dbStreamAPI DB{StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
StrictTVar m (Map (RealPoint TestBlock) TestBlock)
LedgerDbCfg (ExtLedgerState TestBlock)
DbEnv m
ResolveBlock m TestBlock
dbEnv :: forall (m :: * -> *). StandaloneDB m -> DbEnv m
dbBlocks :: forall (m :: * -> *).
StandaloneDB m
-> StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbState :: forall (m :: * -> *).
StandaloneDB m
-> StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbResolve :: forall (m :: * -> *). StandaloneDB m -> ResolveBlock m TestBlock
dbLedgerDbCfg :: forall (m :: * -> *).
StandaloneDB m -> LedgerDbCfg (ExtLedgerState TestBlock)
dbEnv :: DbEnv m
dbBlocks :: StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbState :: StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbResolve :: ResolveBlock m TestBlock
dbLedgerDbCfg :: LedgerDbCfg (ExtLedgerState TestBlock)
..} = StreamAPI {Point TestBlock
-> (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m b)
-> m b
forall b.
HasCallStack =>
Point TestBlock
-> (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m b)
-> m b
forall a.
Point TestBlock
-> (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a)
-> m a
streamAfter :: forall a.
Point TestBlock
-> (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a)
-> m a
streamAfter :: forall b.
HasCallStack =>
Point TestBlock
-> (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m b)
-> m b
..}
where
streamAfter ::
Point TestBlock
-> (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a)
-> m a
streamAfter :: forall a.
Point TestBlock
-> (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a)
-> m a
streamAfter Point TestBlock
tip Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a
k = do
[RealPoint TestBlock]
pts <- STM m [RealPoint TestBlock] -> m [RealPoint TestBlock]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [RealPoint TestBlock] -> m [RealPoint TestBlock])
-> STM m [RealPoint TestBlock] -> m [RealPoint TestBlock]
forall a b. (a -> b) -> a -> b
$ [RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. [a] -> [a]
reverse ([RealPoint TestBlock] -> [RealPoint TestBlock])
-> (([RealPoint TestBlock], LedgerDB' TestBlock)
-> [RealPoint TestBlock])
-> ([RealPoint TestBlock], LedgerDB' TestBlock)
-> [RealPoint TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RealPoint TestBlock], LedgerDB' TestBlock)
-> [RealPoint TestBlock]
forall a b. (a, b) -> a
fst (([RealPoint TestBlock], LedgerDB' TestBlock)
-> [RealPoint TestBlock])
-> STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> STM m [RealPoint TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState
case WithOrigin (RealPoint TestBlock)
tip' of
NotOrigin RealPoint TestBlock
pt
| RealPoint TestBlock
pt RealPoint TestBlock -> [RealPoint TestBlock] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.notElem` [RealPoint TestBlock]
pts
-> Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a
k (Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a)
-> Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a
forall a b. (a -> b) -> a -> b
$ RealPoint TestBlock
-> Either (RealPoint TestBlock) (m (NextItem TestBlock))
forall a b. a -> Either a b
Left RealPoint TestBlock
pt
WithOrigin (RealPoint TestBlock)
_otherwise
-> do StrictTVar m [RealPoint TestBlock]
toStream <- [RealPoint TestBlock] -> m (StrictTVar m [RealPoint TestBlock])
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM (WithOrigin (RealPoint TestBlock)
-> [RealPoint TestBlock] -> [RealPoint TestBlock]
blocksToStream WithOrigin (RealPoint TestBlock)
tip' [RealPoint TestBlock]
pts)
Either (RealPoint TestBlock) (m (NextItem TestBlock)) -> m a
k (m (NextItem TestBlock)
-> Either (RealPoint TestBlock) (m (NextItem TestBlock))
forall a b. b -> Either a b
Right (StrictTVar m [RealPoint TestBlock] -> m (NextItem TestBlock)
getNext StrictTVar m [RealPoint TestBlock]
toStream))
where
tip' :: WithOrigin (RealPoint TestBlock)
tip' = Point TestBlock -> WithOrigin (RealPoint TestBlock)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint Point TestBlock
tip
blocksToStream ::
WithOrigin (RealPoint TestBlock)
-> [RealPoint TestBlock] -> [RealPoint TestBlock]
blocksToStream :: WithOrigin (RealPoint TestBlock)
-> [RealPoint TestBlock] -> [RealPoint TestBlock]
blocksToStream WithOrigin (RealPoint TestBlock)
Origin = [RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. a -> a
id
blocksToStream (NotOrigin RealPoint TestBlock
r) = [RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. HasCallStack => [a] -> [a]
tail ([RealPoint TestBlock] -> [RealPoint TestBlock])
-> ([RealPoint TestBlock] -> [RealPoint TestBlock])
-> [RealPoint TestBlock]
-> [RealPoint TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealPoint TestBlock -> Bool)
-> [RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (RealPoint TestBlock -> RealPoint TestBlock -> Bool
forall a. Eq a => a -> a -> Bool
/= RealPoint TestBlock
r)
getNext :: StrictTVar m [RealPoint TestBlock] -> m (NextItem TestBlock)
getNext :: StrictTVar m [RealPoint TestBlock] -> m (NextItem TestBlock)
getNext StrictTVar m [RealPoint TestBlock]
toStream = do
Maybe (RealPoint TestBlock)
mr <- STM m (Maybe (RealPoint TestBlock))
-> m (Maybe (RealPoint TestBlock))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (RealPoint TestBlock))
-> m (Maybe (RealPoint TestBlock)))
-> STM m (Maybe (RealPoint TestBlock))
-> m (Maybe (RealPoint TestBlock))
forall a b. (a -> b) -> a -> b
$ do
[RealPoint TestBlock]
rs <- StrictTVar m [RealPoint TestBlock] -> STM m [RealPoint TestBlock]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m [RealPoint TestBlock]
toStream
case [RealPoint TestBlock]
rs of
[] -> Maybe (RealPoint TestBlock) -> STM m (Maybe (RealPoint TestBlock))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (RealPoint TestBlock)
forall a. Maybe a
Nothing
RealPoint TestBlock
r:[RealPoint TestBlock]
rs' -> StrictTVar m [RealPoint TestBlock]
-> [RealPoint TestBlock] -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m [RealPoint TestBlock]
toStream [RealPoint TestBlock]
rs' STM m ()
-> STM m (Maybe (RealPoint TestBlock))
-> STM m (Maybe (RealPoint TestBlock))
forall a b. STM m a -> STM m b -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (RealPoint TestBlock) -> STM m (Maybe (RealPoint TestBlock))
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RealPoint TestBlock -> Maybe (RealPoint TestBlock)
forall a. a -> Maybe a
Just RealPoint TestBlock
r)
case Maybe (RealPoint TestBlock)
mr of
Maybe (RealPoint TestBlock)
Nothing -> NextItem TestBlock -> m (NextItem TestBlock)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return NextItem TestBlock
forall blk. NextItem blk
NoMoreItems
Just RealPoint TestBlock
r -> do Maybe TestBlock
mb <- STM m (Maybe TestBlock) -> m (Maybe TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe TestBlock) -> m (Maybe TestBlock))
-> STM m (Maybe TestBlock) -> m (Maybe TestBlock)
forall a b. (a -> b) -> a -> b
$ RealPoint TestBlock
-> Map (RealPoint TestBlock) TestBlock -> Maybe TestBlock
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RealPoint TestBlock
r (Map (RealPoint TestBlock) TestBlock -> Maybe TestBlock)
-> STM m (Map (RealPoint TestBlock) TestBlock)
-> STM m (Maybe TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map (RealPoint TestBlock) TestBlock)
-> STM m (Map (RealPoint TestBlock) TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbBlocks
case Maybe TestBlock
mb of
Just TestBlock
b -> NextItem TestBlock -> m (NextItem TestBlock)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NextItem TestBlock -> m (NextItem TestBlock))
-> NextItem TestBlock -> m (NextItem TestBlock)
forall a b. (a -> b) -> a -> b
$ TestBlock -> NextItem TestBlock
forall blk. blk -> NextItem blk
NextItem TestBlock
b
Maybe TestBlock
Nothing -> TestName -> m (NextItem TestBlock)
forall a. HasCallStack => TestName -> a
error TestName
blockNotFound
blockNotFound :: String
blockNotFound :: TestName
blockNotFound = Context -> TestName
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
TestName
"dbStreamAPI: "
, TestName
"invariant violation: "
, TestName
"block in dbChain not present in dbBlocks"
]
runDB ::
forall m. IOLike m
=> StandaloneDB m -> Cmd DiskSnapshot -> m (Resp DiskSnapshot)
runDB :: forall (m :: * -> *).
IOLike m =>
StandaloneDB m -> Cmd DiskSnapshot -> m (Resp DiskSnapshot)
runDB standalone :: StandaloneDB m
standalone@DB{StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
StrictTVar m (Map (RealPoint TestBlock) TestBlock)
LedgerDbCfg (ExtLedgerState TestBlock)
DbEnv m
ResolveBlock m TestBlock
dbEnv :: forall (m :: * -> *). StandaloneDB m -> DbEnv m
dbBlocks :: forall (m :: * -> *).
StandaloneDB m
-> StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbState :: forall (m :: * -> *).
StandaloneDB m
-> StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbResolve :: forall (m :: * -> *). StandaloneDB m -> ResolveBlock m TestBlock
dbLedgerDbCfg :: forall (m :: * -> *).
StandaloneDB m -> LedgerDbCfg (ExtLedgerState TestBlock)
dbEnv :: DbEnv m
dbBlocks :: StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbState :: StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbResolve :: ResolveBlock m TestBlock
dbLedgerDbCfg :: LedgerDbCfg (ExtLedgerState TestBlock)
..} Cmd DiskSnapshot
cmd =
case DbEnv m
dbEnv of
DbEnv{SomeHasFS m
dbHasFS :: forall (m :: * -> *). DbEnv m -> SomeHasFS m
dbHasFS :: SomeHasFS m
dbHasFS} -> Success DiskSnapshot -> Resp DiskSnapshot
forall ss. Success ss -> Resp ss
Resp (Success DiskSnapshot -> Resp DiskSnapshot)
-> m (Success DiskSnapshot) -> m (Resp DiskSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeHasFS m -> Cmd DiskSnapshot -> m (Success DiskSnapshot)
go SomeHasFS m
dbHasFS Cmd DiskSnapshot
cmd
where
stream :: StreamAPI m TestBlock TestBlock
stream = StandaloneDB m -> StreamAPI m TestBlock TestBlock
forall (m :: * -> *).
IOLike m =>
StandaloneDB m -> StreamAPI m TestBlock TestBlock
dbStreamAPI StandaloneDB m
standalone
annLedgerErr' ::
AnnLedgerError (ExtLedgerState TestBlock) TestBlock
-> ExtValidationError TestBlock
annLedgerErr' :: AnnLedgerError (ExtLedgerState TestBlock) TestBlock
-> ExtValidationError TestBlock
annLedgerErr' = AnnLedgerError (ExtLedgerState TestBlock) TestBlock
-> LedgerErr (ExtLedgerState TestBlock)
AnnLedgerError (ExtLedgerState TestBlock) TestBlock
-> ExtValidationError TestBlock
forall l blk. AnnLedgerError l blk -> LedgerErr l
annLedgerErr
go :: SomeHasFS m -> Cmd DiskSnapshot -> m (Success DiskSnapshot)
go :: SomeHasFS m -> Cmd DiskSnapshot -> m (Success DiskSnapshot)
go SomeHasFS m
_ Cmd DiskSnapshot
Current =
STM m (Success DiskSnapshot) -> m (Success DiskSnapshot)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Success DiskSnapshot) -> m (Success DiskSnapshot))
-> STM m (Success DiskSnapshot) -> m (Success DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ (ExtLedgerState TestBlock -> Success DiskSnapshot
forall ss. ExtLedgerState TestBlock -> Success ss
Ledger (ExtLedgerState TestBlock -> Success DiskSnapshot)
-> (([RealPoint TestBlock], LedgerDB' TestBlock)
-> ExtLedgerState TestBlock)
-> ([RealPoint TestBlock], LedgerDB' TestBlock)
-> Success DiskSnapshot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerDB' TestBlock -> ExtLedgerState TestBlock
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent (LedgerDB' TestBlock -> ExtLedgerState TestBlock)
-> (([RealPoint TestBlock], LedgerDB' TestBlock)
-> LedgerDB' TestBlock)
-> ([RealPoint TestBlock], LedgerDB' TestBlock)
-> ExtLedgerState TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([RealPoint TestBlock], LedgerDB' TestBlock) -> LedgerDB' TestBlock
forall a b. (a, b) -> b
snd) (([RealPoint TestBlock], LedgerDB' TestBlock)
-> Success DiskSnapshot)
-> STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> STM m (Success DiskSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState
go SomeHasFS m
_ (Push TestBlock
b) = do
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 (Map (RealPoint TestBlock) TestBlock)
-> (Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbBlocks ((Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> STM m ())
-> (Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> STM m ()
forall a b. (a -> b) -> a -> b
$
(RealPoint TestBlock
-> TestBlock
-> Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> (RealPoint TestBlock, TestBlock)
-> Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RealPoint TestBlock
-> TestBlock
-> Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TestBlock -> (RealPoint TestBlock, TestBlock)
refValPair TestBlock
b)
([RealPoint TestBlock] -> [RealPoint TestBlock])
-> (LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Success DiskSnapshot)
upd (TestBlock -> [RealPoint TestBlock] -> [RealPoint TestBlock]
push TestBlock
b) ((LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Success DiskSnapshot))
-> (LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Success DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ \LedgerDB' TestBlock
db ->
(Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(LedgerDB' TestBlock)
-> Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(LedgerDB' TestBlock))
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AnnLedgerError (ExtLedgerState TestBlock) TestBlock
-> ExtValidationError TestBlock)
-> Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(LedgerDB' TestBlock)
-> Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)
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 AnnLedgerError (ExtLedgerState TestBlock) TestBlock
-> ExtValidationError TestBlock
annLedgerErr') (m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(LedgerDB' TestBlock))
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(LedgerDB' TestBlock))
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
forall a b. (a -> b) -> a -> b
$
ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
m
(LedgerDB' TestBlock)
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(LedgerDB' TestBlock))
forall l blk (m :: * -> *) a.
ExceptT (AnnLedgerError l blk) m a
-> m (Either (AnnLedgerError l blk) a)
defaultThrowLedgerErrors (ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
m
(LedgerDB' TestBlock)
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(LedgerDB' TestBlock)))
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
m
(LedgerDB' TestBlock)
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(LedgerDB' TestBlock))
forall a b. (a -> b) -> a -> b
$
LedgerDbCfg (ExtLedgerState TestBlock)
-> Ap
(ExceptT (AnnLedgerError (ExtLedgerState TestBlock) TestBlock) m)
(ExtLedgerState TestBlock)
TestBlock
(ThrowsLedgerError
(ExceptT (AnnLedgerError (ExtLedgerState TestBlock) TestBlock) m)
(ExtLedgerState TestBlock)
TestBlock)
-> LedgerDB' TestBlock
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
m
(LedgerDB' TestBlock)
forall (m :: * -> *) (c :: Constraint) l blk.
(ApplyBlock l blk, Monad m, c) =>
LedgerDbCfg l -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
ledgerDbPush
LedgerDbCfg (ExtLedgerState TestBlock)
dbLedgerDbCfg
(TestBlock
-> Ap
(ExceptT (AnnLedgerError (ExtLedgerState TestBlock) TestBlock) m)
(ExtLedgerState TestBlock)
TestBlock
(ThrowsLedgerError
(ExceptT (AnnLedgerError (ExtLedgerState TestBlock) TestBlock) m)
(ExtLedgerState TestBlock)
TestBlock)
forall blk (m :: * -> *) l.
blk -> Ap m l blk (ThrowsLedgerError m l blk)
ApplyVal TestBlock
b)
LedgerDB' TestBlock
db
go SomeHasFS m
_ (Switch Word64
n [TestBlock]
bs) = do
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 (Map (RealPoint TestBlock) TestBlock)
-> (Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbBlocks ((Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> STM m ())
-> (Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> STM m ()
forall a b. (a -> b) -> a -> b
$
((RealPoint TestBlock, TestBlock)
-> Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> [(RealPoint TestBlock, TestBlock)]
-> Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly ((RealPoint TestBlock
-> TestBlock
-> Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock)
-> (RealPoint TestBlock, TestBlock)
-> Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry RealPoint TestBlock
-> TestBlock
-> Map (RealPoint TestBlock) TestBlock
-> Map (RealPoint TestBlock) TestBlock
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert) ((TestBlock -> (RealPoint TestBlock, TestBlock))
-> [TestBlock] -> [(RealPoint TestBlock, TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> (RealPoint TestBlock, TestBlock)
refValPair [TestBlock]
bs)
([RealPoint TestBlock] -> [RealPoint TestBlock])
-> (LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Success DiskSnapshot)
upd (Word64
-> [TestBlock] -> [RealPoint TestBlock] -> [RealPoint TestBlock]
switch Word64
n [TestBlock]
bs) ((LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Success DiskSnapshot))
-> (LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Success DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ \LedgerDB' TestBlock
db ->
(Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(Either ExceededRollback (LedgerDB' TestBlock))
-> Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(Either ExceededRollback (LedgerDB' TestBlock)))
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AnnLedgerError (ExtLedgerState TestBlock) TestBlock
-> ExtValidationError TestBlock)
-> (Either ExceededRollback (LedgerDB' TestBlock)
-> LedgerDB' TestBlock)
-> Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(Either ExceededRollback (LedgerDB' TestBlock))
-> Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap AnnLedgerError (ExtLedgerState TestBlock) TestBlock
-> ExtValidationError TestBlock
annLedgerErr' Either ExceededRollback (LedgerDB' TestBlock)
-> LedgerDB' TestBlock
forall a. Either ExceededRollback a -> a
ignoreExceedRollback) (m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(Either ExceededRollback (LedgerDB' TestBlock)))
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(Either ExceededRollback (LedgerDB' TestBlock)))
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
forall a b. (a -> b) -> a -> b
$
ResolveBlock m TestBlock
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
(Either ExceededRollback (LedgerDB' TestBlock))
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(Either ExceededRollback (LedgerDB' TestBlock)))
forall (m :: * -> *) blk l a.
ResolveBlock m blk
-> ExceptT
(AnnLedgerError l blk) (ReaderT (ResolveBlock m blk) m) a
-> m (Either (AnnLedgerError l blk) a)
defaultResolveWithErrors ResolveBlock m TestBlock
dbResolve (ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
(Either ExceededRollback (LedgerDB' TestBlock))
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(Either ExceededRollback (LedgerDB' TestBlock))))
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
(Either ExceededRollback (LedgerDB' TestBlock))
-> m (Either
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(Either ExceededRollback (LedgerDB' TestBlock)))
forall a b. (a -> b) -> a -> b
$
LedgerDbCfg (ExtLedgerState TestBlock)
-> Word64
-> (UpdateLedgerDbTraceEvent TestBlock
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
())
-> [Ap
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m))
(ExtLedgerState TestBlock)
TestBlock
(ThrowsLedgerError
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m))
(ExtLedgerState TestBlock)
TestBlock)]
-> LedgerDB' TestBlock
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
(Either ExceededRollback (LedgerDB' TestBlock))
forall l blk (m :: * -> *) (c :: Constraint).
(ApplyBlock l blk, Monad m, c) =>
LedgerDbCfg l
-> Word64
-> (UpdateLedgerDbTraceEvent blk -> m ())
-> [Ap m l blk c]
-> LedgerDB l
-> m (Either ExceededRollback (LedgerDB l))
ledgerDbSwitch
LedgerDbCfg (ExtLedgerState TestBlock)
dbLedgerDbCfg
Word64
n
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
()
-> UpdateLedgerDbTraceEvent TestBlock
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
()
forall a b. a -> b -> a
const (ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
()
-> UpdateLedgerDbTraceEvent TestBlock
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
())
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
()
-> UpdateLedgerDbTraceEvent TestBlock
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
()
forall a b. (a -> b) -> a -> b
$ ()
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
()
forall a.
a
-> ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m)
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
((TestBlock
-> Ap
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m))
(ExtLedgerState TestBlock)
TestBlock
(ThrowsLedgerError
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m))
(ExtLedgerState TestBlock)
TestBlock))
-> [TestBlock]
-> [Ap
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m))
(ExtLedgerState TestBlock)
TestBlock
(ThrowsLedgerError
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m))
(ExtLedgerState TestBlock)
TestBlock)]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock
-> Ap
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m))
(ExtLedgerState TestBlock)
TestBlock
(ThrowsLedgerError
(ExceptT
(AnnLedgerError (ExtLedgerState TestBlock) TestBlock)
(ReaderT (ResolveBlock m TestBlock) m))
(ExtLedgerState TestBlock)
TestBlock)
forall blk (m :: * -> *) l.
blk -> Ap m l blk (ThrowsLedgerError m l blk)
ApplyVal [TestBlock]
bs)
LedgerDB' TestBlock
db
go SomeHasFS m
hasFS Cmd DiskSnapshot
Snap = do
([RealPoint TestBlock]
_, LedgerDB' TestBlock
db) <- STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> m ([RealPoint TestBlock], LedgerDB' TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState)
Maybe (DiskSnapshot, RealPoint TestBlock) -> Success DiskSnapshot
forall ss. Maybe (ss, RealPoint TestBlock) -> Success ss
Snapped (Maybe (DiskSnapshot, RealPoint TestBlock) -> Success DiskSnapshot)
-> m (Maybe (DiskSnapshot, RealPoint TestBlock))
-> m (Success DiskSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Tracer m (TraceSnapshotEvent TestBlock)
-> SomeHasFS m
-> (ExtLedgerState TestBlock -> Encoding)
-> ExtLedgerState TestBlock
-> m (Maybe (DiskSnapshot, RealPoint TestBlock))
forall (m :: * -> *) blk.
(MonadThrow m, MonadMonotonicTime m, IsLedger (LedgerState blk)) =>
Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot
Tracer m (TraceSnapshotEvent TestBlock)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
SomeHasFS m
hasFS
ExtLedgerState TestBlock -> Encoding
forall a. Serialise a => a -> Encoding
S.encode
(LedgerDB' TestBlock -> ExtLedgerState TestBlock
forall l. LedgerDB l -> l
ledgerDbAnchor LedgerDB' TestBlock
db)
go SomeHasFS m
hasFS Cmd DiskSnapshot
Restore = do
(InitLog TestBlock
initLog, LedgerDB' TestBlock
db, Word64
_replayed) <-
Tracer m (ReplayGoal TestBlock -> TraceReplayEvent TestBlock)
-> Tracer m (TraceSnapshotEvent TestBlock)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState TestBlock))
-> (forall s. Decoder s (HeaderHash TestBlock))
-> LedgerDbCfg (ExtLedgerState TestBlock)
-> m (ExtLedgerState TestBlock)
-> StreamAPI m TestBlock TestBlock
-> m (InitLog TestBlock, LedgerDB' TestBlock, Word64)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
HasCallStack) =>
Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> LedgerDbCfg (ExtLedgerState blk)
-> m (ExtLedgerState blk)
-> StreamAPI m blk blk
-> m (InitLog blk, LedgerDB' blk, Word64)
initLedgerDB
Tracer m (ReplayGoal TestBlock -> TraceReplayEvent TestBlock)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
Tracer m (TraceSnapshotEvent TestBlock)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
SomeHasFS m
hasFS
Decoder s (ExtLedgerState TestBlock)
forall s. Decoder s (ExtLedgerState TestBlock)
forall a s. Serialise a => Decoder s a
S.decode
Decoder s (HeaderHash TestBlock)
Decoder s TestHash
forall s. Decoder s (HeaderHash TestBlock)
forall s. Decoder s TestHash
forall a s. Serialise a => Decoder s a
S.decode
LedgerDbCfg (ExtLedgerState TestBlock)
dbLedgerDbCfg
(ExtLedgerState TestBlock -> m (ExtLedgerState TestBlock)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PayloadDependentState Tx -> ExtLedgerState TestBlock
forall ptype.
PayloadDependentState ptype -> ExtLedgerState (TestBlockWith ptype)
testInitExtLedgerWithState PayloadDependentState Tx
UTxTok
initialTestLedgerState))
StreamAPI m TestBlock TestBlock
stream
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 ([RealPoint TestBlock], LedgerDB' TestBlock)
-> (([RealPoint TestBlock], LedgerDB' TestBlock)
-> ([RealPoint TestBlock], LedgerDB' TestBlock))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState (\([RealPoint TestBlock]
rs, LedgerDB' TestBlock
_) -> ([RealPoint TestBlock]
rs, LedgerDB' TestBlock
db))
Success DiskSnapshot -> m (Success DiskSnapshot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Success DiskSnapshot -> m (Success DiskSnapshot))
-> Success DiskSnapshot -> m (Success DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ (MockInitLog DiskSnapshot, ExtLedgerState TestBlock)
-> Success DiskSnapshot
forall ss. (MockInitLog ss, ExtLedgerState TestBlock) -> Success ss
Restored (InitLog TestBlock -> MockInitLog DiskSnapshot
fromInitLog InitLog TestBlock
initLog, LedgerDB' TestBlock -> ExtLedgerState TestBlock
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent LedgerDB' TestBlock
db)
go SomeHasFS m
hasFS (Corrupt Corruption
c DiskSnapshot
ss) =
m (Success DiskSnapshot)
-> (FsError -> m (Success DiskSnapshot))
-> m (Success DiskSnapshot)
forall e a. Exception e => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
(case Corruption
c of
Corruption
Delete -> () -> Success DiskSnapshot
forall ss. () -> Success ss
Unit (() -> Success DiskSnapshot) -> m () -> m (Success DiskSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeHasFS m -> DiskSnapshot -> m ()
forall (m :: * -> *).
HasCallStack =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot SomeHasFS m
hasFS DiskSnapshot
ss
Corruption
Truncate -> () -> Success DiskSnapshot
forall ss. () -> Success ss
Unit (() -> Success DiskSnapshot) -> m () -> m (Success DiskSnapshot)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeHasFS m -> DiskSnapshot -> m ()
truncateSnapshot SomeHasFS m
hasFS DiskSnapshot
ss)
(\(FsError
_ :: FsError) -> Success DiskSnapshot -> m (Success DiskSnapshot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Success DiskSnapshot -> m (Success DiskSnapshot))
-> Success DiskSnapshot -> m (Success DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ () -> Success DiskSnapshot
forall ss. () -> Success ss
Unit())
go SomeHasFS m
hasFS (Drop Word64
n) = do
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
([RealPoint TestBlock]
rs, LedgerDB' TestBlock
_db) <- StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState
StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> ([RealPoint TestBlock], LedgerDB' TestBlock) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState (Int -> [RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. Int -> [a] -> [a]
drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) [RealPoint TestBlock]
rs, TestName -> LedgerDB' TestBlock
forall a. HasCallStack => TestName -> a
error TestName
"ledger DB not initialized")
SomeHasFS m -> Cmd DiskSnapshot -> m (Success DiskSnapshot)
go SomeHasFS m
hasFS Cmd DiskSnapshot
forall ss. Cmd ss
Restore
push ::
TestBlock
-> [RealPoint TestBlock] -> [RealPoint TestBlock]
push :: TestBlock -> [RealPoint TestBlock] -> [RealPoint TestBlock]
push TestBlock
b = (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
bRealPoint TestBlock
-> [RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. a -> [a] -> [a]
:)
switch ::
Word64
-> [TestBlock]
-> [RealPoint TestBlock] -> [RealPoint TestBlock]
switch :: Word64
-> [TestBlock] -> [RealPoint TestBlock] -> [RealPoint TestBlock]
switch Word64
0 [TestBlock]
bs = ([RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. [a] -> [a]
reverse ((TestBlock -> RealPoint TestBlock)
-> [TestBlock] -> [RealPoint TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint [TestBlock]
bs) [RealPoint TestBlock]
-> [RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. [a] -> [a] -> [a]
++)
switch Word64
n [TestBlock]
bs = Word64
-> [TestBlock] -> [RealPoint TestBlock] -> [RealPoint TestBlock]
switch Word64
0 [TestBlock]
bs ([RealPoint TestBlock] -> [RealPoint TestBlock])
-> ([RealPoint TestBlock] -> [RealPoint TestBlock])
-> [RealPoint TestBlock]
-> [RealPoint TestBlock]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [RealPoint TestBlock] -> [RealPoint TestBlock]
forall a. Int -> [a] -> [a]
drop (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
ignoreExceedRollback :: Either ExceededRollback a -> a
ignoreExceedRollback :: forall a. Either ExceededRollback a -> a
ignoreExceedRollback (Left ExceededRollback
_) = TestName -> a
forall a. HasCallStack => TestName -> a
error TestName
"unexpected ExceededRollback"
ignoreExceedRollback (Right a
a) = a
a
upd :: ( [RealPoint TestBlock] -> [RealPoint TestBlock] )
-> ( LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
)
-> m (Success DiskSnapshot)
upd :: ([RealPoint TestBlock] -> [RealPoint TestBlock])
-> (LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)))
-> m (Success DiskSnapshot)
upd [RealPoint TestBlock] -> [RealPoint TestBlock]
f LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
g = do
([RealPoint TestBlock]
rs, LedgerDB' TestBlock
db) <- STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> m ([RealPoint TestBlock], LedgerDB' TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> m ([RealPoint TestBlock], LedgerDB' TestBlock))
-> STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> m ([RealPoint TestBlock], LedgerDB' TestBlock)
forall a b. (a -> b) -> a -> b
$ StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
-> STM m ([RealPoint TestBlock], LedgerDB' TestBlock)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState
Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)
mDB' <- LedgerDB' TestBlock
-> m (Either (ExtValidationError TestBlock) (LedgerDB' TestBlock))
g LedgerDB' TestBlock
db
case Either (ExtValidationError TestBlock) (LedgerDB' TestBlock)
mDB' of
Left ExtValidationError TestBlock
e -> Success DiskSnapshot -> m (Success DiskSnapshot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Success DiskSnapshot -> m (Success DiskSnapshot))
-> Success DiskSnapshot -> m (Success DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ Either (ExtValidationError TestBlock) () -> Success DiskSnapshot
forall ss. Either (ExtValidationError TestBlock) () -> Success ss
MaybeErr (ExtValidationError TestBlock
-> Either (ExtValidationError TestBlock) ()
forall a b. a -> Either a b
Left ExtValidationError TestBlock
e)
Right LedgerDB' TestBlock
db' -> do 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 ([RealPoint TestBlock], LedgerDB' TestBlock)
-> ([RealPoint TestBlock], LedgerDB' TestBlock) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState ([RealPoint TestBlock] -> [RealPoint TestBlock]
f [RealPoint TestBlock]
rs, LedgerDB' TestBlock
db')
Success DiskSnapshot -> m (Success DiskSnapshot)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Success DiskSnapshot -> m (Success DiskSnapshot))
-> Success DiskSnapshot -> m (Success DiskSnapshot)
forall a b. (a -> b) -> a -> b
$ Either (ExtValidationError TestBlock) () -> Success DiskSnapshot
forall ss. Either (ExtValidationError TestBlock) () -> Success ss
MaybeErr (() -> Either (ExtValidationError TestBlock) ()
forall a b. b -> Either a b
Right ())
truncateSnapshot :: SomeHasFS m -> DiskSnapshot -> m ()
truncateSnapshot :: SomeHasFS m -> DiskSnapshot -> m ()
truncateSnapshot (SomeHasFS hasFS :: HasFS m h
hasFS@HasFS{m TestName
HasCallStack => Bool -> FsPath -> m ()
HasCallStack => Handle h -> m Bool
HasCallStack => Handle h -> m Word64
HasCallStack => Handle h -> m ()
HasCallStack => Handle h -> Word64 -> m ()
HasCallStack => Handle h -> Word64 -> m ByteString
HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
HasCallStack => Handle h -> ByteString -> m Word64
HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
HasCallStack => FsPath -> m Bool
HasCallStack => FsPath -> m ()
HasCallStack => FsPath -> m (Set TestName)
HasCallStack => FsPath -> FsPath -> m ()
HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> m TestName
FsPath -> FsErrorPath
dumpState :: m TestName
hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h)
hClose :: HasCallStack => Handle h -> m ()
hIsOpen :: HasCallStack => Handle h -> m Bool
hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hGetSome :: HasCallStack => Handle h -> Word64 -> m ByteString
hGetSomeAt :: HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hPutSome :: HasCallStack => Handle h -> ByteString -> m Word64
hTruncate :: HasCallStack => Handle h -> Word64 -> m ()
hGetSize :: HasCallStack => Handle h -> m Word64
createDirectory :: HasCallStack => FsPath -> m ()
createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()
listDirectory :: HasCallStack => FsPath -> m (Set TestName)
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
doesFileExist :: HasCallStack => FsPath -> m Bool
removeDirectoryRecursive :: HasCallStack => FsPath -> m ()
removeFile :: HasCallStack => FsPath -> m ()
renameFile :: HasCallStack => FsPath -> FsPath -> m ()
mkFsErrorPath :: FsPath -> FsErrorPath
unsafeToFilePath :: FsPath -> m TestName
hGetBufSome :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSomeAt :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSome :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSomeAt :: HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
dumpState :: forall (m :: * -> *) h. HasFS m h -> m TestName
hOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Bool
hSeek :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hGetSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hPutSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
createDirectory :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set TestName)
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
removeDirectoryRecursive :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
unsafeToFilePath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> m TestName
hGetBufSome :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hGetBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
hPutBufSome :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> m ByteCount
hPutBufSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack =>
Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
..}) DiskSnapshot
ss =
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m ()) -> m ()
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS (DiskSnapshot -> FsPath
snapshotToPath DiskSnapshot
ss) (AllowExisting -> OpenMode
AppendMode AllowExisting
AllowExisting) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
h ->
HasCallStack => Handle h -> Word64 -> m ()
Handle h -> Word64 -> m ()
hTruncate Handle h
h Word64
0
refValPair :: TestBlock -> (RealPoint TestBlock, TestBlock)
refValPair :: TestBlock -> (RealPoint TestBlock, TestBlock)
refValPair TestBlock
b = (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b, TestBlock
b)
newtype At f r = At (f (Reference DiskSnapshot r))
type f :@ r = At f r
deriving instance Show (f (Reference DiskSnapshot r)) => Show (At f r)
type SnapRefs r = [(Reference DiskSnapshot r, MockSnap)]
(!) :: Eq r => [(r, a)] -> r -> a
[(r, a)]
env ! :: forall r a. Eq r => [(r, a)] -> r -> a
! r
r = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (r -> [(r, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup r
r [(r, a)]
env)
data Model r = Model {
forall (r :: * -> *). Model r -> Mock
modelMock :: Mock
, forall (r :: * -> *). Model r -> SnapRefs r
modelSnaps :: SnapRefs r
}
deriving ((forall x. Model r -> Rep (Model r) x)
-> (forall x. Rep (Model r) x -> Model r) -> Generic (Model r)
forall x. Rep (Model r) x -> Model r
forall x. Model r -> Rep (Model r) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (r :: * -> *) x. Rep (Model r) x -> Model r
forall (r :: * -> *) x. Model r -> Rep (Model r) x
$cfrom :: forall (r :: * -> *) x. Model r -> Rep (Model r) x
from :: forall x. Model r -> Rep (Model r) x
$cto :: forall (r :: * -> *) x. Rep (Model r) x -> Model r
to :: forall x. Rep (Model r) x -> Model r
Generic)
deriving instance Show1 r => Show (Model r)
initModel :: SecurityParam -> Model r
initModel :: forall (r :: * -> *). SecurityParam -> Model r
initModel SecurityParam
secParam = Mock -> SnapRefs r -> Model r
forall (r :: * -> *). Mock -> SnapRefs r -> Model r
Model (SecurityParam -> Mock
mockInit SecurityParam
secParam) []
toMock :: (Functor f, Eq1 r) => Model r -> f :@ r -> f MockSnap
toMock :: forall (f :: * -> *) (r :: * -> *).
(Functor f, Eq1 r) =>
Model r -> (f :@ r) -> f MockSnap
toMock Model r
m (At f (Reference DiskSnapshot r)
fr) = (Model r -> SnapRefs r
forall (r :: * -> *). Model r -> SnapRefs r
modelSnaps Model r
m SnapRefs r -> Reference DiskSnapshot r -> MockSnap
forall r a. Eq r => [(r, a)] -> r -> a
!) (Reference DiskSnapshot r -> MockSnap)
-> f (Reference DiskSnapshot r) -> f MockSnap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Reference DiskSnapshot r)
fr
step :: Eq1 r => Model r -> Cmd :@ r -> (Resp MockSnap, Mock)
step :: forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp MockSnap, Mock)
step Model r
m Cmd :@ r
cmd = Cmd MockSnap -> Mock -> (Resp MockSnap, Mock)
runMock (Model r -> (Cmd :@ r) -> Cmd MockSnap
forall (f :: * -> *) (r :: * -> *).
(Functor f, Eq1 r) =>
Model r -> (f :@ r) -> f MockSnap
toMock Model r
m Cmd :@ r
cmd) (Model r -> Mock
forall (r :: * -> *). Model r -> Mock
modelMock Model r
m)
data Event r = Event {
forall (r :: * -> *). Event r -> Model r
eventBefore :: Model r
, forall (r :: * -> *). Event r -> Cmd :@ r
eventCmd :: Cmd :@ r
, forall (r :: * -> *). Event r -> Resp :@ r
eventResp :: Resp :@ r
, forall (r :: * -> *). Event r -> Model r
eventAfter :: Model r
, forall (r :: * -> *). Event r -> Resp MockSnap
eventMockResp :: Resp MockSnap
}
deriving instance Show1 r => Show (Event r)
lockstep :: Eq1 r
=> Model r
-> Cmd :@ r
-> Resp :@ r
-> Event r
lockstep :: forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp :@ r) -> Event r
lockstep m :: Model r
m@(Model Mock
_ SnapRefs r
hs) Cmd :@ r
cmd (At Resp (Reference DiskSnapshot r)
resp) = Event {
eventBefore :: Model r
eventBefore = Model r
m
, eventCmd :: Cmd :@ r
eventCmd = Cmd :@ r
cmd
, eventResp :: At Resp r
eventResp = Resp (Reference DiskSnapshot r) -> At Resp r
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At Resp (Reference DiskSnapshot r)
resp
, eventAfter :: Model r
eventAfter = Mock -> SnapRefs r -> Model r
forall (r :: * -> *). Mock -> SnapRefs r -> Model r
Model Mock
mock' (SnapRefs r
hs' SnapRefs r -> SnapRefs r -> SnapRefs r
forall a. Semigroup a => a -> a -> a
<> SnapRefs r
hs)
, eventMockResp :: Resp MockSnap
eventMockResp = Resp MockSnap
resp'
}
where
(Resp MockSnap
resp', Mock
mock') = Model r -> (Cmd :@ r) -> (Resp MockSnap, Mock)
forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp MockSnap, Mock)
step Model r
m Cmd :@ r
cmd
hs' :: SnapRefs r
hs' = [Reference DiskSnapshot r] -> [MockSnap] -> SnapRefs r
forall a b. [a] -> [b] -> [(a, b)]
zip (Resp (Reference DiskSnapshot r) -> [Reference DiskSnapshot r]
forall a. Resp a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Resp (Reference DiskSnapshot r)
resp) (Resp MockSnap -> [MockSnap]
forall a. Resp a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Resp MockSnap
resp')
execCmd :: Model Symbolic
-> QSM.Command (At Cmd) (At Resp)
-> Event Symbolic
execCmd :: Model Symbolic -> Command (At Cmd) (At Resp) -> Event Symbolic
execCmd Model Symbolic
model (QSM.Command At Cmd Symbolic
cmd At Resp Symbolic
resp [Var]
_vars) = Model Symbolic
-> At Cmd Symbolic -> At Resp Symbolic -> Event Symbolic
forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp :@ r) -> Event r
lockstep Model Symbolic
model At Cmd Symbolic
cmd At Resp Symbolic
resp
execCmds :: SecurityParam
-> QSM.Commands (At Cmd) (At Resp)
-> [Event Symbolic]
execCmds :: SecurityParam -> Commands (At Cmd) (At Resp) -> [Event Symbolic]
execCmds SecurityParam
secParam = \(QSM.Commands [Command (At Cmd) (At Resp)]
cs) -> Model Symbolic -> [Command (At Cmd) (At Resp)] -> [Event Symbolic]
go (SecurityParam -> Model Symbolic
forall (r :: * -> *). SecurityParam -> Model r
initModel SecurityParam
secParam) [Command (At Cmd) (At Resp)]
cs
where
go :: Model Symbolic
-> [QSM.Command (At Cmd) (At Resp)]
-> [Event Symbolic]
go :: Model Symbolic -> [Command (At Cmd) (At Resp)] -> [Event Symbolic]
go Model Symbolic
_ [] = []
go Model Symbolic
m (Command (At Cmd) (At Resp)
c:[Command (At Cmd) (At Resp)]
cs) = Event Symbolic
e Event Symbolic -> [Event Symbolic] -> [Event Symbolic]
forall a. a -> [a] -> [a]
: Model Symbolic -> [Command (At Cmd) (At Resp)] -> [Event Symbolic]
go (Event Symbolic -> Model Symbolic
forall (r :: * -> *). Event r -> Model r
eventAfter Event Symbolic
e) [Command (At Cmd) (At Resp)]
cs
where
e :: Event Symbolic
e = Model Symbolic -> Command (At Cmd) (At Resp) -> Event Symbolic
execCmd Model Symbolic
m Command (At Cmd) (At Resp)
c
generator :: SecurityParam -> Model Symbolic -> Maybe (Gen (Cmd :@ Symbolic))
generator :: SecurityParam -> Model Symbolic -> Maybe (Gen (At Cmd Symbolic))
generator SecurityParam
secParam (Model Mock
mock SnapRefs Symbolic
hs) = Gen (At Cmd Symbolic) -> Maybe (Gen (At Cmd Symbolic))
forall a. a -> Maybe a
Just (Gen (At Cmd Symbolic) -> Maybe (Gen (At Cmd Symbolic)))
-> Gen (At Cmd Symbolic) -> Maybe (Gen (At Cmd Symbolic))
forall a b. (a -> b) -> a -> b
$ [Gen (At Cmd Symbolic)] -> Gen (At Cmd Symbolic)
forall a. [Gen a] -> Gen a
QC.oneof ([Gen (At Cmd Symbolic)] -> Gen (At Cmd Symbolic))
-> [Gen (At Cmd Symbolic)] -> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> a -> b
$ [[Gen (At Cmd Symbolic)]] -> [Gen (At Cmd Symbolic)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
[Gen (At Cmd Symbolic)]
withoutRef
, if [(Corruption, Reference DiskSnapshot Symbolic)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Corruption, Reference DiskSnapshot Symbolic)]
possibleCorruptions
then []
else [(Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> ((Corruption, Reference DiskSnapshot Symbolic)
-> Cmd (Reference DiskSnapshot Symbolic))
-> (Corruption, Reference DiskSnapshot Symbolic)
-> At Cmd Symbolic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Corruption
-> Reference DiskSnapshot Symbolic
-> Cmd (Reference DiskSnapshot Symbolic))
-> (Corruption, Reference DiskSnapshot Symbolic)
-> Cmd (Reference DiskSnapshot Symbolic)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Corruption
-> Reference DiskSnapshot Symbolic
-> Cmd (Reference DiskSnapshot Symbolic)
forall ss. Corruption -> ss -> Cmd ss
Corrupt) ((Corruption, Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Gen (Corruption, Reference DiskSnapshot Symbolic)
-> Gen (At Cmd Symbolic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Corruption, Reference DiskSnapshot Symbolic)]
-> Gen (Corruption, Reference DiskSnapshot Symbolic)
forall a. [a] -> Gen a
QC.elements [(Corruption, Reference DiskSnapshot Symbolic)]
possibleCorruptions]
]
where
withoutRef :: [Gen (Cmd :@ Symbolic)]
withoutRef :: [Gen (At Cmd Symbolic)]
withoutRef = [
(Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic))
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> a -> b
$ Cmd (Reference DiskSnapshot Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd (Reference DiskSnapshot Symbolic)
forall ss. Cmd ss
Current
, (TestBlock -> At Cmd Symbolic)
-> Gen TestBlock -> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> (TestBlock -> Cmd (Reference DiskSnapshot Symbolic))
-> TestBlock
-> At Cmd Symbolic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Cmd (Reference DiskSnapshot Symbolic)
forall ss. TestBlock -> Cmd ss
Push) (Gen TestBlock -> Gen (At Cmd Symbolic))
-> Gen TestBlock -> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState TestBlock -> Gen TestBlock
genBlockFromLedgerState (Mock -> ExtLedgerState TestBlock
mockCurrent Mock
mock)
, (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic))
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> a -> b
$ do
let maxRollback :: Word64
maxRollback = [Word64] -> Word64
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [
Mock -> Word64
mockMaxRollback Mock
mock
, SecurityParam -> Word64
maxRollbacks SecurityParam
secParam
]
Word64
numRollback <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
QC.choose (Word64
0, Word64
maxRollback)
Word64
numNewBlocks <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
QC.choose (Word64
numRollback, Word64
numRollback Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2)
let
afterRollback :: Mock
afterRollback = Word64 -> Mock -> Mock
mockRollback Word64
numRollback Mock
mock
blocks :: [TestBlock]
blocks = Word64 -> Point TestBlock -> [TestBlock]
genBlocks
Word64
numNewBlocks
(LedgerState TestBlock -> Point TestBlock
forall ptype.
LedgerState (TestBlockWith ptype) -> Point (TestBlockWith ptype)
lastAppliedPoint (LedgerState TestBlock -> Point TestBlock)
-> (Mock -> LedgerState TestBlock) -> Mock -> Point TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExtLedgerState TestBlock -> LedgerState TestBlock
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState TestBlock -> LedgerState TestBlock)
-> (Mock -> ExtLedgerState TestBlock)
-> Mock
-> LedgerState TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mock -> ExtLedgerState TestBlock
mockCurrent (Mock -> Point TestBlock) -> Mock -> Point TestBlock
forall a b. (a -> b) -> a -> b
$ Mock
afterRollback)
Cmd (Reference DiskSnapshot Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cmd (Reference DiskSnapshot Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic)))
-> Cmd (Reference DiskSnapshot Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
forall a b. (a -> b) -> a -> b
$ Word64 -> [TestBlock] -> Cmd (Reference DiskSnapshot Symbolic)
forall ss. Word64 -> [TestBlock] -> Cmd ss
Switch Word64
numRollback [TestBlock]
blocks
, (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic))
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> a -> b
$ Cmd (Reference DiskSnapshot Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd (Reference DiskSnapshot Symbolic)
forall ss. Cmd ss
Snap
, (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic))
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> a -> b
$ Cmd (Reference DiskSnapshot Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd (Reference DiskSnapshot Symbolic)
forall ss. Cmd ss
Restore
, (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic))
-> Gen (Cmd (Reference DiskSnapshot Symbolic))
-> Gen (At Cmd Symbolic)
forall a b. (a -> b) -> a -> b
$ Word64 -> Cmd (Reference DiskSnapshot Symbolic)
forall ss. Word64 -> Cmd ss
Drop (Word64 -> Cmd (Reference DiskSnapshot Symbolic))
-> Gen Word64 -> Gen (Cmd (Reference DiskSnapshot Symbolic))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
QC.choose (Word64
0, Mock -> Word64
mockChainLength Mock
mock)
]
possibleCorruptions :: [(Corruption, Reference DiskSnapshot Symbolic)]
possibleCorruptions :: [(Corruption, Reference DiskSnapshot Symbolic)]
possibleCorruptions = ((Reference DiskSnapshot Symbolic, MockSnap)
-> [(Corruption, Reference DiskSnapshot Symbolic)])
-> SnapRefs Symbolic
-> [(Corruption, Reference DiskSnapshot Symbolic)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Reference DiskSnapshot Symbolic, MockSnap)
-> [(Corruption, Reference DiskSnapshot Symbolic)]
aux SnapRefs Symbolic
hs
where
aux :: (Reference DiskSnapshot Symbolic, MockSnap)
-> [(Corruption, Reference DiskSnapshot Symbolic)]
aux :: (Reference DiskSnapshot Symbolic, MockSnap)
-> [(Corruption, Reference DiskSnapshot Symbolic)]
aux (Reference DiskSnapshot Symbolic
diskSnap, MockSnap
mockSnap) =
case MockSnap -> MockSnaps -> Maybe (RealPoint TestBlock, SnapState)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MockSnap
mockSnap (Mock -> MockSnaps
mockSnaps Mock
mock) of
Just (RealPoint TestBlock
_tip, SnapState
state) ->
(Corruption -> (Corruption, Reference DiskSnapshot Symbolic))
-> [Corruption] -> [(Corruption, Reference DiskSnapshot Symbolic)]
forall a b. (a -> b) -> [a] -> [b]
map (, Reference DiskSnapshot Symbolic
diskSnap) ([Corruption] -> [(Corruption, Reference DiskSnapshot Symbolic)])
-> [Corruption] -> [(Corruption, Reference DiskSnapshot Symbolic)]
forall a b. (a -> b) -> a -> b
$ SnapState -> [Corruption]
possibleCorruptionsInState SnapState
state
Maybe (RealPoint TestBlock, SnapState)
Nothing ->
[]
possibleCorruptionsInState :: SnapState -> [Corruption]
possibleCorruptionsInState :: SnapState -> [Corruption]
possibleCorruptionsInState SnapState
SnapOk = [Corruption
Delete, Corruption
Truncate]
possibleCorruptionsInState SnapState
SnapCorrupted = [Corruption
Delete]
shrinker :: Model Symbolic -> Cmd :@ Symbolic -> [Cmd :@ Symbolic]
shrinker :: Model Symbolic -> At Cmd Symbolic -> [At Cmd Symbolic]
shrinker Model Symbolic
_ (At Cmd (Reference DiskSnapshot Symbolic)
cmd) =
case Cmd (Reference DiskSnapshot Symbolic)
cmd of
Cmd (Reference DiskSnapshot Symbolic)
Current -> []
Push TestBlock
_b -> []
Cmd (Reference DiskSnapshot Symbolic)
Snap -> []
Cmd (Reference DiskSnapshot Symbolic)
Restore -> []
Switch Word64
0 [TestBlock
b] -> [Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall a b. (a -> b) -> a -> b
$ TestBlock -> Cmd (Reference DiskSnapshot Symbolic)
forall ss. TestBlock -> Cmd ss
Push TestBlock
b]
Switch Word64
n [TestBlock]
bs -> if [TestBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestBlock]
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
then [Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall a b. (a -> b) -> a -> b
$ Word64 -> [TestBlock] -> Cmd (Reference DiskSnapshot Symbolic)
forall ss. Word64 -> [TestBlock] -> Cmd ss
Switch Word64
n ([TestBlock] -> [TestBlock]
forall a. HasCallStack => [a] -> [a]
init [TestBlock]
bs)]
else []
Corrupt Corruption
c Reference DiskSnapshot Symbolic
ss -> case Corruption
c of
Corruption
Truncate -> [Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall a b. (a -> b) -> a -> b
$ Corruption
-> Reference DiskSnapshot Symbolic
-> Cmd (Reference DiskSnapshot Symbolic)
forall ss. Corruption -> ss -> Cmd ss
Corrupt Corruption
Delete Reference DiskSnapshot Symbolic
ss]
Corruption
Delete -> []
Drop Word64
n -> Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Cmd (Reference DiskSnapshot Symbolic) -> At Cmd Symbolic)
-> (Word64 -> Cmd (Reference DiskSnapshot Symbolic))
-> Word64
-> At Cmd Symbolic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Cmd (Reference DiskSnapshot Symbolic)
forall ss. Word64 -> Cmd ss
Drop (Word64 -> At Cmd Symbolic) -> [Word64] -> [At Cmd Symbolic]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> [Word64]
forall a. Arbitrary a => a -> [a]
QC.shrink Word64
n
instance CommandNames (At Cmd) where
cmdName :: forall (r :: * -> *). At Cmd r -> TestName
cmdName (At Current{}) = TestName
"Current"
cmdName (At Push{}) = TestName
"Push"
cmdName (At Switch{}) = TestName
"Switch"
cmdName (At Snap{}) = TestName
"Snap"
cmdName (At Restore{}) = TestName
"Restore"
cmdName (At Corrupt{}) = TestName
"Corrupt"
cmdName (At Drop{}) = TestName
"Drop"
cmdNames :: forall (r :: * -> *). Proxy (At Cmd r) -> Context
cmdNames Proxy (At Cmd r)
_ = [
TestName
"Current"
, TestName
"Push"
, TestName
"Switch"
, TestName
"Snap"
, TestName
"Restore"
, TestName
"Corrupt"
, TestName
"Drop"
]
instance Functor f => Rank2.Functor (At f) where
fmap :: forall (p :: * -> *) (q :: * -> *).
(forall x. p x -> q x) -> At f p -> At f q
fmap = \forall x. p x -> q x
f (At f (Reference DiskSnapshot p)
x) -> f (Reference DiskSnapshot q) -> At f q
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (f (Reference DiskSnapshot q) -> At f q)
-> f (Reference DiskSnapshot q) -> At f q
forall a b. (a -> b) -> a -> b
$ (Reference DiskSnapshot p -> Reference DiskSnapshot q)
-> f (Reference DiskSnapshot p) -> f (Reference DiskSnapshot q)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((p DiskSnapshot -> q DiskSnapshot)
-> Reference DiskSnapshot p -> Reference DiskSnapshot q
forall (r :: * -> *) x (r' :: * -> *).
(r x -> r' x) -> Reference x r -> Reference x r'
lift p DiskSnapshot -> q DiskSnapshot
forall x. p x -> q x
f) f (Reference DiskSnapshot p)
x
where
lift :: (r x -> r' x) -> QSM.Reference x r -> QSM.Reference x r'
lift :: forall (r :: * -> *) x (r' :: * -> *).
(r x -> r' x) -> Reference x r -> Reference x r'
lift r x -> r' x
f (QSM.Reference r x
x) = r' x -> Reference x r'
forall a (r :: * -> *). r a -> Reference a r
QSM.Reference (r x -> r' x
f r x
x)
instance Foldable f => Rank2.Foldable (At f) where
foldMap :: forall m (p :: * -> *).
Monoid m =>
(forall x. p x -> m) -> At f p -> m
foldMap = \forall x. p x -> m
f (At f (Reference DiskSnapshot p)
x) -> (Reference DiskSnapshot p -> m)
-> f (Reference DiskSnapshot p) -> m
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((p DiskSnapshot -> m) -> Reference DiskSnapshot p -> m
forall (r :: * -> *) x m. (r x -> m) -> Reference x r -> m
lift p DiskSnapshot -> m
forall x. p x -> m
f) f (Reference DiskSnapshot p)
x
where
lift :: (r x -> m) -> QSM.Reference x r -> m
lift :: forall (r :: * -> *) x m. (r x -> m) -> Reference x r -> m
lift r x -> m
f (QSM.Reference r x
x) = r x -> m
f r x
x
instance Traversable t => Rank2.Traversable (At t) where
traverse :: forall (f :: * -> *) (p :: * -> *) (q :: * -> *).
Applicative f =>
(forall a. p a -> f (q a)) -> At t p -> f (At t q)
traverse = \forall a. p a -> f (q a)
f (At t (Reference DiskSnapshot p)
x) -> t (Reference DiskSnapshot q) -> At t q
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (t (Reference DiskSnapshot q) -> At t q)
-> f (t (Reference DiskSnapshot q)) -> f (At t q)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Reference DiskSnapshot p -> f (Reference DiskSnapshot q))
-> t (Reference DiskSnapshot p) -> f (t (Reference DiskSnapshot q))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse ((p DiskSnapshot -> f (q DiskSnapshot))
-> Reference DiskSnapshot p -> f (Reference DiskSnapshot q)
forall (f :: * -> *) (r :: * -> *) x (r' :: * -> *).
Functor f =>
(r x -> f (r' x)) -> Reference x r -> f (Reference x r')
lift p DiskSnapshot -> f (q DiskSnapshot)
forall a. p a -> f (q a)
f) t (Reference DiskSnapshot p)
x
where
lift :: Functor f
=> (r x -> f (r' x)) -> QSM.Reference x r -> f (QSM.Reference x r')
lift :: forall (f :: * -> *) (r :: * -> *) x (r' :: * -> *).
Functor f =>
(r x -> f (r' x)) -> Reference x r -> f (Reference x r')
lift r x -> f (r' x)
f (QSM.Reference r x
x) = r' x -> Reference x r'
forall a (r :: * -> *). r a -> Reference a r
QSM.Reference (r' x -> Reference x r') -> f (r' x) -> f (Reference x r')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r x -> f (r' x)
f r x
x
instance ToExpr (Model Concrete)
semantics :: IOLike m
=> StandaloneDB m
-> Cmd :@ Concrete -> m (Resp :@ Concrete)
semantics :: forall (m :: * -> *).
IOLike m =>
StandaloneDB m -> At Cmd Concrete -> m (At Resp Concrete)
semantics StandaloneDB m
db (At Cmd (Reference DiskSnapshot Concrete)
cmd) = (Resp (Reference DiskSnapshot Concrete) -> At Resp Concrete
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Resp (Reference DiskSnapshot Concrete) -> At Resp Concrete)
-> (Resp DiskSnapshot -> Resp (Reference DiskSnapshot Concrete))
-> Resp DiskSnapshot
-> At Resp Concrete
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiskSnapshot -> Reference DiskSnapshot Concrete)
-> Resp DiskSnapshot -> Resp (Reference DiskSnapshot Concrete)
forall a b. (a -> b) -> Resp a -> Resp b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DiskSnapshot -> Reference DiskSnapshot Concrete
forall a. Typeable a => a -> Reference a Concrete
reference) (Resp DiskSnapshot -> At Resp Concrete)
-> m (Resp DiskSnapshot) -> m (At Resp Concrete)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StandaloneDB m -> Cmd DiskSnapshot -> m (Resp DiskSnapshot)
forall (m :: * -> *).
IOLike m =>
StandaloneDB m -> Cmd DiskSnapshot -> m (Resp DiskSnapshot)
runDB StandaloneDB m
db (Reference DiskSnapshot Concrete -> DiskSnapshot
forall a. Reference a Concrete -> a
concrete (Reference DiskSnapshot Concrete -> DiskSnapshot)
-> Cmd (Reference DiskSnapshot Concrete) -> Cmd DiskSnapshot
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cmd (Reference DiskSnapshot Concrete)
cmd)
transition :: Eq1 r
=> Model r
-> Cmd :@ r
-> Resp :@ r
-> Model r
transition :: forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp :@ r) -> Model r
transition Model r
m Cmd :@ r
cmd = Event r -> Model r
forall (r :: * -> *). Event r -> Model r
eventAfter (Event r -> Model r)
-> ((Resp :@ r) -> Event r) -> (Resp :@ r) -> Model r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Model r -> (Cmd :@ r) -> (Resp :@ r) -> Event r
forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp :@ r) -> Event r
lockstep Model r
m Cmd :@ r
cmd
postcondition :: Model Concrete
-> Cmd :@ Concrete
-> Resp :@ Concrete
-> Logic
postcondition :: Model Concrete -> At Cmd Concrete -> At Resp Concrete -> Logic
postcondition Model Concrete
m At Cmd Concrete
cmd At Resp Concrete
r = Model Concrete -> At Resp Concrete -> Resp MockSnap
forall (f :: * -> *) (r :: * -> *).
(Functor f, Eq1 r) =>
Model r -> (f :@ r) -> f MockSnap
toMock (Event Concrete -> Model Concrete
forall (r :: * -> *). Event r -> Model r
eventAfter Event Concrete
e) At Resp Concrete
r Resp MockSnap -> Resp MockSnap -> Logic
forall a. (Eq a, Show a) => a -> a -> Logic
.== Event Concrete -> Resp MockSnap
forall (r :: * -> *). Event r -> Resp MockSnap
eventMockResp Event Concrete
e
where
e :: Event Concrete
e = Model Concrete
-> At Cmd Concrete -> At Resp Concrete -> Event Concrete
forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp :@ r) -> Event r
lockstep Model Concrete
m At Cmd Concrete
cmd At Resp Concrete
r
precondition :: Model Symbolic -> Cmd :@ Symbolic -> Logic
precondition :: Model Symbolic -> At Cmd Symbolic -> Logic
precondition (Model Mock
mock SnapRefs Symbolic
hs) (At Cmd (Reference DiskSnapshot Symbolic)
c) =
[Reference DiskSnapshot Symbolic]
-> (Reference DiskSnapshot Symbolic -> Logic) -> Logic
forall a. Show a => [a] -> (a -> Logic) -> Logic
forAll (Cmd (Reference DiskSnapshot Symbolic)
-> [Reference DiskSnapshot Symbolic]
forall a. Cmd a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Cmd (Reference DiskSnapshot Symbolic)
c) (Reference DiskSnapshot Symbolic
-> [Reference DiskSnapshot Symbolic] -> Logic
forall (t :: * -> *) a.
(Foldable t, Eq a, Show a, Show (t a)) =>
a -> t a -> Logic
`member` ((Reference DiskSnapshot Symbolic, MockSnap)
-> Reference DiskSnapshot Symbolic)
-> SnapRefs Symbolic -> [Reference DiskSnapshot Symbolic]
forall a b. (a -> b) -> [a] -> [b]
map (Reference DiskSnapshot Symbolic, MockSnap)
-> Reference DiskSnapshot Symbolic
forall a b. (a, b) -> a
fst SnapRefs Symbolic
hs)
Logic -> Logic -> Logic
.&& Cmd (Reference DiskSnapshot Symbolic) -> Logic
forall ss. Cmd ss -> Logic
validCmd Cmd (Reference DiskSnapshot Symbolic)
c
where
validCmd :: Cmd ss -> Logic
validCmd :: forall ss. Cmd ss -> Logic
validCmd (Switch Word64
n [TestBlock]
_) = Word64
n Word64 -> Word64 -> Logic
forall a. (Ord a, Show a) => a -> a -> Logic
.<= Mock -> Word64
mockMaxRollback Mock
mock
validCmd Cmd ss
_otherwise = Logic
Top
symbolicResp :: Model Symbolic
-> Cmd :@ Symbolic
-> GenSym (Resp :@ Symbolic)
symbolicResp :: Model Symbolic -> At Cmd Symbolic -> GenSym (At Resp Symbolic)
symbolicResp Model Symbolic
m At Cmd Symbolic
c = Resp (Reference DiskSnapshot Symbolic) -> At Resp Symbolic
forall (f :: * -> *) (r :: * -> *).
f (Reference DiskSnapshot r) -> At f r
At (Resp (Reference DiskSnapshot Symbolic) -> At Resp Symbolic)
-> GenSym (Resp (Reference DiskSnapshot Symbolic))
-> GenSym (At Resp Symbolic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MockSnap -> GenSym (Reference DiskSnapshot Symbolic))
-> Resp MockSnap -> GenSym (Resp (Reference DiskSnapshot Symbolic))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Resp a -> f (Resp b)
traverse (GenSym (Reference DiskSnapshot Symbolic)
-> MockSnap -> GenSym (Reference DiskSnapshot Symbolic)
forall a b. a -> b -> a
const GenSym (Reference DiskSnapshot Symbolic)
forall a. Typeable a => GenSym (Reference a Symbolic)
genSym) Resp MockSnap
resp
where
(Resp MockSnap
resp, Mock
_mock') = Model Symbolic -> At Cmd Symbolic -> (Resp MockSnap, Mock)
forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp MockSnap, Mock)
step Model Symbolic
m At Cmd Symbolic
c
sm :: IOLike m
=> SecurityParam
-> StandaloneDB m
-> StateMachine Model (At Cmd) m (At Resp)
sm :: forall (m :: * -> *).
IOLike m =>
SecurityParam
-> StandaloneDB m -> StateMachine Model (At Cmd) m (At Resp)
sm SecurityParam
secParam StandaloneDB m
db = StateMachine {
initModel :: forall (r :: * -> *). Model r
initModel = SecurityParam -> Model r
forall (r :: * -> *). SecurityParam -> Model r
initModel SecurityParam
secParam
, transition :: forall (r :: * -> *).
(Show1 r, Ord1 r) =>
Model r -> At Cmd r -> At Resp r -> Model r
transition = Model r -> (Cmd :@ r) -> (Resp :@ r) -> Model r
forall (r :: * -> *).
(Show1 r, Ord1 r) =>
Model r -> At Cmd r -> At Resp r -> Model r
forall (r :: * -> *).
Eq1 r =>
Model r -> (Cmd :@ r) -> (Resp :@ r) -> Model r
transition
, precondition :: Model Symbolic -> At Cmd Symbolic -> Logic
precondition = Model Symbolic -> At Cmd Symbolic -> Logic
precondition
, postcondition :: Model Concrete -> At Cmd Concrete -> At Resp Concrete -> Logic
postcondition = Model Concrete -> At Cmd Concrete -> At Resp Concrete -> Logic
postcondition
, invariant :: Maybe (Model Concrete -> Logic)
invariant = Maybe (Model Concrete -> Logic)
forall a. Maybe a
Nothing
, generator :: Model Symbolic -> Maybe (Gen (At Cmd Symbolic))
generator = SecurityParam -> Model Symbolic -> Maybe (Gen (At Cmd Symbolic))
generator SecurityParam
secParam
, shrinker :: Model Symbolic -> At Cmd Symbolic -> [At Cmd Symbolic]
shrinker = Model Symbolic -> At Cmd Symbolic -> [At Cmd Symbolic]
shrinker
, semantics :: At Cmd Concrete -> m (At Resp Concrete)
semantics = StandaloneDB m -> At Cmd Concrete -> m (At Resp Concrete)
forall (m :: * -> *).
IOLike m =>
StandaloneDB m -> At Cmd Concrete -> m (At Resp Concrete)
semantics StandaloneDB m
db
, mock :: Model Symbolic -> At Cmd Symbolic -> GenSym (At Resp Symbolic)
mock = Model Symbolic -> At Cmd Symbolic -> GenSym (At Resp Symbolic)
symbolicResp
, cleanup :: Model Concrete -> m ()
cleanup = Model Concrete -> m ()
forall (m :: * -> *) (model :: (* -> *) -> *).
Monad m =>
model Concrete -> m ()
noCleanup
}
prop_sequential :: SecurityParam -> QC.Property
prop_sequential :: SecurityParam -> Property
prop_sequential SecurityParam
secParam =
StateMachine Model (At Cmd) IO (At Resp)
-> Maybe Int
-> (Commands (At Cmd) (At Resp) -> Property)
-> Property
forall prop (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *)
(model :: (* -> *) -> *) (m :: * -> *).
(Testable prop, Show (cmd Symbolic), Show (resp Symbolic),
Show (model Symbolic), Traversable cmd, Foldable resp) =>
StateMachine model cmd m resp
-> Maybe Int -> (Commands cmd resp -> prop) -> Property
forAllCommands (SecurityParam
-> StandaloneDB IO -> StateMachine Model (At Cmd) IO (At Resp)
forall (m :: * -> *).
IOLike m =>
SecurityParam
-> StandaloneDB m -> StateMachine Model (At Cmd) m (At Resp)
sm SecurityParam
secParam StandaloneDB IO
dbUnused) Maybe Int
forall a. Maybe a
Nothing ((Commands (At Cmd) (At Resp) -> Property) -> Property)
-> (Commands (At Cmd) (At Resp) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Commands (At Cmd) (At Resp)
cmds ->
PropertyM IO () -> Property
forall a. Testable a => PropertyM IO a -> Property
QC.monadicIO (SecurityParam -> Commands (At Cmd) (At Resp) -> PropertyM IO ()
propCmds SecurityParam
secParam Commands (At Cmd) (At Resp)
cmds)
propCmds :: SecurityParam
-> QSM.Commands (At Cmd) (At Resp)
-> QC.PropertyM IO ()
propCmds :: SecurityParam -> Commands (At Cmd) (At Resp) -> PropertyM IO ()
propCmds SecurityParam
secParam Commands (At Cmd) (At Resp)
cmds = do
StrictTMVar IO MockFS
fs <- IO (StrictTMVar IO MockFS) -> PropertyM IO (StrictTMVar IO MockFS)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
QC.run (IO (StrictTMVar IO MockFS)
-> PropertyM IO (StrictTMVar IO MockFS))
-> IO (StrictTMVar IO MockFS)
-> PropertyM IO (StrictTMVar IO MockFS)
forall a b. (a -> b) -> a -> b
$ STM IO (StrictTMVar IO MockFS) -> IO (StrictTMVar IO MockFS)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (StrictTMVar IO MockFS) -> IO (StrictTMVar IO MockFS))
-> STM IO (StrictTMVar IO MockFS) -> IO (StrictTMVar IO MockFS)
forall a b. (a -> b) -> a -> b
$ MockFS -> STM IO (StrictTMVar IO MockFS)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTMVar m a)
newTMVar MockFS
MockFS.empty
let dbEnv :: DbEnv IO
dbEnv :: DbEnv IO
dbEnv = SomeHasFS IO -> SecurityParam -> DbEnv IO
forall (m :: * -> *). SomeHasFS m -> SecurityParam -> DbEnv m
DbEnv (HasFS IO HandleMock -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (StrictTMVar IO MockFS -> HasFS IO HandleMock
forall (m :: * -> *).
(MonadSTM m, MonadThrow m, PrimMonad m) =>
StrictTMVar m MockFS -> HasFS m HandleMock
simHasFS StrictTMVar IO MockFS
fs)) SecurityParam
secParam
StandaloneDB IO
db <- IO (StandaloneDB IO) -> PropertyM IO (StandaloneDB IO)
forall (m :: * -> *) a. Monad m => m a -> PropertyM m a
QC.run (IO (StandaloneDB IO) -> PropertyM IO (StandaloneDB IO))
-> IO (StandaloneDB IO) -> PropertyM IO (StandaloneDB IO)
forall a b. (a -> b) -> a -> b
$ DbEnv IO -> IO (StandaloneDB IO)
forall (m :: * -> *). IOLike m => DbEnv m -> m (StandaloneDB m)
initStandaloneDB DbEnv IO
dbEnv
let sm' :: StateMachine Model (At Cmd) IO (At Resp)
sm' = SecurityParam
-> StandaloneDB IO -> StateMachine Model (At Cmd) IO (At Resp)
forall (m :: * -> *).
IOLike m =>
SecurityParam
-> StandaloneDB m -> StateMachine Model (At Cmd) m (At Resp)
sm SecurityParam
secParam StandaloneDB IO
db
(History (At Cmd) (At Resp)
hist, Model Concrete
_model, Reason
res) <- StateMachine Model (At Cmd) IO (At Resp)
-> Commands (At Cmd) (At Resp)
-> PropertyM
IO (History (At Cmd) (At Resp), Model Concrete, Reason)
forall (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *) (m :: * -> *)
(model :: (* -> *) -> *).
(Show (cmd Concrete), Show (resp Concrete), Traversable cmd,
Foldable resp, MonadMask m, MonadIO m) =>
StateMachine model cmd m resp
-> Commands cmd resp
-> PropertyM m (History cmd resp, model Concrete, Reason)
runCommands StateMachine Model (At Cmd) IO (At Resp)
sm' Commands (At Cmd) (At Resp)
cmds
StateMachine Model (At Cmd) IO (At Resp)
-> History (At Cmd) (At Resp) -> Property -> PropertyM IO ()
forall (m :: * -> *) (model :: (* -> *) -> *)
(cmd :: (* -> *) -> *) (resp :: (* -> *) -> *).
(MonadIO m, CanDiff (model Concrete), Show (cmd Concrete),
Show (resp Concrete)) =>
StateMachine model cmd m resp
-> History cmd resp -> Property -> PropertyM m ()
prettyCommands StateMachine Model (At Cmd) IO (At Resp)
sm' History (At Cmd) (At Resp)
hist
(Property -> PropertyM IO ()) -> Property -> PropertyM IO ()
forall a b. (a -> b) -> a -> b
$ TestName -> Context -> Property -> Property
forall prop.
Testable prop =>
TestName -> Context -> prop -> Property
QC.tabulate
TestName
"Tags"
((Tag -> TestName) -> [Tag] -> Context
forall a b. (a -> b) -> [a] -> [b]
map Tag -> TestName
forall a. Show a => a -> TestName
show ([Tag] -> Context) -> [Tag] -> Context
forall a b. (a -> b) -> a -> b
$ SecurityParam -> [Event Symbolic] -> [Tag]
tagEvents SecurityParam
secParam (SecurityParam -> Commands (At Cmd) (At Resp) -> [Event Symbolic]
execCmds SecurityParam
secParam Commands (At Cmd) (At Resp)
cmds))
(Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Reason
res Reason -> Reason -> Property
forall a. (Eq a, Show a) => a -> a -> Property
QC.=== Reason
Ok
dbUnused :: StandaloneDB IO
dbUnused :: StandaloneDB IO
dbUnused = TestName -> StandaloneDB IO
forall a. HasCallStack => TestName -> a
error TestName
"DB unused during command generation"
data Tag =
TagRestore (Maybe SnapState) RangeK
| TagMaxRollback RangeK
| TagMaxDrop RangeK
deriving (Int -> Tag -> ShowS
[Tag] -> ShowS
Tag -> TestName
(Int -> Tag -> ShowS)
-> (Tag -> TestName) -> ([Tag] -> ShowS) -> Show Tag
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tag -> ShowS
showsPrec :: Int -> Tag -> ShowS
$cshow :: Tag -> TestName
show :: Tag -> TestName
$cshowList :: [Tag] -> ShowS
showList :: [Tag] -> ShowS
Show, Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
/= :: Tag -> Tag -> Bool
Eq)
type EventPred = C.Predicate (Event Symbolic) Tag
tagEvents :: SecurityParam -> [Event Symbolic] -> [Tag]
tagEvents :: SecurityParam -> [Event Symbolic] -> [Tag]
tagEvents SecurityParam
k = [Predicate (Event Symbolic) Tag] -> [Event Symbolic] -> [Tag]
forall a b. [Predicate a b] -> [a] -> [b]
C.classify [
Predicate (Event Symbolic) Tag
tagMaxRollback
, Predicate (Event Symbolic) Tag
tagMaxDrop
, Maybe SnapState -> Predicate (Event Symbolic) Tag
tagRestore Maybe SnapState
forall a. Maybe a
Nothing
, Maybe SnapState -> Predicate (Event Symbolic) Tag
tagRestore (SnapState -> Maybe SnapState
forall a. a -> Maybe a
Just SnapState
SnapOk)
, Maybe SnapState -> Predicate (Event Symbolic) Tag
tagRestore (SnapState -> Maybe SnapState
forall a. a -> Maybe a
Just SnapState
SnapCorrupted)
]
where
tagMaxRollback :: EventPred
tagMaxRollback :: Predicate (Event Symbolic) Tag
tagMaxRollback =
(Word64 -> Tag)
-> Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag
forall a b.
(a -> b)
-> Predicate (Event Symbolic) a -> Predicate (Event Symbolic) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RangeK -> Tag
TagMaxRollback (RangeK -> Tag) -> (Word64 -> RangeK) -> Word64 -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> Word64 -> RangeK
forall a. Integral a => SecurityParam -> a -> RangeK
rangeK SecurityParam
k) (Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag)
-> Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag
forall a b. (a -> b) -> a -> b
$ (Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64
forall a b. Ord b => (a -> Maybe b) -> Predicate a b
C.maximum ((Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64)
-> (Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64
forall a b. (a -> b) -> a -> b
$ \Event Symbolic
ev ->
case Event Symbolic -> At Cmd Symbolic
forall (r :: * -> *). Event r -> Cmd :@ r
eventCmd Event Symbolic
ev of
At (Switch Word64
n [TestBlock]
_) -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
n
At Cmd Symbolic
_otherwise -> Maybe Word64
forall a. Maybe a
Nothing
tagMaxDrop :: EventPred
tagMaxDrop :: Predicate (Event Symbolic) Tag
tagMaxDrop =
(Word64 -> Tag)
-> Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag
forall a b.
(a -> b)
-> Predicate (Event Symbolic) a -> Predicate (Event Symbolic) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RangeK -> Tag
TagMaxDrop (RangeK -> Tag) -> (Word64 -> RangeK) -> Word64 -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> Word64 -> RangeK
forall a. Integral a => SecurityParam -> a -> RangeK
rangeK SecurityParam
k) (Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag)
-> Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag
forall a b. (a -> b) -> a -> b
$ (Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64
forall a b. Ord b => (a -> Maybe b) -> Predicate a b
C.maximum ((Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64)
-> (Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64
forall a b. (a -> b) -> a -> b
$ \Event Symbolic
ev ->
case Event Symbolic -> At Cmd Symbolic
forall (r :: * -> *). Event r -> Cmd :@ r
eventCmd Event Symbolic
ev of
At (Drop Word64
n) -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
n
At Cmd Symbolic
_otherwise -> Maybe Word64
forall a. Maybe a
Nothing
tagRestore :: Maybe SnapState -> EventPred
tagRestore :: Maybe SnapState -> Predicate (Event Symbolic) Tag
tagRestore Maybe SnapState
mST =
(Word64 -> Tag)
-> Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag
forall a b.
(a -> b)
-> Predicate (Event Symbolic) a -> Predicate (Event Symbolic) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe SnapState -> RangeK -> Tag
TagRestore Maybe SnapState
mST (RangeK -> Tag) -> (Word64 -> RangeK) -> Word64 -> Tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> Word64 -> RangeK
forall a. Integral a => SecurityParam -> a -> RangeK
rangeK SecurityParam
k) (Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag)
-> Predicate (Event Symbolic) Word64
-> Predicate (Event Symbolic) Tag
forall a b. (a -> b) -> a -> b
$ (Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64
forall a b. Ord b => (a -> Maybe b) -> Predicate a b
C.maximum ((Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64)
-> (Event Symbolic -> Maybe Word64)
-> Predicate (Event Symbolic) Word64
forall a b. (a -> b) -> a -> b
$ \Event Symbolic
ev ->
let mock :: Mock
mock = Model Symbolic -> Mock
forall (r :: * -> *). Model r -> Mock
modelMock (Event Symbolic -> Model Symbolic
forall (r :: * -> *). Event r -> Model r
eventBefore Event Symbolic
ev) in
case Event Symbolic -> At Cmd Symbolic
forall (r :: * -> *). Event r -> Cmd :@ r
eventCmd Event Symbolic
ev of
At Cmd (Reference DiskSnapshot Symbolic)
Restore | Mock -> Maybe SnapState
mockRecentSnap Mock
mock Maybe SnapState -> Maybe SnapState -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe SnapState
mST -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Mock -> Word64
mockChainLength Mock
mock)
At Cmd Symbolic
_otherwise -> Maybe Word64
forall a. Maybe a
Nothing
showLabelledExamples :: SecurityParam
-> Maybe Int
-> (Tag -> Bool)
-> IO ()
showLabelledExamples :: SecurityParam -> Maybe Int -> (Tag -> Bool) -> IO ()
showLabelledExamples SecurityParam
secParam Maybe Int
mReplay Tag -> Bool
relevant = do
Int
replaySeed <- case Maybe Int
mReplay of
Maybe Int
Nothing -> (StdGen -> (Int, StdGen)) -> IO Int
forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom ((StdGen -> (Int, StdGen)) -> IO Int)
-> (StdGen -> (Int, StdGen)) -> IO Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> StdGen -> (Int, StdGen)
forall g. RandomGen g => (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
1, Int
999999)
Just Int
seed -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
seed
TestName -> IO ()
putStrLn (TestName -> IO ()) -> TestName -> IO ()
forall a b. (a -> b) -> a -> b
$ TestName
"Using replaySeed " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
replaySeed
let args :: Args
args = Args
QC.stdArgs {
QC.maxSuccess = 10000
, QC.replay = Just (QC.mkQCGen replaySeed, 0)
}
Args -> Property -> IO ()
forall prop. Testable prop => Args -> prop -> IO ()
QC.labelledExamplesWith Args
args (Property -> IO ()) -> Property -> IO ()
forall a b. (a -> b) -> a -> b
$
StateMachine Model (At Cmd) IO (At Resp)
-> Maybe Int
-> (Commands (At Cmd) (At Resp) -> Property)
-> Property
forall prop (cmd :: (* -> *) -> *) (resp :: (* -> *) -> *)
(model :: (* -> *) -> *) (m :: * -> *).
(Testable prop, Show (cmd Symbolic), Show (resp Symbolic),
Show (model Symbolic), Traversable cmd, Foldable resp) =>
StateMachine model cmd m resp
-> Maybe Int -> (Commands cmd resp -> prop) -> Property
forAllCommands (SecurityParam
-> StandaloneDB IO -> StateMachine Model (At Cmd) IO (At Resp)
forall (m :: * -> *).
IOLike m =>
SecurityParam
-> StandaloneDB m -> StateMachine Model (At Cmd) m (At Resp)
sm SecurityParam
secParam StandaloneDB IO
dbUnused) Maybe Int
forall a. Maybe a
Nothing ((Commands (At Cmd) (At Resp) -> Property) -> Property)
-> (Commands (At Cmd) (At Resp) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \Commands (At Cmd) (At Resp)
cmds ->
(Tag -> Property -> Property) -> [Tag] -> Property -> Property
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly Tag -> Property -> Property
forall a prop. (Show a, Testable prop) => a -> prop -> Property
QC.collect (Commands (At Cmd) (At Resp) -> [Tag]
run Commands (At Cmd) (At Resp)
cmds) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool -> Property
forall prop. Testable prop => prop -> Property
QC.property Bool
True
where
run :: QSM.Commands (At Cmd) (At Resp) -> [Tag]
run :: Commands (At Cmd) (At Resp) -> [Tag]
run = (Tag -> Bool) -> [Tag] -> [Tag]
forall a. (a -> Bool) -> [a] -> [a]
filter Tag -> Bool
relevant ([Tag] -> [Tag])
-> (Commands (At Cmd) (At Resp) -> [Tag])
-> Commands (At Cmd) (At Resp)
-> [Tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> [Event Symbolic] -> [Tag]
tagEvents SecurityParam
secParam ([Event Symbolic] -> [Tag])
-> (Commands (At Cmd) (At Resp) -> [Event Symbolic])
-> Commands (At Cmd) (At Resp)
-> [Tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> Commands (At Cmd) (At Resp) -> [Event Symbolic]
execCmds SecurityParam
secParam