Merge pull request #3216 from input-output-hk/coot/cbr-96-benchmarks

[CBR-96] Block verification benchmarks

Author: coot

block/cardano-sl-block.cabal

@@ -43,6 +43,8 @@ library
                       , ether
                       , formatting
                       , lens
+                      , log-warper
+                      , mmorph
                       , mtl
                       , reflection
                       , safe-exceptions

block/src/Pos/Block/Error.hs

@@ -51,7 +51,9 @@ data ApplyBlocksException
         HeaderHash -- attempted tip
     | ApplyBlocksVerifyFailure VerifyBlocksException
     | ApplyBlocksError Text -- other error (not covered by constructors above)
-    deriving (Show)
+    deriving (Show, Generic)
+
+instance NFData ApplyBlocksException
 
 renderApplyBlocksException :: ApplyBlocksException -> Builder
 renderApplyBlocksException = \case

block/src/Pos/Block/Logic/Integrity.hs

@@ -12,6 +12,7 @@ module Pos.Block.Logic.Integrity
 
          -- * Block
        , VerifyBlockParams (..)
+       , verifyBlock
        , verifyBlocks
        ) where
 
@@ -61,7 +62,9 @@ data VerifyHeaderParams = VerifyHeaderParams
       -- ^ Maximal allowed header size. It's applied to 'BlockHeader'.
     , vhpVerifyNoUnknown :: !Bool
       -- ^ Check that header has no unknown attributes.
-    } deriving (Eq, Show)
+    } deriving (Eq, Show, Generic)
+
+instance NFData VerifyHeaderParams
 
 verifyFromEither :: Text -> Either Text b -> VerificationRes
 verifyFromEither txt (Left reason) = verifyGeneric [(False, txt <> ": " <> reason)]
@@ -246,7 +249,9 @@ data VerifyBlockParams = VerifyBlockParams
     -- is either main or genesis block).
     , vbpVerifyNoUnknown :: !Bool
     -- ^ Check that block has no unknown attributes.
-    }
+    } deriving (Generic)
+
+instance NFData VerifyBlockParams
 
 -- CHECK: @verifyBlock
 -- | Check predicates defined by VerifyBlockParams.

block/test/Test/Pos/Block/BlockSpec.hs

@@ -42,7 +42,7 @@ import           Test.Pos.Crypto.Dummy (dummyProtocolMagic)
 
 -- This tests are quite slow, hence max success is at most 20.
 spec :: Spec
-spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ ->
+spec = withGenesisSpec 0 defaultCoreConfiguration id $ \_ ->
     describe "Block properties" $ modifyMaxSuccess (min 20) $ do
         describe "mkMainHeader" $ do
             prop mainHeaderFormationDesc mainHeaderFormation

block/test/Test/Pos/Block/CborSpec.hs

@@ -18,7 +18,7 @@ import           Test.Pos.Block.Arbitrary ()
 import           Test.Pos.Core.Arbitrary ()
 
 spec :: Spec
-spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ ->
+spec = withGenesisSpec 0 defaultCoreConfiguration id $ \_ ->
     describe "Cbor.Bi instances" $ do
         -- These data types are defined in the 'core' package which suggests that
         -- these tests should be there, but they depend on type in eg 'update' so

block/test/Test/Pos/Block/SafeCopySpec.hs

@@ -17,7 +17,7 @@ import           Test.Pos.Binary.Helpers (safeCopyTest)
 import           Test.Pos.Block.Arbitrary ()
 
 spec :: Spec
-spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ -> describe "Block types" $ do
+spec = withGenesisSpec 0 defaultCoreConfiguration id $ \_ -> describe "Block types" $ do
     -- These types are defined in 'core' but the 'Arbitrary' instances require
     -- generator components defined in package like 'ssc' and 'update' which
     -- means these tests cannot be moved to 'core'.

core/src/Pos/Core/Configuration.hs

@@ -79,6 +79,8 @@ withCoreConfigurations
        , MonadIO m
        )
     => CoreConfiguration
+    -> (GenesisData -> GenesisData)
+    -- ^ Update @'GenesisData'@ before passing its parts to @'given'@.
     -> FilePath
     -- ^ Directory where 'configuration.yaml' is stored.
     -> Maybe Timestamp
