{-# 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

-- | On-disk ledger DB tests.
--
-- This is a model based test. The commands here are
--
-- * Get the current ledger state
-- * Push a block, or switch to a fork
-- * Write a snapshot to disk
-- * Restore the ledger DB from the snapshots on disk
-- * Model disk corruption
--
-- The model here is satisfyingly simple: just a map from blocks to their
-- corresponding ledger state.
--
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 ()

{-------------------------------------------------------------------------------
  Top-level tests
-------------------------------------------------------------------------------}

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
    ]

{-------------------------------------------------------------------------------
  TestBlock
-------------------------------------------------------------------------------}

type TestBlock = TestBlockWith Tx

-- | Mock of a UTxO transaction where exactly one (transaction) input is
-- consumed and exactly one output is produced.
--
data Tx = Tx {
    -- | Input that the transaction consumes.
    Tx -> Token
consumed :: Token
    -- | Ouptupt that the transaction produces.
  , 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)

-- | A token is an identifier for the values produced and consumed by the
-- 'TestBlock' transactions.
--
-- This is analogous to @TxId@: it's how we identify what's in the table. It's
-- also analogous to @TxIn@, since we trivially only have one output per 'Tx'.
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)

-- | Unit of value associated with the output produced by a transaction.
--
-- This is analogous to @TxOut@: it's what the table maps 'Token's to.
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)

{-------------------------------------------------------------------------------
  A ledger semantics for TestBlock
-------------------------------------------------------------------------------}

data UTxTok = UTxTok { UTxTok -> Map Token TValue
utxtok  :: Map Token TValue
                     , -- | All the tokens that ever existed. We use this to
                       -- make sure a token is not created more than once. See
                       -- the definition of 'applyPayload' in the
                       -- 'PayloadSemantics' of 'Tx'.
                       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

  -- We need to exercise the HD backend. This requires that we store key-values
  -- ledger tables and the block application semantics satisfy:
  --
  -- * a key is deleted at most once
  -- * a key is inserted at most once
  --
  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

{-------------------------------------------------------------------------------
  TestBlock generation

  When we added support for storing parts of the ledger state on disk we needed
  to exercise this new functionality. Therefore, we modified this test so that
  the ledger state associated to the test block contained tables (key-value
  maps) to be stored on disk. This ledger state needs to follow an evolution
  pattern similar to the UTxO one (see the 'PayloadSemantics' instance for more
  details). As a result, block application might fail on a given payload.

  The tests in this module assume that no invalid blocks are generated. Thus we
  have to satisfy this assumption in the block generators. To keep the
  generators simple, eg independent on the ledger state, we follow this strategy
  to block generation:

  - The block payload consist of a single transaction:
      - input: Point
      - output: (Point, SlotNo)
  - The ledger state is a map from Point to SlotNo.
  - We start always in an initial state in which 'GenesisPoint' maps to slot 0.
  - When we generate a block for point p, the payload of the block will be:
      - input: point p - 1
      - ouptput: (point p, slot of point p)


  A consequence of adopting the strategy above is that the initial state is
  coupled to the generator's semantics.
 -------------------------------------------------------------------------------}

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

-- | Get the token value associated to a given token. This is coupled to the
-- generators semantics.
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
        -- This could be the new block itself; we merely wanted to avoid the loop.
        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))
    }


-- | TODO: for the time being 'TestBlock' does not have any codec config
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)

-- | TODO: for the time being 'TestBlock' does not have any storage config
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)

{-------------------------------------------------------------------------------
  Commands
-------------------------------------------------------------------------------}

data Corruption =
    -- | Delete the snapshot entirely
    Delete

    -- | Truncate the file
    --
    -- This is just a simple way to cause a deserialisation error
  | 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 =
    -- | Get the current ledger state
    Current

    -- | Push a block
  | Push TestBlock

    -- | Switch to a fork
  | Switch Word64 [TestBlock]

    -- | Take a snapshot (write to disk)
  | Snap

    -- | Restore the DB from on-disk, then return it along with the init log
  | Restore

    -- | Corrupt a previously taken snapshot
  | Corrupt Corruption ss

    -- | Corruption of the chain
    --
    -- Chain corruption, no matter what form, always results in truncation. We
    -- model this as the number of blocks that got truncated from the end of the
    -- chain.
    --
    -- NOTE: Since this is modelling /disk/ corruption, and it is the
    -- responsibility of the 'ChainDB' to /notice/ disk corruption (by
    -- catching the appropriate exceptions), we assume that the ledger state
    -- will immediately be re-initialized after a 'Truncate' (which is precisely
    -- what the 'ChainDB' would do, after first doing recovery on the
    -- underlying 'LedgerDB'). This is important because otherwise the model
    -- would diverge from the real thing.
    --
    -- Since 'Drop' therefore implies a 'Restore', we return the new ledger.
  | 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)

