diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 919592ee3de..76b2c793091 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -296,6 +296,7 @@ test-suite test-consensus Test.Consensus.ChainSyncClient Test.Consensus.Ledger.Byron Test.Consensus.Ledger.Mock + Test.Consensus.LocalStateQueryServer Test.Consensus.Mempool Test.Consensus.Mempool.TestBlock Test.Consensus.Mempool.TestTx diff --git a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LgrDB.hs index b66cab9a3ec..8240b39009b 100644 --- a/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LgrDB.hs +++ b/ouroboros-consensus/src/Ouroboros/Storage/ChainDB/Impl/LgrDB.hs @@ -48,6 +48,8 @@ module Ouroboros.Storage.ChainDB.Impl.LgrDB ( , LedgerDB.SwitchResult (..) , TraceEvent (..) , TraceReplayEvent (..) + -- * Exported for testing purposes + , mkLgrDB ) where import Codec.Serialise.Decoding (Decoder) @@ -268,6 +270,14 @@ initFromDisk args@LgrDbArgs{..} replayTracer lgrDbConf immDB = wrapFailure args (streamAPI immDB) return db +-- | For testing purposes +mkLgrDB :: Conf m blk + -> StrictTVar m (LedgerDB blk) + -> StrictTVar m (Set (Point blk)) + -> LgrDbArgs m blk + -> LgrDB m blk +mkLgrDB conf varDB varPrevApplied args = LgrDB {..} + {------------------------------------------------------------------------------- TraceReplayEvent decorator -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/test-consensus/Main.hs b/ouroboros-consensus/test-consensus/Main.hs index 1402428b7f9..d61cb32b6c0 100644 --- a/ouroboros-consensus/test-consensus/Main.hs +++ b/ouroboros-consensus/test-consensus/Main.hs @@ -7,6 +7,7 @@ import qualified Test.Consensus.BlockchainTime.WallClock (tests) import qualified Test.Consensus.ChainSyncClient (tests) import qualified Test.Consensus.Ledger.Byron (tests) import qualified Test.Consensus.Ledger.Mock (tests) +import qualified Test.Consensus.LocalStateQueryServer (tests) import qualified Test.Consensus.Mempool (tests) import qualified Test.Consensus.Node (tests) import qualified Test.Consensus.Protocol.PBFT (tests) @@ -32,6 +33,7 @@ tests = , Test.Consensus.ChainSyncClient.tests , Test.Consensus.Ledger.Byron.tests , Test.Consensus.Ledger.Mock.tests + , Test.Consensus.LocalStateQueryServer.tests , Test.Consensus.Mempool.tests , Test.Consensus.Node.tests , Test.Consensus.Protocol.PBFT.tests diff --git a/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs b/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs new file mode 100644 index 00000000000..df70a1b272c --- /dev/null +++ b/ouroboros-consensus/test-consensus/Test/Consensus/LocalStateQueryServer.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +module Test.Consensus.LocalStateQueryServer where + +import Control.Monad.Except (runExcept) +import Control.Tracer (nullTracer) +import Data.Map (Map) +import qualified Data.Map as Map + +import Control.Monad.IOSim (runSimOrThrow) + +import Cardano.Crypto.DSIGN.Mock + +import Network.TypedProtocol.Proofs (connect) +import Ouroboros.Network.Block (Point (..), SlotNo, blockPoint, + pointSlot) +import Ouroboros.Network.MockChain.Chain (Chain (..)) +import qualified Ouroboros.Network.MockChain.Chain as Chain +import Ouroboros.Network.Point (WithOrigin (..)) +import Ouroboros.Network.Protocol.LocalStateQuery.Client +import Ouroboros.Network.Protocol.LocalStateQuery.Examples + (localStateQueryClient) +import Ouroboros.Network.Protocol.LocalStateQuery.Server +import Ouroboros.Network.Protocol.LocalStateQuery.Type + (AcquireFailure (..)) + +import Ouroboros.Consensus.Block (BlockProtocol, getHeader) +import Ouroboros.Consensus.BlockchainTime.SlotLength + (slotLengthFromSec) +import Ouroboros.Consensus.BlockchainTime.SlotLengths + (singletonSlotLengths) +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.LocalStateQueryServer +import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..)) +import Ouroboros.Consensus.NodeId +import Ouroboros.Consensus.Protocol.Abstract (NodeConfig, + SecurityParam (..)) +import Ouroboros.Consensus.Protocol.BFT +import Ouroboros.Consensus.Util ((.:)) +import Ouroboros.Consensus.Util.IOLike + +import qualified Ouroboros.Storage.ChainDB.Impl.LedgerCursor as LedgerCursor +import Ouroboros.Storage.ChainDB.Impl.LgrDB (LedgerDbParams (..), + LgrDB, LgrDbArgs (..), mkLgrDB) +import qualified Ouroboros.Storage.ChainDB.Impl.LgrDB as LgrDB +import Ouroboros.Storage.LedgerDB.Conf (LedgerDbConf (..)) +import qualified Ouroboros.Storage.LedgerDB.InMemory as LgrDB + (ledgerDbFromGenesis) + +import Test.QuickCheck hiding (Result) +import Test.Tasty +import Test.Tasty.QuickCheck + +import Test.Util.Orphans.IOLike () +import Test.Util.TestBlock + + +{------------------------------------------------------------------------------- + Top-level tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "LocalStateQueryServer" + [ testProperty "localStateQueryServer" prop_localStateQueryServer + ] + +{------------------------------------------------------------------------------- + Main property +-------------------------------------------------------------------------------} + +-- | Plan: +-- * Preseed the LgrDB of the server with the preferred chain of the +-- 'BlockTree'. +-- * Acquire for each block in the 'BlockTree', including the ones not on the +-- chain, a state and send the 'QueryLedgerTip'. Collect these results. +-- * Check that when acquiring failed, it rightfully failed. Otherwise, check +-- whether the returned tip matches the block. +prop_localStateQueryServer + :: SecurityParam + -> BlockTree + -> Permutation + -> Property +prop_localStateQueryServer k bt p = checkOutcome k chain actualOutcome + where + chain :: Chain TestBlock + chain = treePreferredChain (testCfg k) bt + + points :: [Point TestBlock] + points = blockPoint <$> permute p (treeToBlocks bt) + + actualOutcome = runSimOrThrow $ do + let client = mkClient points + server <- mkServer k chain + (\(a, _, _) -> a) <$> + connect + (localStateQueryClientPeer client) + (localStateQueryServerPeer server) + +{------------------------------------------------------------------------------- + Test setup +-------------------------------------------------------------------------------} + +-- | Checks whether the given outcome is correct: in case of an +-- 'AcquireFailure', we check whether it was warranted. Otherwise we check +-- whether the results are correct. +-- +-- NOTE: when we don't get an 'AcquireFailure', even though we expected it, we +-- accept it. This is because the LgrDB may contain snapshots for blocks on +-- the current chain older than @k@, but we do not want to imitate such +-- implementation details. +-- +-- Additionally, this function labels the test results. +checkOutcome + :: SecurityParam + -> Chain TestBlock + -> [(Point TestBlock, Either AcquireFailure [Result TestBlock])] + -> Property +checkOutcome k chain = conjoin . map (uncurry checkResult) + where + immutableSlot :: WithOrigin SlotNo + immutableSlot = Chain.headSlot $ + Chain.drop (fromIntegral (maxRollbacks k)) chain + + checkResult + :: Point TestBlock + -> Either AcquireFailure [Result TestBlock] + -> Property + checkResult pt = \case + Right results + -> tabulate "Acquired" ["Success"] $ results === [ResultLedgerTip pt] + Left AcquireFailurePointNotOnChain + | Chain.pointOnChain pt chain + -> counterexample + ("Point " <> show pt <> + " on chain, but got AcquireFailurePointNotOnChain") + (property False) + | otherwise + -> tabulate "Acquired" ["AcquireFailurePointNotOnChain"] $ property True + Left AcquireFailurePointTooOld + | pointSlot pt >= immutableSlot + -> counterexample + ("Point " <> show pt <> + " newer than the immutable tip, but got AcquireFailurePointTooOld") + (property False) + | otherwise + -> tabulate "Acquired" ["AcquireFailurePointTooOld"] $ property True + +mkClient + :: Monad m + => [Point TestBlock] + -> LocalStateQueryClient + TestBlock + (Query TestBlock) + (Result TestBlock) + m + [(Point TestBlock, Either AcquireFailure [Result TestBlock])] +mkClient points = localStateQueryClient [(pt, [QueryLedgerTip]) | pt <- points] + +mkServer + :: IOLike m + => SecurityParam + -> Chain TestBlock + -> m (LocalStateQueryServer TestBlock (Query TestBlock) (Result TestBlock) m ()) +mkServer k chain = do + lgrDB <- initLgrDB k chain + return $ localStateQueryServer $ LedgerCursor.newLedgerCursor lgrDB getImmutablePoint + where + getImmutablePoint = return $ Chain.headPoint $ + Chain.drop (fromIntegral (maxRollbacks k)) chain + +-- | Initialise a 'LgrDB' with the given chain. +initLgrDB + :: forall m. IOLike m + => SecurityParam + -> Chain TestBlock + -> m (LgrDB m TestBlock) +initLgrDB k chain = do + varDB <- newTVarM genesisLedgerDB + varPrevApplied <- newTVarM mempty + let lgrDB = mkLgrDB conf varDB varPrevApplied args + LgrDB.validate lgrDB genesisLedgerDB 0 + (map getHeader (Chain.toOldestFirst chain)) >>= \case + LgrDB.MaximumRollbackExceeded {} -> + error "rollback was 0" + LgrDB.RollbackSuccessful (LgrDB.InvalidBlock {}) -> + error "there were no invalid blocks" + LgrDB.RollbackSuccessful (LgrDB.ValidBlocks ledgerDB') -> do + atomically $ LgrDB.setCurrent lgrDB ledgerDB' + return lgrDB + where + blockMapping :: Map (Point TestBlock) TestBlock + blockMapping = Map.fromList + [(blockPoint b, b) | b <- Chain.toOldestFirst chain] + + params :: LedgerDbParams + params = LedgerDbParams + { ledgerDbSnapEvery = maxRollbacks k + , ledgerDbSecurityParam = k + } + + cfg = testCfg k + + conf = LedgerDbConf + { ldbConfGenesis = return testInitExtLedger + , ldbConfApply = runExcept .: + applyExtLedgerState BlockNotPreviouslyApplied cfg + , ldbConfReapply = (mustBeRight . runExcept) .: + applyExtLedgerState BlockPreviouslyApplied cfg + , ldbConfResolve = return . (blockMapping Map.!) + } + + mustBeRight (Left e) = error $ "impossible: " <> show e + mustBeRight (Right a) = a + + genesisLedgerDB = LgrDB.ledgerDbFromGenesis params testInitExtLedger + + args = LgrDbArgs + { lgrNodeConfig = cfg + , lgrHasFS = error "lgrHasFS" + , lgrDecodeLedger = error "lgrDecodeLedger" + , lgrDecodeChainState = error "lgrDecodeChainState" + , lgrDecodeHash = error "lgrDecodeHash" + , lgrEncodeLedger = error "lgrEncodeLedger" + , lgrEncodeChainState = error "lgrEncodeChainState" + , lgrEncodeHash = error "lgrEncodeHash" + , lgrParams = params + , lgrDiskPolicy = error "lgrDiskPolicy" + , lgrGenesis = return testInitExtLedger + , lgrTracer = nullTracer + , lgrTraceLedger = nullTracer + } + +testCfg :: SecurityParam -> NodeConfig (BlockProtocol TestBlock) +testCfg securityParam = BftNodeConfig + { bftParams = BftParams { bftSecurityParam = securityParam + , bftNumNodes = NumCoreNodes 1 + , bftSlotLengths = singletonSlotLengths $ + slotLengthFromSec 20 + } + , bftNodeId = CoreId (CoreNodeId 0) + , bftSignKey = SignKeyMockDSIGN 0 + , bftVerKeys = Map.singleton (CoreId (CoreNodeId 0)) (VerKeyMockDSIGN 0) + } + + +{------------------------------------------------------------------------------- + Orphans +-------------------------------------------------------------------------------} + +instance Arbitrary SecurityParam where + arbitrary = SecurityParam <$> choose (1, 100) + shrink (SecurityParam k) = [SecurityParam k' | k' <- shrink k, k' > 0]