From 13214d29ba6dfea885cacd4599341533adeff8e3 Mon Sep 17 00:00:00 2001 From: Thomas Winant Date: Mon, 22 Jul 2019 14:57:36 +0200 Subject: [PATCH] ChainDB: add initial tests for the iterators Currently, these are only unit tests. In the future, we will write a generator and turn them into property tests. --- ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Test/Ouroboros/Storage/ChainDB.hs | 2 + .../Ouroboros/Storage/ChainDB/Iterator.hs | 301 ++++++++++++++++++ 3 files changed, 304 insertions(+) create mode 100644 ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Iterator.hs diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index cc01012ec72..8c73e3ce83c 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -295,6 +295,7 @@ test-suite test-storage Test.Ouroboros.Storage Test.Ouroboros.Storage.ChainDB Test.Ouroboros.Storage.ChainDB.AddBlock + Test.Ouroboros.Storage.ChainDB.Iterator Test.Ouroboros.Storage.ChainDB.Mock Test.Ouroboros.Storage.ChainDB.Model Test.Ouroboros.Storage.ChainDB.StateMachine diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB.hs index 0bf9795da3f..98d653fc523 100644 --- a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB.hs +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB.hs @@ -5,6 +5,7 @@ module Test.Ouroboros.Storage.ChainDB ( import Test.Tasty import qualified Test.Ouroboros.Storage.ChainDB.AddBlock as AddBlock +import qualified Test.Ouroboros.Storage.ChainDB.Iterator as Iterator import qualified Test.Ouroboros.Storage.ChainDB.Mock as Mock import qualified Test.Ouroboros.Storage.ChainDB.Model as Model import qualified Test.Ouroboros.Storage.ChainDB.StateMachine as StateMachine @@ -12,6 +13,7 @@ import qualified Test.Ouroboros.Storage.ChainDB.StateMachine as StateMachine tests :: TestTree tests = testGroup "ChainDB" [ AddBlock.tests + , Iterator.tests , Model.tests , Mock.tests , StateMachine.tests diff --git a/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Iterator.hs b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Iterator.hs new file mode 100644 index 00000000000..a67b67fe206 --- /dev/null +++ b/ouroboros-consensus/test-storage/Test/Ouroboros/Storage/ChainDB/Iterator.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Test.Ouroboros.Storage.ChainDB.Iterator + ( tests + ) where + +import Test.Tasty +import Test.Tasty.QuickCheck + +import Codec.Serialise (decode, encode, serialiseIncremental) +import Control.Monad.Except +import Control.Tracer +import Data.List (intercalate) +import qualified Data.Map.Strict as Map +import Data.Word (Word64) + +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Monad.IOSim (runSimOrThrow) + +import Ouroboros.Network.Block (ChainHash (..), HasHeader (..), + HeaderHash, SlotNo (..), blockPoint) +import Ouroboros.Network.Chain (Chain) +import qualified Ouroboros.Network.Chain as Chain + +import Ouroboros.Consensus.Util.Condense (condense) + +import Ouroboros.Storage.ChainDB.API (Iterator (..), IteratorId (..), + IteratorResult (..), StreamFrom (..), StreamTo (..), + UnknownRange) +import Ouroboros.Storage.ChainDB.Impl.ImmDB (ImmDB, mkImmDB) +import Ouroboros.Storage.ChainDB.Impl.Iterator (IteratorEnv (..), + newIterator) +import Ouroboros.Storage.ChainDB.Impl.Types (TraceIteratorEvent (..)) +import Ouroboros.Storage.ChainDB.Impl.VolDB (VolDB, mkVolDB) +import Ouroboros.Storage.Common (EpochSize) +import Ouroboros.Storage.EpochInfo (fixedSizeEpochInfo) +import qualified Ouroboros.Storage.ImmutableDB as ImmDB +import qualified Ouroboros.Storage.Util.ErrorHandling as EH +import qualified Ouroboros.Storage.VolatileDB as VolDB + + +import Test.Ouroboros.Storage.ChainDB.TestBlock +import qualified Test.Ouroboros.Storage.ImmutableDB.Mock as ImmDB (openDBMock) +import qualified Test.Ouroboros.Storage.VolatileDB.Mock as VolDB (openDBMock) + +{------------------------------------------------------------------------------- + Top-level tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Iterator" + [ testProperty "#773 bug in example 1" prop_773_bug + , testProperty "#773 correct example 2" prop_773_working + ] + +-- These tests focus on the implementation of the ChainDB iterators, which are +-- used to stream blocks from the ChainDB. A few things make this code +-- complex: +-- +-- * We need to be able to stream from both the ImmutableDB and the +-- VolatileDB. +-- * While streaming, blocks might be copied from the VolatileDB to the +-- ImmutableDB. +-- * While streaming, blocks might be garbage-collected from the VolatileDB. +-- These blocks might have been copied to the ImmutableDB or not. +-- +-- The copying and garbage collection will happen in the background, +-- /concurrently/ with the streaming, so we have to be careful about race +-- conditions. For these reasons, we provide separate tests for the ChainDb +-- iterators. +-- +-- To avoid the complexity of a whole ChainDB and to have explicit control of +-- the copying and garbage collection, we set up a mock 'IteratorEnv' record +-- containing (amongst others) a mock ImmutableDB and a mock VolatileDB that +-- can be manipulated directly, instead of relying on the background threads +-- to manipulate them for us. + +-- TODO: +-- - Write a generator for TestSetup and a model implementation (reuse +-- ChainDB.Model) to turn this into a property test. +-- - Instead of simply reading all blocks, use: +-- > data Action = IterNext .. | CopyToImmDB .. | GCFromVolDB .. +-- And write a generator for it. +-- - Run multiple @Action@s in parallel + +{------------------------------------------------------------------------------- + Test cases +-------------------------------------------------------------------------------} + +-- All blocks on the same chain +a, b, c, d, e :: TestBlock +a = mkBlk [0] +b = mkBlk [0,0] +c = mkBlk [0,0,0] +d = mkBlk [0,0,0,0] +e = mkBlk [0,0,0,0,0] + +-- | Requested stream = A -> C + +-- ImmDB VolDB +-- Hash A -> B -> C -> D C, D +-- +-- Bug: we find a partial path [B]->C in the VolDB. Now the ForkTooOld +-- condition is triggered because the tip of the ImmDB is not B but D. +-- +-- For more details, see: +-- https://github.com/input-output-hk/ouroboros-network/pull/773#issuecomment-513128004 +prop_773_bug :: Property +prop_773_bug = prop_general_test + TestSetup + { immutable = Chain.fromOldestFirst [a, b, c, d] + , volatile = [c, d] + } + (StreamFromInclusive (blockPoint a)) + (StreamToInclusive (blockPoint c)) + (Right (map Right [a, b, c])) + +-- | Requested stream = A -> E + +-- ImmDB VolDB +-- Hash A -> B -> C -> D C D E +-- +-- This was/is handled correctly in @streamFromBoth@. +prop_773_working :: Property +prop_773_working = prop_general_test + TestSetup + { immutable = Chain.fromOldestFirst [a, b, c, d] + , volatile = [c, d, e] + } + (StreamFromInclusive (blockPoint a)) + (StreamToInclusive (blockPoint e)) + (Right (map Right [a, b, c, d, e])) + +-- | The general property test +prop_general_test + :: TestSetup + -> StreamFrom TestBlock + -> StreamTo TestBlock + -> IterRes + -> Property +prop_general_test setup from to expected = + counterexample (testSetupInfo setup) $ + case (actual, expected) of + (Left actualErr, Left expectedErr) -> actualErr === expectedErr + (Left actualErr, Right expectedStream) -> failure $ + "Got " <> show actualErr <> "\nbut expected " <> ppStream expectedStream + (Right actualStream, Left expectedErr) -> failure $ + "Got " <> ppStream actualStream <> "\nbut expected " <> show expectedErr + (Right actualStream, Right expectedStream) + | actualStream == expectedStream + -> property True + | otherwise + -> failure $ "Got " <> ppStream actualStream <> "\nbut expected " <> + ppStream expectedStream + where + (_trace, actual) = runIterator setup from to + failure msg = counterexample msg False + + ppStream :: [Either (HeaderHash TestBlock) TestBlock] -> String + ppStream = intercalate " :> " . map ppEBBOrBlock + +{------------------------------------------------------------------------------- + Test setup +-------------------------------------------------------------------------------} + +-- | The initial contents of the ImmutableDB and the VolatileDB. +-- +-- Note that the iterator implementation does not rely on the current +-- in-memory chain. +data TestSetup = TestSetup + { immutable :: Chain TestBlock + , volatile :: [TestBlock] + } + +mkBlk :: [Word64] -> TestBlock +mkBlk h = TestBlock + { tbHash = mkTestHash h + , tbSlot = SlotNo $ fromIntegral $ 2 * length h + , tbValid = True + } + +-- | Human-friendly string description of the 'TestSetup' that can be used +-- when printing a failing test. +testSetupInfo :: TestSetup -> String +testSetupInfo TestSetup { immutable, volatile } = mconcat + [ "Immutable: " + , intercalate " :> " (map ppBlock (Chain.toOldestFirst immutable)) + , "\n" + , "Volatile: " + , intercalate ", " (map ppBlock volatile) + ] + +ppEBBOrBlock :: Either (HeaderHash TestBlock) TestBlock -> String +ppEBBOrBlock (Left ebbHash) = "EBB " <> condense ebbHash +ppEBBOrBlock (Right blk) = ppBlock blk + +ppBlock :: TestBlock -> String +ppBlock = condense . blockHash + +{------------------------------------------------------------------------------- + Running an iterator test +-------------------------------------------------------------------------------} + +type IterRes = Either (UnknownRange TestBlock) + [Either (HeaderHash TestBlock) TestBlock] + -- Left: EBB hash + -- Right: regular block + +-- | Open an iterator with the given bounds on the given 'TestSetup'. Return a +-- trace of the 'TraceIteratorEvent's produced and the result of the iterator +-- itself. +runIterator + :: TestSetup + -> StreamFrom TestBlock + -> StreamTo TestBlock + -> ([TraceIteratorEvent TestBlock], IterRes) +runIterator setup from to = runSimOrThrow $ do + (tracer, getTrace) <- recordTrace + itEnv <- initIteratorEnv setup tracer + res <- runExceptT $ do + it <- ExceptT $ newIterator itEnv ($ itEnv) from to + lift $ consume it + trace <- getTrace + return (trace, res) + where + consume :: Monad m + => Iterator m TestBlock + -> m [Either TestHash TestBlock] + consume it = iteratorNext it >>= \case + IteratorResult blk -> (Right blk :) <$> consume it + IteratorBlockGCed hash -> do + iteratorClose it + return [Left hash] + IteratorExhausted -> do + iteratorClose it + return [] + +recordTrace :: MonadSTM m => m (Tracer m ev, m [ev]) +recordTrace = newTVarM [] >>= \ref -> return + ( Tracer $ \ev -> atomically $ modifyTVar' ref (ev:) + , atomically $ reverse <$> readTVar ref + ) + +{------------------------------------------------------------------------------- + Setting up a mock IteratorEnv +-------------------------------------------------------------------------------} + +initIteratorEnv + :: forall m. + ( MonadSTM m + , MonadCatch m + , MonadThrow (STM m) + ) + => TestSetup + -> Tracer m (TraceIteratorEvent TestBlock) + -> m (IteratorEnv m TestBlock) +initIteratorEnv TestSetup { immutable, volatile } tracer = do + iters <- atomically $ newTVar Map.empty + nextIterId <- atomically $ newTVar $ IteratorId 0 + volDB <- openVolDB volatile + immDB <- openImmDB immutable + return IteratorEnv + { itImmDB = immDB + , itVolDB = volDB + , itIterators = iters + , itNextIteratorId = nextIterId + , itTracer = tracer + } + where + -- | Open a mock VolatileDB and add the given blocks + openVolDB :: [TestBlock] -> m (VolDB m TestBlock) + openVolDB blocks = do + (_volDBModel, volDB) <- VolDB.openDBMock EH.throwSTM 1 + forM_ blocks $ \block -> + VolDB.putBlock volDB (blockInfo block) (serialiseIncremental block) + return $ mkVolDB volDB decode encode + + blockInfo :: TestBlock -> VolDB.BlockInfo (HeaderHash TestBlock) + blockInfo tb = VolDB.BlockInfo + { VolDB.bbid = blockHash tb + , VolDB.bslot = blockSlot tb + , VolDB.bpreBid = case blockPrevHash tb of + GenesisHash -> Nothing + BlockHash h -> Just h + } + + epochSize :: EpochSize + epochSize = 10 + + -- | Open a mock ImmutableDB and add the given chain of blocks + openImmDB :: Chain TestBlock -> m (ImmDB m TestBlock) + openImmDB chain = do + (_immDBModel, immDB) <- ImmDB.openDBMock EH.monadCatch (const epochSize) + forM_ (Chain.toOldestFirst chain) $ \block -> + ImmDB.appendBinaryBlob immDB (blockSlot block) + (serialiseIncremental block) + let epochInfo = fixedSizeEpochInfo epochSize + return $ mkImmDB immDB decode encode epochInfo (const Nothing)