@@ -89,7 +91,7 @@ withCoreConfigurations
     -- provided.
     -> (HasConfiguration => ProtocolMagic -> m r)
     -> m r
-withCoreConfigurations conf@CoreConfiguration{..} confDir mSystemStart mSeed act = case ccGenesis of
+withCoreConfigurations conf@CoreConfiguration{..} fn confDir mSystemStart mSeed act = case ccGenesis of
     -- If a 'GenesisData' source file is given, we check its hash against the
     -- given expected hash, parse it, and use the GenesisData to fill in all of
     -- the obligations.
@@ -106,7 +108,7 @@ withCoreConfigurations conf@CoreConfiguration{..} confDir mSystemStart mSeed act
 
         theGenesisData <- case Canonical.fromJSON gdataJSON of
             Left err -> throwM $ GenesisDataSchemaError err
-            Right it -> return it
+            Right it -> return $ fn it
 
         let (_, theGenesisHash) = canonicalGenesisJson theGenesisData
             pc = genesisProtocolConstantsToProtocolConstants (gdProtocolConsts theGenesisData)
@@ -144,14 +146,15 @@ withCoreConfigurations conf@CoreConfiguration{..} confDir mSystemStart mSeed act
 
         let theConf = conf {ccGenesis = GCSpec theSpec}
 
-        withGenesisSpec theSystemStart theConf act
+        withGenesisSpec theSystemStart theConf fn act
 
 withGenesisSpec
     :: Timestamp
     -> CoreConfiguration
+    -> (GenesisData -> GenesisData)
     -> (HasConfiguration => ProtocolMagic -> r)
     -> r
-withGenesisSpec theSystemStart conf@CoreConfiguration{..} val = case ccGenesis of
+withGenesisSpec theSystemStart conf@CoreConfiguration{..} fn val = case ccGenesis of
     GCSrc {} -> error "withGenesisSpec called with GCSrc"
     GCSpec spec ->
         withProtocolConstants pc $
@@ -168,7 +171,7 @@ withGenesisSpec theSystemStart conf@CoreConfiguration{..} val = case ccGenesis o
                     (toList $ gsHeavyDelegation spec) <> toList ggdDelegation
 
                 -- Construct the final value
