{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
module Test.Ouroboros.Storage.ChainDB.Iterator (tests) where
import Control.Monad (forM_)
import Control.Monad.Except (ExceptT (..), runExceptT)
import Control.Monad.IOSim (runSimOrThrow)
import Control.Monad.Trans.Class (lift)
import Control.Tracer
import Data.List (intercalate)
import qualified Data.Map.Strict as Map
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Storage.ChainDB.API (BlockComponent (..),
Iterator (..), IteratorResult (..), StreamFrom (..),
StreamTo (..), UnknownRange (..))
import Ouroboros.Consensus.Storage.ChainDB.Impl.Iterator
(IteratorEnv (..), newIterator)
import Ouroboros.Consensus.Storage.ChainDB.Impl.Types
(IteratorKey (..), TraceIteratorEvent (..))
import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB)
import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
import Ouroboros.Consensus.Util.Condense (condense)
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
import Ouroboros.Network.Mock.Chain (Chain)
import qualified Ouroboros.Network.Mock.Chain as Chain
import qualified Test.Ouroboros.Storage.ImmutableDB.Mock as ImmutableDB
(openDBMock)
import Test.Ouroboros.Storage.TestBlock
import qualified Test.Ouroboros.Storage.VolatileDB.Mock as VolatileDB
(openDBMock)
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.Util.Orphans.IOLike ()
import Test.Util.Tracer (recordingTracerTVar)
tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"Iterator"
[ String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"#773 bug in example 1" Property
prop_773_bug
, String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"#773 correct example 2" Property
prop_773_working
, String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"#1435 case 1" Property
prop_1435_case1
, String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"#1435 case 2" Property
prop_1435_case2
, String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"#1435 case 3" Property
prop_1435_case3
, String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"#1435 case 4" Property
prop_1435_case4
, String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"#1435 case 5" Property
prop_1435_case5
, String -> Property -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"#1435 case 6" Property
prop_1435_case6
]
a, b, c, d, e :: TestBlock
a :: TestBlock
a = SlotNo -> TestBody -> TestBlock
firstBlock SlotNo
0 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
b :: TestBlock
b = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
a SlotNo
1 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
c :: TestBlock
c = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
b SlotNo
2 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
d :: TestBlock
d = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
c SlotNo
3 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
e :: TestBlock
e = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
d SlotNo
4 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
prop_773_bug :: Property
prop_773_bug :: Property
prop_773_bug = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test
TestSetup
{ immutable :: Chain TestBlock
immutable = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst [TestBlock
a, TestBlock
b, TestBlock
c, TestBlock
d]
, volatile :: [TestBlock]
volatile = [TestBlock
c, TestBlock
d]
}
(RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
a))
(RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
c))
([Either (RealPoint TestBlock) TestBlock] -> IterRes
forall a b. b -> Either a b
Right ((TestBlock -> Either (RealPoint TestBlock) TestBlock)
-> [TestBlock] -> [Either (RealPoint TestBlock) TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> Either (RealPoint TestBlock) TestBlock
forall a b. b -> Either a b
Right [TestBlock
a, TestBlock
b, TestBlock
c]))
prop_773_working :: Property
prop_773_working :: Property
prop_773_working = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test
TestSetup
{ immutable :: Chain TestBlock
immutable = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst [TestBlock
a, TestBlock
b, TestBlock
c, TestBlock
d]
, volatile :: [TestBlock]
volatile = [TestBlock
c, TestBlock
d, TestBlock
e]
}
(RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
a))
(RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
e))
([Either (RealPoint TestBlock) TestBlock] -> IterRes
forall a b. b -> Either a b
Right ((TestBlock -> Either (RealPoint TestBlock) TestBlock)
-> [TestBlock] -> [Either (RealPoint TestBlock) TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> Either (RealPoint TestBlock) TestBlock
forall a b. b -> Either a b
Right [TestBlock
a, TestBlock
b, TestBlock
c, TestBlock
d, TestBlock
e]))
prop_1435_case1 :: Property
prop_1435_case1 :: Property
prop_1435_case1 = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test
TestSetup
{ immutable :: Chain TestBlock
immutable = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst [TestBlock
ebb, TestBlock
b]
, volatile :: [TestBlock]
volatile = []
}
(RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b'))
(RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b'))
(UnknownRange TestBlock -> IterRes
forall a b. a -> Either a b
Left (StreamFrom TestBlock -> UnknownRange TestBlock
forall blk. StreamFrom blk -> UnknownRange blk
ForkTooOld (RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b'))))
where
canContainEBB :: b -> Bool
canContainEBB = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True
ebb :: TestBlock
ebb = (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
forall {b}. b -> Bool
canContainEBB TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
b :: TestBlock
b = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
ebb SlotNo
0 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
b' :: TestBlock
b' = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
ebb SlotNo
0 TestBody { tbForkNo :: Word
tbForkNo = Word
1, tbIsValid :: Bool
tbIsValid = Bool
True }
prop_1435_case2 :: Property
prop_1435_case2 :: Property
prop_1435_case2 = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test
TestSetup
{ immutable :: Chain TestBlock
immutable = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst [TestBlock
ebb, TestBlock
b]
, volatile :: [TestBlock]
volatile = []
}
(RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb'))
(RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb'))
(UnknownRange TestBlock -> IterRes
forall a b. a -> Either a b
Left (StreamFrom TestBlock -> UnknownRange TestBlock
forall blk. StreamFrom blk -> UnknownRange blk
ForkTooOld (RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb'))))
where
canContainEBB :: b -> Bool
canContainEBB = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True
ebb :: TestBlock
ebb = (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
forall {b}. b -> Bool
canContainEBB TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
b :: TestBlock
b = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
ebb SlotNo
0 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
ebb' :: TestBlock
ebb' = (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
forall {b}. b -> Bool
canContainEBB TestBody { tbForkNo :: Word
tbForkNo = Word
1, tbIsValid :: Bool
tbIsValid = Bool
True }
prop_1435_case3 :: Property
prop_1435_case3 :: Property
prop_1435_case3 = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test
TestSetup
{ immutable :: Chain TestBlock
immutable = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst [TestBlock
ebb, TestBlock
b]
, volatile :: [TestBlock]
volatile = []
}
(RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb))
(RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb))
([Either (RealPoint TestBlock) TestBlock] -> IterRes
forall a b. b -> Either a b
Right ((TestBlock -> Either (RealPoint TestBlock) TestBlock)
-> [TestBlock] -> [Either (RealPoint TestBlock) TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> Either (RealPoint TestBlock) TestBlock
forall a b. b -> Either a b
Right [TestBlock
ebb]))
where
canContainEBB :: b -> Bool
canContainEBB = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True
ebb :: TestBlock
ebb = (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
forall {b}. b -> Bool
canContainEBB TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
b :: TestBlock
b = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
ebb SlotNo
0 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
prop_1435_case4 :: Property
prop_1435_case4 :: Property
prop_1435_case4 = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test
TestSetup
{ immutable :: Chain TestBlock
immutable = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst [TestBlock
ebb]
, volatile :: [TestBlock]
volatile = [TestBlock
b]
}
(RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb))
(RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb))
([Either (RealPoint TestBlock) TestBlock] -> IterRes
forall a b. b -> Either a b
Right ((TestBlock -> Either (RealPoint TestBlock) TestBlock)
-> [TestBlock] -> [Either (RealPoint TestBlock) TestBlock]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> Either (RealPoint TestBlock) TestBlock
forall a b. b -> Either a b
Right [TestBlock
ebb]))
where
canContainEBB :: b -> Bool
canContainEBB = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True
ebb :: TestBlock
ebb = (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
forall {b}. b -> Bool
canContainEBB TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
b :: TestBlock
b = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
ebb SlotNo
0 TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
prop_1435_case5 :: Property
prop_1435_case5 :: Property
prop_1435_case5 = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test
TestSetup
{ immutable :: Chain TestBlock
immutable = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst [TestBlock
ebb]
, volatile :: [TestBlock]
volatile = []
}
(RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b'))
(RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b'))
(UnknownRange TestBlock -> IterRes
forall a b. a -> Either a b
Left (StreamFrom TestBlock -> UnknownRange TestBlock
forall blk. StreamFrom blk -> UnknownRange blk
ForkTooOld (RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
b'))))
where
canContainEBB :: b -> Bool
canContainEBB = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True
ebb :: TestBlock
ebb = (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
forall {b}. b -> Bool
canContainEBB TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
b' :: TestBlock
b' = TestBlock -> SlotNo -> TestBody -> TestBlock
mkNextBlock TestBlock
ebb SlotNo
0 TestBody { tbForkNo :: Word
tbForkNo = Word
1, tbIsValid :: Bool
tbIsValid = Bool
True }
prop_1435_case6 :: Property
prop_1435_case6 :: Property
prop_1435_case6 = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test
TestSetup
{ immutable :: Chain TestBlock
immutable = [TestBlock] -> Chain TestBlock
forall block. HasHeader block => [block] -> Chain block
Chain.fromOldestFirst [TestBlock
ebb]
, volatile :: [TestBlock]
volatile = []
}
(RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb'))
(RealPoint TestBlock -> StreamTo TestBlock
forall blk. RealPoint blk -> StreamTo blk
StreamToInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb'))
(UnknownRange TestBlock -> IterRes
forall a b. a -> Either a b
Left (StreamFrom TestBlock -> UnknownRange TestBlock
forall blk. StreamFrom blk -> UnknownRange blk
ForkTooOld (RealPoint TestBlock -> StreamFrom TestBlock
forall blk. RealPoint blk -> StreamFrom blk
StreamFromInclusive (TestBlock -> RealPoint TestBlock
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint TestBlock
ebb'))))
where
canContainEBB :: b -> Bool
canContainEBB = Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True
ebb :: TestBlock
ebb = (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
forall {b}. b -> Bool
canContainEBB TestBody { tbForkNo :: Word
tbForkNo = Word
0, tbIsValid :: Bool
tbIsValid = Bool
True }
ebb' :: TestBlock
ebb' = (SlotNo -> Bool) -> TestBody -> TestBlock
firstEBB SlotNo -> Bool
forall {b}. b -> Bool
canContainEBB TestBody { tbForkNo :: Word
tbForkNo = Word
1, tbIsValid :: Bool
tbIsValid = Bool
True }
prop_general_test
:: TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test :: TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IterRes
-> Property
prop_general_test TestSetup
setup StreamFrom TestBlock
from StreamTo TestBlock
to IterRes
expected =
String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (TestSetup -> String
testSetupInfo TestSetup
setup) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
case (IterRes
actual, IterRes
expected) of
(Left UnknownRange TestBlock
actualErr, Left UnknownRange TestBlock
expectedErr) -> UnknownRange TestBlock
actualErr UnknownRange TestBlock -> UnknownRange TestBlock -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== UnknownRange TestBlock
expectedErr
(Left UnknownRange TestBlock
actualErr, Right [Either (RealPoint TestBlock) TestBlock]
expectedStream) -> String -> Property
failure (String -> Property) -> String -> Property
forall a b. (a -> b) -> a -> b
$
String
"Got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnknownRange TestBlock -> String
forall a. Show a => a -> String
show UnknownRange TestBlock
actualErr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nbut expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Either (RealPoint TestBlock) TestBlock] -> String
ppStream [Either (RealPoint TestBlock) TestBlock]
expectedStream
(Right [Either (RealPoint TestBlock) TestBlock]
actualStream, Left UnknownRange TestBlock
expectedErr) -> String -> Property
failure (String -> Property) -> String -> Property
forall a b. (a -> b) -> a -> b
$
String
"Got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Either (RealPoint TestBlock) TestBlock] -> String
ppStream [Either (RealPoint TestBlock) TestBlock]
actualStream String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nbut expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnknownRange TestBlock -> String
forall a. Show a => a -> String
show UnknownRange TestBlock
expectedErr
(Right [Either (RealPoint TestBlock) TestBlock]
actualStream, Right [Either (RealPoint TestBlock) TestBlock]
expectedStream)
| [Either (RealPoint TestBlock) TestBlock]
actualStream [Either (RealPoint TestBlock) TestBlock]
-> [Either (RealPoint TestBlock) TestBlock] -> Bool
forall a. Eq a => a -> a -> Bool
== [Either (RealPoint TestBlock) TestBlock]
expectedStream
-> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
| Bool
otherwise
-> String -> Property
failure (String -> Property) -> String -> Property
forall a b. (a -> b) -> a -> b
$ String
"Got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Either (RealPoint TestBlock) TestBlock] -> String
ppStream [Either (RealPoint TestBlock) TestBlock]
actualStream String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\nbut expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
[Either (RealPoint TestBlock) TestBlock] -> String
ppStream [Either (RealPoint TestBlock) TestBlock]
expectedStream
where
([TraceIteratorEvent TestBlock]
_trace, IterRes
actual) = TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> ([TraceIteratorEvent TestBlock], IterRes)
runIterator TestSetup
setup StreamFrom TestBlock
from StreamTo TestBlock
to
failure :: String -> Property
failure String
msg = String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
msg Bool
False
ppStream :: [Either (RealPoint TestBlock) TestBlock] -> String
ppStream :: [Either (RealPoint TestBlock) TestBlock] -> String
ppStream = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" :> " ([String] -> String)
-> ([Either (RealPoint TestBlock) TestBlock] -> [String])
-> [Either (RealPoint TestBlock) TestBlock]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either (RealPoint TestBlock) TestBlock -> String)
-> [Either (RealPoint TestBlock) TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Either (RealPoint TestBlock) TestBlock -> String
ppGCedOrBlock
data TestSetup = TestSetup
{ TestSetup -> Chain TestBlock
immutable :: Chain TestBlock
, TestSetup -> [TestBlock]
volatile :: [TestBlock]
}
testSetupInfo :: TestSetup -> String
testSetupInfo :: TestSetup -> String
testSetupInfo TestSetup { Chain TestBlock
immutable :: TestSetup -> Chain TestBlock
immutable :: Chain TestBlock
immutable, [TestBlock]
volatile :: TestSetup -> [TestBlock]
volatile :: [TestBlock]
volatile } = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
[ String
"Immutable: "
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" :> " ((TestBlock -> String) -> [TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> String
ppBlock (Chain TestBlock -> [TestBlock]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain TestBlock
immutable))
, String
"\n"
, String
"Volatile: "
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((TestBlock -> String) -> [TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map TestBlock -> String
ppBlock [TestBlock]
volatile)
]
ppGCedOrBlock :: Either (RealPoint TestBlock) TestBlock -> String
ppGCedOrBlock :: Either (RealPoint TestBlock) TestBlock -> String
ppGCedOrBlock (Left RealPoint TestBlock
gcedPt) = String
"GCed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RealPoint TestBlock -> String
forall a. Condense a => a -> String
condense RealPoint TestBlock
gcedPt
ppGCedOrBlock (Right TestBlock
blk) = TestBlock -> String
ppBlock TestBlock
blk
ppBlock :: TestBlock -> String
ppBlock :: TestBlock -> String
ppBlock = TestBlock -> String
forall a. Condense a => a -> String
condense
type IterRes = Either (UnknownRange TestBlock)
[Either (RealPoint TestBlock) TestBlock]
runIterator ::
TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> ([TraceIteratorEvent TestBlock], IterRes)
runIterator :: TestSetup
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> ([TraceIteratorEvent TestBlock], IterRes)
runIterator TestSetup
setup StreamFrom TestBlock
from StreamTo TestBlock
to = (forall s. IOSim s ([TraceIteratorEvent TestBlock], IterRes))
-> ([TraceIteratorEvent TestBlock], IterRes)
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s ([TraceIteratorEvent TestBlock], IterRes))
-> ([TraceIteratorEvent TestBlock], IterRes))
-> (forall s. IOSim s ([TraceIteratorEvent TestBlock], IterRes))
-> ([TraceIteratorEvent TestBlock], IterRes)
forall a b. (a -> b) -> a -> b
$ (ResourceRegistry (IOSim s)
-> IOSim s ([TraceIteratorEvent TestBlock], IterRes))
-> IOSim s ([TraceIteratorEvent TestBlock], IterRes)
forall (m :: * -> *) a.
(IOLike m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry (IOSim s)
-> IOSim s ([TraceIteratorEvent TestBlock], IterRes))
-> IOSim s ([TraceIteratorEvent TestBlock], IterRes))
-> (ResourceRegistry (IOSim s)
-> IOSim s ([TraceIteratorEvent TestBlock], IterRes))
-> IOSim s ([TraceIteratorEvent TestBlock], IterRes)
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry (IOSim s)
r -> do
(Tracer (IOSim s) (TraceIteratorEvent TestBlock)
tracer, IOSim s [TraceIteratorEvent TestBlock]
getTrace) <- IOSim
s
(Tracer (IOSim s) (TraceIteratorEvent TestBlock),
IOSim s [TraceIteratorEvent TestBlock])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
IteratorEnv (IOSim s) TestBlock
itEnv <- TestSetup
-> Tracer (IOSim s) (TraceIteratorEvent TestBlock)
-> IOSim s (IteratorEnv (IOSim s) TestBlock)
forall (m :: * -> *).
IOLike m =>
TestSetup
-> Tracer m (TraceIteratorEvent TestBlock)
-> m (IteratorEnv m TestBlock)
initIteratorEnv TestSetup
setup Tracer (IOSim s) (TraceIteratorEvent TestBlock)
tracer
IterRes
res <- ExceptT
(UnknownRange TestBlock)
(IOSim s)
[Either (RealPoint TestBlock) TestBlock]
-> IOSim s IterRes
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
(UnknownRange TestBlock)
(IOSim s)
[Either (RealPoint TestBlock) TestBlock]
-> IOSim s IterRes)
-> ExceptT
(UnknownRange TestBlock)
(IOSim s)
[Either (RealPoint TestBlock) TestBlock]
-> IOSim s IterRes
forall a b. (a -> b) -> a -> b
$ do
Iterator (IOSim s) TestBlock TestBlock
it <- IOSim
s
(Either
(UnknownRange TestBlock) (Iterator (IOSim s) TestBlock TestBlock))
-> ExceptT
(UnknownRange TestBlock)
(IOSim s)
(Iterator (IOSim s) TestBlock TestBlock)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IOSim
s
(Either
(UnknownRange TestBlock) (Iterator (IOSim s) TestBlock TestBlock))
-> ExceptT
(UnknownRange TestBlock)
(IOSim s)
(Iterator (IOSim s) TestBlock TestBlock))
-> IOSim
s
(Either
(UnknownRange TestBlock) (Iterator (IOSim s) TestBlock TestBlock))
-> ExceptT
(UnknownRange TestBlock)
(IOSim s)
(Iterator (IOSim s) TestBlock TestBlock)
forall a b. (a -> b) -> a -> b
$ IteratorEnv (IOSim s) TestBlock
-> (forall r.
(IteratorEnv (IOSim s) TestBlock -> IOSim s r) -> IOSim s r)
-> ResourceRegistry (IOSim s)
-> BlockComponent TestBlock TestBlock
-> StreamFrom TestBlock
-> StreamTo TestBlock
-> IOSim
s
(Either
(UnknownRange TestBlock) (Iterator (IOSim s) TestBlock TestBlock))
forall (m :: * -> *) blk b.
(IOLike m, HasHeader blk, HasCallStack) =>
IteratorEnv m blk
-> (forall r. (IteratorEnv m blk -> m r) -> m r)
-> ResourceRegistry m
-> BlockComponent blk b
-> StreamFrom blk
-> StreamTo blk
-> m (Either (UnknownRange blk) (Iterator m blk b))
newIterator IteratorEnv (IOSim s) TestBlock
itEnv ((IteratorEnv (IOSim s) TestBlock -> IOSim s r)
-> IteratorEnv (IOSim s) TestBlock -> IOSim s r
forall a b. (a -> b) -> a -> b
$ IteratorEnv (IOSim s) TestBlock
itEnv) ResourceRegistry (IOSim s)
r BlockComponent TestBlock TestBlock
forall blk. BlockComponent blk blk
GetBlock StreamFrom TestBlock
from StreamTo TestBlock
to
IOSim s [Either (RealPoint TestBlock) TestBlock]
-> ExceptT
(UnknownRange TestBlock)
(IOSim s)
[Either (RealPoint TestBlock) TestBlock]
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (UnknownRange TestBlock) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IOSim s [Either (RealPoint TestBlock) TestBlock]
-> ExceptT
(UnknownRange TestBlock)
(IOSim s)
[Either (RealPoint TestBlock) TestBlock])
-> IOSim s [Either (RealPoint TestBlock) TestBlock]
-> ExceptT
(UnknownRange TestBlock)
(IOSim s)
[Either (RealPoint TestBlock) TestBlock]
forall a b. (a -> b) -> a -> b
$ Iterator (IOSim s) TestBlock TestBlock
-> IOSim s [Either (RealPoint TestBlock) TestBlock]
forall (m :: * -> *).
Monad m =>
Iterator m TestBlock TestBlock
-> m [Either (RealPoint TestBlock) TestBlock]
consume Iterator (IOSim s) TestBlock TestBlock
it
[TraceIteratorEvent TestBlock]
trace <- IOSim s [TraceIteratorEvent TestBlock]
getTrace
([TraceIteratorEvent TestBlock], IterRes)
-> IOSim s ([TraceIteratorEvent TestBlock], IterRes)
forall a. a -> IOSim s a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TraceIteratorEvent TestBlock]
trace, IterRes
res)
where
consume :: Monad m
=> Iterator m TestBlock TestBlock
-> m [Either (RealPoint TestBlock) TestBlock]
consume :: forall (m :: * -> *).
Monad m =>
Iterator m TestBlock TestBlock
-> m [Either (RealPoint TestBlock) TestBlock]
consume Iterator m TestBlock TestBlock
it = Iterator m TestBlock TestBlock
-> m (IteratorResult TestBlock TestBlock)
forall (m :: * -> *) blk b.
Iterator m blk b -> m (IteratorResult blk b)
iteratorNext Iterator m TestBlock TestBlock
it m (IteratorResult TestBlock TestBlock)
-> (IteratorResult TestBlock TestBlock
-> m [Either (RealPoint TestBlock) TestBlock])
-> m [Either (RealPoint TestBlock) TestBlock]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
IteratorResult TestBlock
blk -> (TestBlock -> Either (RealPoint TestBlock) TestBlock
forall a b. b -> Either a b
Right TestBlock
blk Either (RealPoint TestBlock) TestBlock
-> [Either (RealPoint TestBlock) TestBlock]
-> [Either (RealPoint TestBlock) TestBlock]
forall a. a -> [a] -> [a]
:) ([Either (RealPoint TestBlock) TestBlock]
-> [Either (RealPoint TestBlock) TestBlock])
-> m [Either (RealPoint TestBlock) TestBlock]
-> m [Either (RealPoint TestBlock) TestBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Iterator m TestBlock TestBlock
-> m [Either (RealPoint TestBlock) TestBlock]
forall (m :: * -> *).
Monad m =>
Iterator m TestBlock TestBlock
-> m [Either (RealPoint TestBlock) TestBlock]
consume Iterator m TestBlock TestBlock
it
IteratorBlockGCed RealPoint TestBlock
hash -> do
Iterator m TestBlock TestBlock -> m ()
forall (m :: * -> *) blk b. Iterator m blk b -> m ()
iteratorClose Iterator m TestBlock TestBlock
it
[Either (RealPoint TestBlock) TestBlock]
-> m [Either (RealPoint TestBlock) TestBlock]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [RealPoint TestBlock -> Either (RealPoint TestBlock) TestBlock
forall a b. a -> Either a b
Left RealPoint TestBlock
hash]
IteratorResult TestBlock TestBlock
IteratorExhausted -> do
Iterator m TestBlock TestBlock -> m ()
forall (m :: * -> *) blk b. Iterator m blk b -> m ()
iteratorClose Iterator m TestBlock TestBlock
it
[Either (RealPoint TestBlock) TestBlock]
-> m [Either (RealPoint TestBlock) TestBlock]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
initIteratorEnv ::
forall m. IOLike m
=> TestSetup
-> Tracer m (TraceIteratorEvent TestBlock)
-> m (IteratorEnv m TestBlock)
initIteratorEnv :: forall (m :: * -> *).
IOLike m =>
TestSetup
-> Tracer m (TraceIteratorEvent TestBlock)
-> m (IteratorEnv m TestBlock)
initIteratorEnv TestSetup { Chain TestBlock
immutable :: TestSetup -> Chain TestBlock
immutable :: Chain TestBlock
immutable, [TestBlock]
volatile :: TestSetup -> [TestBlock]
volatile :: [TestBlock]
volatile } Tracer m (TraceIteratorEvent TestBlock)
tracer = do
StrictTVar m (Map IteratorKey (m ()))
iters <- Map IteratorKey (m ()) -> m (StrictTVar m (Map IteratorKey (m ())))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map IteratorKey (m ())
forall k a. Map k a
Map.empty
StrictTVar m IteratorKey
nextIterKey <- IteratorKey -> m (StrictTVar m IteratorKey)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM (IteratorKey -> m (StrictTVar m IteratorKey))
-> IteratorKey -> m (StrictTVar m IteratorKey)
forall a b. (a -> b) -> a -> b
$ Word -> IteratorKey
IteratorKey Word
0
VolatileDB m TestBlock
volatileDB <- [TestBlock] -> m (VolatileDB m TestBlock)
openVolatileDB [TestBlock]
volatile
ImmutableDB m TestBlock
immutableDB <- Chain TestBlock -> m (ImmutableDB m TestBlock)
openImmutableDB Chain TestBlock
immutable
IteratorEnv m TestBlock -> m (IteratorEnv m TestBlock)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IteratorEnv
{ itImmutableDB :: ImmutableDB m TestBlock
itImmutableDB = ImmutableDB m TestBlock
immutableDB
, itVolatileDB :: VolatileDB m TestBlock
itVolatileDB = VolatileDB m TestBlock
volatileDB
, itIterators :: StrictTVar m (Map IteratorKey (m ()))
itIterators = StrictTVar m (Map IteratorKey (m ()))
iters
, itNextIteratorKey :: StrictTVar m IteratorKey
itNextIteratorKey = StrictTVar m IteratorKey
nextIterKey
, itTracer :: Tracer m (TraceIteratorEvent TestBlock)
itTracer = Tracer m (TraceIteratorEvent TestBlock)
tracer
}
where
openVolatileDB :: [TestBlock] -> m (VolatileDB m TestBlock)
openVolatileDB :: [TestBlock] -> m (VolatileDB m TestBlock)
openVolatileDB [TestBlock]
blocks = do
(DBModel TestBlock
_volatileDBModel, VolatileDB m TestBlock
volatileDB) <-
BlocksPerFile
-> CodecConfig TestBlock
-> m (DBModel TestBlock, VolatileDB m TestBlock)
forall (m :: * -> *) blk.
(IOLike m, GetPrevHash blk, HasBinaryBlockInfo blk,
EncodeDisk blk blk, HasNestedContent Header blk) =>
BlocksPerFile
-> CodecConfig blk -> m (DBModel blk, VolatileDB m blk)
VolatileDB.openDBMock
(Word32 -> BlocksPerFile
VolatileDB.mkBlocksPerFile Word32
1)
CodecConfig TestBlock
TestBlockCodecConfig
[TestBlock] -> (TestBlock -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TestBlock]
blocks ((TestBlock -> m ()) -> m ()) -> (TestBlock -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ VolatileDB m TestBlock -> HasCallStack => TestBlock -> m ()
forall (m :: * -> *) blk.
VolatileDB m blk -> HasCallStack => blk -> m ()
VolatileDB.putBlock VolatileDB m TestBlock
volatileDB
VolatileDB m TestBlock -> m (VolatileDB m TestBlock)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return VolatileDB m TestBlock
volatileDB
epochSize :: EpochSize
epochSize :: EpochSize
epochSize = EpochSize
10
openImmutableDB :: Chain TestBlock -> m (ImmutableDB m TestBlock)
openImmutableDB :: Chain TestBlock -> m (ImmutableDB m TestBlock)
openImmutableDB Chain TestBlock
chain = do
(DBModel TestBlock
_immutableDBModel, ImmutableDB m TestBlock
immutableDB) <-
ChunkInfo
-> CodecConfig TestBlock
-> m (DBModel TestBlock, ImmutableDB m TestBlock)
forall (m :: * -> *) blk.
(HasHeader blk, GetHeader blk, EncodeDisk blk blk,
HasNestedContent Header blk, EncodeDiskDep (NestedCtxt Header) blk,
IOLike m) =>
ChunkInfo -> CodecConfig blk -> m (DBModel blk, ImmutableDB m blk)
ImmutableDB.openDBMock
ChunkInfo
chunkInfo
CodecConfig TestBlock
TestBlockCodecConfig
(TestBlock -> m ()) -> [TestBlock] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ImmutableDB m TestBlock -> TestBlock -> m ()
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> blk -> m ()
ImmutableDB.appendBlock ImmutableDB m TestBlock
immutableDB) (Chain TestBlock -> [TestBlock]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain TestBlock
chain)
ImmutableDB m TestBlock -> m (ImmutableDB m TestBlock)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ImmutableDB m TestBlock
immutableDB
where
chunkInfo :: ChunkInfo
chunkInfo = EpochSize -> ChunkInfo
ImmutableDB.simpleChunkInfo EpochSize
epochSize