-- | Currently we don't have any error responses
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)

{-------------------------------------------------------------------------------
  Pure model
-------------------------------------------------------------------------------}

-- | The mock ledger records the blocks and ledger values (new to old)
type MockLedger = [(TestBlock, ExtLedgerState TestBlock)]

-- | We use the slot number of the ledger state as the snapshot number
--
-- We only keep track of this to be able to give more meaningful statistics
-- about generated tests. The mock implementation doesn't actually " take "
-- any snapshots (instead it stores the ledger state at each point).
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)

-- | State of all snapshots on disk
--
-- In addition to the state of the snapshot we also record the tip of the chain
-- at the time we took the snapshot; this is important for 'mockMaxRollback'.
type MockSnaps = Map MockSnap (RealPoint TestBlock, SnapState)

-- | Mock implementation
--
-- The mock implementation simply records the ledger at every point.
-- We store the chain most recent first.
data Mock = Mock {
      -- | Current ledger
      Mock -> MockLedger
mockLedger   :: MockLedger

      -- | Current state the snapshots
    , Mock -> MockSnaps
mockSnaps    :: MockSnaps

      -- | The oldest (tail) block in the real DB at the most recent restore
      --
      -- This puts a limit on how far we can roll back.
      -- See also 'applyMockLog', 'mockMaxRollback'.
    , Mock -> Point TestBlock
mockRestore  :: Point TestBlock

      -- | Security parameter
      --
      -- We need the security parameter only to compute which snapshots the real
      -- implementation would take, so that we can accurately predict how far
      -- the real implementation can roll back.
    , 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

{-------------------------------------------------------------------------------
  Modelling restoration

  Although the mock implementation itself is not affected by disk failures
  (in fact, the concept makes no sense, since we don't store anything on disk),
  we /do/ need to be able to accurately predict how the real DB will be
  initialized (from which snapshot); this is important, because this dictates
  how far the real DB can roll back.
-------------------------------------------------------------------------------}

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 ->
            -- If it's truncated, it will skip it
            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

-- | Compute theoretical maximum rollback
--
-- The actual maximum rollback will be restricted by the ledger DB params.
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

{-------------------------------------------------------------------------------
  Interpreter
-------------------------------------------------------------------------------}

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
          -- No snapshot to take or one already exists
          -> (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
        -- | The snapshot that the real implementation will possibly write to
        -- disk.
        --
        -- 1. We will write the snapshot of the ledger state @k@ blocks back
        --    from the tip to disk.
        --
        --    For example, with @k = 2@:
        --
        --    > A -> B -> C -> D -> E
        --
        --    We will write C to disk.
        --
        -- 2. In case we don't have enough snapshots for (1), i.e., @<= k@, we
        --    look at the snapshot from which we restored ('mockRestore').
        --
        --    a. When that corresponds to the genesis ledger state, we don't
        --       write a snapshot to disk.
        --
        --    b. Otherwise, we write 'mockRestore' to disk. Note that we later
        --       check whether that snapshots still exists on disk, in which
        --       case we wouldn't write it to disk again.
        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)  -- 1
            []         -> 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  -- 2a
                            NotOrigin RealPoint TestBlock
pt -> RealPoint TestBlock -> Maybe (RealPoint TestBlock)
forall a. a -> Maybe a
Just RealPoint TestBlock
pt  -- 2b
          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

            -- The snapshots from new to old until 'mockRestore' (inclusive)
            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

{-------------------------------------------------------------------------------
  Standalone instantiation of the ledger DB
-------------------------------------------------------------------------------}

-- | Arguments required by 'StandaloneDB'
data DbEnv m = DbEnv {
      forall (m :: * -> *). DbEnv m -> SomeHasFS m
dbHasFS    :: SomeHasFS m
    , forall (m :: * -> *). DbEnv m -> SecurityParam
dbSecParam :: SecurityParam
    }

-- | Standalone ledger DB
--
-- Under normal circumstances the ledger DB is maintained by the 'ChainDB',
-- and supported by the 'ChainDB'. In order to test it stand-alone we need to
-- mock these components.
data StandaloneDB m = DB {
      -- | Arguments
      forall (m :: * -> *). StandaloneDB m -> DbEnv m
dbEnv         :: DbEnv m

      -- | Block storage
      --
      -- We can think of this as mocking the volatile DB. Blocks can be
      -- added to this without updating the rest of the state.
    , forall (m :: * -> *).
StandaloneDB m
-> StrictTVar m (Map (RealPoint TestBlock) TestBlock)
dbBlocks      :: StrictTVar m (Map (RealPoint TestBlock) TestBlock)

      -- | Current chain and corresponding ledger state
      --
      -- We can think of this as mocking the ChainDB, which must keep
      -- track of a current chain and keep the ledger DB in sync with it.
      --
      -- Invariant: all references @r@ here must be present in 'dbBlocks'.
    , forall (m :: * -> *).
StandaloneDB m
-> StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)
dbState       :: StrictTVar m ([RealPoint TestBlock], LedgerDB' TestBlock)

      -- | Resolve blocks
    , forall (m :: * -> *). StandaloneDB m -> ResolveBlock m TestBlock
dbResolve     :: ResolveBlock m TestBlock

      -- | LedgerDB config
    , 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

    -- Blocks to stream
    --
    -- Precondition: tip must be on the current chain
    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()) -- ignore any errors during corruption
    go SomeHasFS m
hasFS (Drop Word64
n) = do
        -- During recovery the ChainDB would ask the ChainDB to recover
        -- and pick a new current chain; only once that is done would it
        -- compute a new ledger state. During this process the ChainDB
        -- would effectively be closed.
        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)

    -- We don't currently test the case where the LedgerDB cannot support
    -- the full rollback range. See also
    -- <https://github.com/IntersectMBO/ouroboros-network/issues/1025>
    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
        -- We cannot run the whole thing in a transaction, since computing the
        -- new value of the ledger DB may require reading from the chain DB
        ([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)

{-------------------------------------------------------------------------------
  References
-------------------------------------------------------------------------------}

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)

{-------------------------------------------------------------------------------
  Model
-------------------------------------------------------------------------------}

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)