-                theGenesisData =
+                theGenesisData = fn $
                    GenesisData
                       { gdBootStakeholders = ggdBootStakeholders
                       , gdHeavyDelegation  = finalHeavyDelegation

core/test/Test/Pos/Core/CborSpec.hs

@@ -83,7 +83,7 @@ instance Bi (Attributes X2) where
 
 
 spec :: Spec
-spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ ->
+spec = withGenesisSpec 0 defaultCoreConfiguration id $ \_ ->
     describe "Cbor Bi instances" $ do
         describe "Core.Address" $ do
             binaryTest @Address

core/test/Test/Pos/Core/SlottingSpec.hs

@@ -20,7 +20,7 @@ import           Test.Pos.Core.Arbitrary (EoSToIntOverflow (..),
 import           Test.Pos.Util.QuickCheck.Property (shouldThrowException, (.=.))
 
 spec :: Spec
-spec = withGenesisSpec 0 defaultCoreConfiguration $ \_ -> describe "Slotting" $ do
+spec = withGenesisSpec 0 defaultCoreConfiguration id $ \_ -> describe "Slotting" $ do
     describe "SlotId" $ do
         describe "Ord" $ do
             prop "is consistent with flatten/unflatten"

db/cardano-sl-db.cabal

@@ -112,6 +112,7 @@ library
                        Pos.DB.Block.Logic.Creation
                        Pos.DB.Block.Logic.Header
                        Pos.DB.Block.Logic.Internal
+                       Pos.DB.Block.Logic.Types
                        Pos.DB.Block.Logic.Util
                        Pos.DB.Block.Logic.VAR
                        Pos.DB.Block.Lrc

db/src/Pos/DB/Block.hs

@@ -69,6 +69,7 @@ import           Pos.DB.Block.Load as X
 import           Pos.DB.Block.Logic.Creation as X
 import           Pos.DB.Block.Logic.Header as X
 import           Pos.DB.Block.Logic.Internal as X
+import           Pos.DB.Block.Logic.Types as X
 import           Pos.DB.Block.Logic.Util as X
 import           Pos.DB.Block.Logic.VAR as X
 import           Pos.DB.Block.Lrc as X

db/src/Pos/DB/Block/Logic/Creation.hs

@@ -47,6 +47,8 @@ import           Pos.Core.Util.LogSafe (logInfoS)
 import           Pos.Crypto (ProtocolMagic, SecretKey)
 import           Pos.DB.Block.Logic.Internal (MonadBlockApply,
                      applyBlocksUnsafe, normalizeMempool)
+import           Pos.DB.Block.Logic.Types (VerifyBlocksContext (..),
+                     getVerifyBlocksContext)
 import           Pos.DB.Block.Logic.Util (calcChainQualityM)
 import           Pos.DB.Block.Logic.VAR (verifyBlocksPrefix)
 import           Pos.DB.Block.Lrc (LrcModeFull, lrcSingleShot)
@@ -161,11 +163,17 @@ createGenesisBlockDo pm epoch = do
             LrcDB.getLeadersForEpoch
         let blk = mkGenesisBlock pm (Right tipHeader) epoch leaders
         let newTip = headerHash blk
-        verifyBlocksPrefix pm (one (Left blk)) >>= \case
+        ctx <- getVerifyBlocksContext
+        verifyBlocksPrefix pm ctx (one (Left blk)) >>= \case
             Left err -> reportFatalError $ pretty err
             Right (undos, pollModifier) -> do
                 let undo = undos ^. _Wrapped . _neHead
-                applyBlocksUnsafe pm (ShouldCallBListener True) (one (Left blk, undo)) (Just pollModifier)
+                applyBlocksUnsafe pm
+                    (vbcBlockVersion ctx)
+                    (vbcBlockVersionData ctx)
+                    (ShouldCallBListener True)
+                    (one (Left blk, undo))
+                    (Just pollModifier)
                 normalizeMempool pm
                 pure (newTip, Just blk)
     logShouldNot =
@@ -358,15 +366,18 @@ applyCreatedBlock pm pske createdBlock = applyCreatedBlockDo False createdBlock
   where
     slotId = createdBlock ^. BC.mainBlockSlot
     applyCreatedBlockDo :: Bool -> MainBlock -> m MainBlock
-    applyCreatedBlockDo isFallback blockToApply =
-        verifyBlocksPrefix pm (one (Right blockToApply)) >>= \case
+    applyCreatedBlockDo isFallback blockToApply = do
+        ctx <- getVerifyBlocksContext
+        verifyBlocksPrefix pm ctx (one (Right blockToApply)) >>= \case
             Left (pretty -> reason)
                 | isFallback -> onFailedFallback reason
                 | otherwise -> fallback reason
             Right (undos, pollModifier) -> do
                 let undo = undos ^. _Wrapped . _neHead
                 applyBlocksUnsafe
                     pm
+                    (vbcBlockVersion ctx)
+                    (vbcBlockVersionData ctx)
                     (ShouldCallBListener True)
                     (one (Right blockToApply, undo))
                     (Just pollModifier)

db/src/Pos/DB/Block/Logic/Internal.hs

@@ -41,6 +41,7 @@ import           Pos.Core.Block (Block, ComponentBlock (..), GenesisBlock,
 import           Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..))
 import           Pos.Core.Exception (assertionFailed)
 import           Pos.Core.Reporting (MonadReporting)
+import           Pos.Core.Update (BlockVersion, BlockVersionData)
 import           Pos.Crypto (ProtocolMagic)
 import           Pos.DB (MonadDB, MonadDBRead, MonadGState, SomeBatchOp (..))
 import           Pos.DB.Block.BListener (MonadBListener)
@@ -143,11 +144,13 @@ applyBlocksUnsafe
        , HasTxpConfiguration
        )
     => ProtocolMagic
+    -> BlockVersion
+    -> BlockVersionData
     -> ShouldCallBListener
     -> OldestFirst NE Blund
     -> Maybe PollModifier
     -> m ()