{-------------------------------------------------------------------------------
  Events
-------------------------------------------------------------------------------}

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) -- new references override old!
    , 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
-------------------------------------------------------------------------------}

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. HasCallStack => [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. HasCallStack => [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 ->
                -- The snapshot has already been deleted
                []

    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 []
      -- an absent snapshot is easier than a corrupted one
      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

{-------------------------------------------------------------------------------
  Additional type class instances required by QSM
-------------------------------------------------------------------------------}

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)

{-------------------------------------------------------------------------------
  Final state machine
-------------------------------------------------------------------------------}

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
    -- Maximum rollback might decrease if shrinking removed blocks
    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)

-- Ideally we'd like to use @IOSim s@ instead of IO, but unfortunately
-- QSM requires monads that implement MonadIO.
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"

{-------------------------------------------------------------------------------
  Event labelling

  TODO: We need at least a label for restore-after-corruption
-------------------------------------------------------------------------------}

data Tag =
    -- | Restore
    --
    -- We record the length of the chain at the time of the restore (to the
    -- closest power of two) as well as the state of the most recent snapshot,
    -- if any has been created.
    --
    -- We will look for the /maximum/ chain length in each case.
    TagRestore (Maybe SnapState) RangeK

    -- | Tag rollback
    --
    -- We record the rollback length
  | TagMaxRollback RangeK

    -- | Tag chain truncation
    --
    -- We record how many blocks were dropped
  | 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

{-------------------------------------------------------------------------------
  Inspecting the labelling function
-------------------------------------------------------------------------------}

showLabelledExamples :: SecurityParam
                     -> Maybe Int
                     -> (Tag -> Bool) -- ^ Which tag are we interested in?
                     -> 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