-applyBlocksUnsafe pm scb blunds pModifier = do
+applyBlocksUnsafe pm bv bvd scb blunds pModifier = do
     -- Check that all blunds have the same epoch.
     unless (null nextEpoch) $ assertionFailed $
         sformat ("applyBlocksUnsafe: tried to apply more than we should"%
@@ -167,7 +170,7 @@ applyBlocksUnsafe pm scb blunds pModifier = do
         (b@(Left _,_):|(x:xs)) -> app' (b:|[]) >> app' (x:|xs)
         _                      -> app blunds
   where
-    app x = applyBlocksDbUnsafeDo pm scb x pModifier
+    app x = applyBlocksDbUnsafeDo pm bv bvd scb x pModifier
     app' = app . OldestFirst
     (thisEpoch, nextEpoch) =
         spanSafe ((==) `on` view (_1 . epochIndexL)) $ getOldestFirst blunds
@@ -177,22 +180,24 @@ applyBlocksDbUnsafeDo
        , HasTxpConfiguration
        )
     => ProtocolMagic
+    -> BlockVersion
+    -> BlockVersionData
     -> ShouldCallBListener
     -> OldestFirst NE Blund
     -> Maybe PollModifier
     -> m ()
-applyBlocksDbUnsafeDo pm scb blunds pModifier = do
+applyBlocksDbUnsafeDo pm bv bvd scb blunds pModifier = do
     let blocks = fmap fst blunds
     -- Note: it's important to do 'slogApplyBlocks' first, because it
     -- puts blocks in DB.
     slogBatch <- slogApplyBlocks scb blunds
     TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings)
-    usBatch <- SomeBatchOp <$> usApplyBlocks pm (map toUpdateBlock blocks) pModifier
+    usBatch <- SomeBatchOp <$> usApplyBlocks pm bv (map toUpdateBlock blocks) pModifier
     delegateBatch <- SomeBatchOp <$> dlgApplyBlocks (map toDlgBlund blunds)
     txpBatch <- tgsApplyBlocks $ map toTxpBlund blunds
     sscBatch <- SomeBatchOp <$>
         -- TODO: pass not only 'Nothing'
-        sscApplyBlocks pm (map toSscBlock blocks) Nothing
+        sscApplyBlocks pm bvd (map toSscBlock blocks) Nothing
     GS.writeBatchGState
         [ delegateBatch
         , usBatch

db/src/Pos/DB/Block/Logic/Types.hs

@@ -0,0 +1,41 @@
+module Pos.DB.Block.Logic.Types
+    ( VerifyBlocksContext (..)
+    , getVerifyBlocksContext
+    , getVerifyBlocksContext'
+    ) where
+
+import           Universum
+
+import           Pos.Core.Slotting (MonadSlots (getCurrentSlot), SlotId)
+import           Pos.Core.Update (BlockVersion, BlockVersionData)
+import           Pos.DB.Class (MonadDBRead)
+import           Pos.DB.Update (getAdoptedBVFull)
+
+-- | Initial context for `verifyBlocksPrefix` which runs in `MonadBlockVerify`
+-- monad.
+data VerifyBlocksContext = VerifyBlocksContext
+    { vbcCurrentSlot      :: !(Maybe SlotId)
+      -- ^ used to check if headers are not from future
+    , vbcBlockVersion     :: !BlockVersion
+    , vbcBlockVersionData :: !BlockVersionData
+    } deriving Generic
+
+instance NFData VerifyBlocksContext
+
+getVerifyBlocksContext
+    :: forall ctx m.
+       ( MonadDBRead m
+       , MonadSlots ctx m
+       )
+    => m VerifyBlocksContext
+getVerifyBlocksContext =
+    getCurrentSlot >>= getVerifyBlocksContext'
+
+getVerifyBlocksContext'
+    :: MonadDBRead m
+    => Maybe SlotId
+    -> m VerifyBlocksContext
+getVerifyBlocksContext' vbcCurrentSlot = do
+    (vbcBlockVersion, vbcBlockVersionData) <- getAdoptedBVFull
+    return $ VerifyBlocksContext {..}
+