[#526] Add ValidationMode and utilize with ReaderT

input-output-hk · Jun 18, 2019 · b764abe · b764abe
1 parent 3265e42
commit b764abe
Show file tree

Hide file tree

Showing 13 changed files with 264 additions and 183 deletions.
diff --git a/cardano-ledger/cardano-ledger.cabal b/cardano-ledger/cardano-ledger.cabal
@@ -45,6 +45,7 @@ library
                        Cardano.Chain.UTxO.Validation
                        Cardano.Chain.Update
                        Cardano.Chain.Update.Validation.Interface
+                       Cardano.Chain.ValidationMode
 
   other-modules:
                        Cardano.Chain.Block.Block

diff --git a/cardano-ledger/src/Cardano/Chain/Block/Validation.hs b/cardano-ledger/src/Cardano/Chain/Block/Validation.hs
@@ -74,11 +74,6 @@ import Cardano.Chain.Block.Header
   , wrapBoundaryBytes
   )
 import Cardano.Chain.Block.Proof (Proof(..), ProofValidationError (..))
-import Cardano.Chain.Block.ValidationMode
-  ( BlockValidationMode
-  , toTxValidationMode
-  , whenBlockValidation
-  )
 import Cardano.Chain.Common
   ( BlockCount(..)
   , KeyHash
@@ -113,6 +108,12 @@ import Cardano.Crypto
   , hashRaw
   , hashDecoded
   )
+import Cardano.Chain.ValidationMode
+  ( ValidationMode
+  , orThrowErrorInBlockValidationMode
+  , whenBlockValidation
+  , wrapErrorWithValidationMode
+  )
 
 --------------------------------------------------------------------------------
 -- SigningHistory
@@ -288,15 +289,14 @@ data ChainValidationError
 --------------------------------------------------------------------------------
 
 updateChainBlockOrBoundary
-  :: MonadError ChainValidationError m
-  => BlockValidationMode
-  -> Genesis.Config
+  :: (MonadError ChainValidationError m, MonadReader ValidationMode m)
+  => Genesis.Config
   -> ChainValidationState
   -> ABlockOrBoundary ByteString
   -> m ChainValidationState
-updateChainBlockOrBoundary bvmode config c b = case b of
+updateChainBlockOrBoundary config c b = case b of
   ABOBBoundary bvd   -> updateChainBoundary c bvd
-  ABOBBlock    block -> updateBlock bvmode config c block
+  ABOBBlock    block -> updateBlock config c block
 
 
 updateChainBoundary
@@ -387,37 +387,30 @@ data BodyState = BodyState
 --   nor does it carry out anything which might be considered part of the
 --   protocol.
 updateBody
-  :: MonadError ChainValidationError m
-  => BlockValidationMode
-  -> BodyEnvironment
+  :: (MonadError ChainValidationError m, MonadReader ValidationMode m)
+  => BodyEnvironment
   -> BodyState
   -> ABlock ByteString
   -> m BodyState
-updateBody bvmode env bs b = do
+updateBody env bs b = do
   -- Validate the block size
-  whenBlockValidation bvmode $
-    blockLength b <= maxBlockSize
-      `orThrowError` ChainValidationBlockTooLarge maxBlockSize (blockLength b)
+  blockLength b <= maxBlockSize
+    `orThrowErrorInBlockValidationMode`
+      ChainValidationBlockTooLarge maxBlockSize (blockLength b)
 
   -- Validate the delegation, transaction, and update payload proofs.
-  whenBlockValidation bvmode $
-    validateBlockProofs b
-      `wrapError` ChainValidationProofValidationError
-
-  -- @intricate: How should we deal with the `BlockValidationMode` here?
-  --             When in the 'NoBlockValidation' mode, it shouldn't be possible
-  --             to return an error. Perhaps there should also be a
-  --             'DelegationValidationMode'?
+  whenBlockValidation (validateBlockProofs b)
+    `wrapErrorWithValidationMode` ChainValidationProofValidationError
+
   -- Update the delegation state
   delegationState' <-
     DI.updateDelegation delegationEnv delegationState certificates
       `wrapError` ChainValidationDelegationSchedulingError
 
   -- Update the UTxO
-  let tvmode = toTxValidationMode bvmode
   utxo' <-
-    UTxO.updateUTxO tvmode utxoEnv utxo txs
-      `wrapError` ChainValidationUTxOValidationError
+    UTxO.updateUTxO utxoEnv utxo txs
+      `wrapErrorWithValidationMode` ChainValidationUTxOValidationError
 
   -- Update the update state
   updateState' <-
@@ -484,17 +477,16 @@ data HeaderEnvironment = HeaderEnvironment
 
 -- | This is an implementation of the the BHEAD rule.
 updateHeader
-  :: MonadError ChainValidationError m
-  => BlockValidationMode
-  -> HeaderEnvironment
+  :: (MonadError ChainValidationError m, MonadReader ValidationMode m)
+  => HeaderEnvironment
   -> UPI.State
   -> AHeader ByteString
   -> m UPI.State
-updateHeader bvmode env st h = do
+updateHeader env st h = do
   -- Validate the header size
-  whenBlockValidation bvmode $
-    headerLength h <= maxHeaderSize
-      `orThrowError` ChainValidationHeaderTooLarge maxHeaderSize (headerLength h)
+  headerLength h <= maxHeaderSize
+    `orThrowErrorInBlockValidationMode`
+      ChainValidationHeaderTooLarge maxHeaderSize (headerLength h)
 
   -- Perform epoch transition
   pure $! epochTransition epochEnv st (headerSlot h)
@@ -559,23 +551,22 @@ epochTransition env st slot = if nextEpoch > currentEpoch
 --   Note that this also updates the previous block hash, which would usually be
 --   done as part of the PBFT rule.
 updateBlock
-  :: MonadError ChainValidationError m
-  => BlockValidationMode
-  -> Genesis.Config
+  :: (MonadError ChainValidationError m, MonadReader ValidationMode m)
+  => Genesis.Config
   -> ChainValidationState
   -> ABlock ByteString
   -> m ChainValidationState
-updateBlock bvmode config cvs b = do
+updateBlock config cvs b = do
 
   -- Compare the block's 'ProtocolMagic' to the configured value
-  whenBlockValidation bvmode $
-    blockProtocolMagicId b == configProtocolMagicId config
-      `orThrowError` ChainValidationProtocolMagicMismatch
-                      (blockProtocolMagicId b)
-                      (configProtocolMagicId config)
+  blockProtocolMagicId b == configProtocolMagicId config
+    `orThrowErrorInBlockValidationMode`
+      ChainValidationProtocolMagicMismatch
+        (blockProtocolMagicId b)
+        (configProtocolMagicId config)
 
   -- Update the header
-  updateState' <- updateHeader bvmode headerEnv (cvsUpdateState cvs) (blockHeader b)
+  updateState' <- updateHeader headerEnv (cvsUpdateState cvs) (blockHeader b)
 
   let
     bodyEnv = BodyEnvironment
@@ -594,7 +585,7 @@ updateBlock bvmode config cvs b = do
       , delegationState = cvsDelegationState cvs
       }
 
-  BodyState { utxo, updateState, delegationState } <- updateBody bvmode bodyEnv bs b
+  BodyState { utxo, updateState, delegationState } <- updateBody bodyEnv bs b
 
   pure $ cvs
     { cvsLastSlot     = blockSlot b
@@ -634,31 +625,28 @@ data Error
 
 -- | Fold transaction validation over a 'Stream' of 'Block's
 foldUTxO
-  :: BlockValidationMode
-  -> UTxO.Environment
+  :: UTxO.Environment
   -> UTxO
   -> Stream (Of (ABlock ByteString)) (ExceptT ParseError ResIO) ()
-  -> ExceptT Error ResIO UTxO
-foldUTxO bvmode env utxo blocks = S.foldM_
-  (foldUTxOBlock bvmode env)
+  -> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
+foldUTxO env utxo blocks = S.foldM_
+  (foldUTxOBlock env)
   (pure utxo)
   pure
-  (hoist (withExceptT ErrorParseError) blocks)
+  (pure (hoist (withExceptT ErrorParseError) blocks))
 
 -- | Fold 'updateUTxO' over the transactions in a single 'Block'
 foldUTxOBlock
-  :: BlockValidationMode
-  -> UTxO.Environment
+  :: UTxO.Environment
   -> UTxO
   -> ABlock ByteString
-  -> ExceptT Error ResIO UTxO
-foldUTxOBlock bvmode env utxo block =
-  let tvmode = toTxValidationMode bvmode
-  in withExceptT
-      (ErrorUTxOValidationError . fromSlotNumber mainnetEpochSlots $ blockSlot
-        block
-      )
-    $ UTxO.updateUTxO tvmode env utxo (aUnTxPayload $ blockTxPayload block)
+  -> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
+foldUTxOBlock env utxo block =
+  withExceptT
+    (ErrorUTxOValidationError . fromSlotNumber mainnetEpochSlots $ blockSlot
+      block
+    )
+  $ UTxO.updateUTxO env utxo (aUnTxPayload $ blockTxPayload block)
 
 -- | Size of a heap value, in words
 newtype HeapSize a =

diff --git a/cardano-ledger/src/Cardano/Chain/Block/ValidationMode.hs b/cardano-ledger/src/Cardano/Chain/Block/ValidationMode.hs
@@ -2,9 +2,7 @@
 
 module Cardano.Chain.Block.ValidationMode
   ( BlockValidationMode (..)
-  , orThrowErrorBVM
   , toTxValidationMode
-  , whenBlockValidation
   ) where
 
 import Cardano.Prelude
@@ -23,27 +21,6 @@ data BlockValidationMode
   -- ^ Perform no block validations.
   deriving (Eq, Show)
 
--- | Perform an action only when in the 'BlockValidation' mode. Otherwise, do
--- nothing.
-whenBlockValidation
-  :: MonadError err m
-  => BlockValidationMode
-  -> m ()
-  -> m ()
-whenBlockValidation BlockValidation action = action
-whenBlockValidation _ _ = pure ()
-
-orThrowErrorBVM
-  :: (MonadError e m, MonadReader BlockValidationMode m)
-  => Bool
-  -> e
-  -> m ()
-orThrowErrorBVM condition err = do
-  bvm <- ask
-  unless (bvm == NoBlockValidation || condition) (throwError err)
-
-infix 1 `orThrowErrorBVM`
-
 -- | Translate a 'BlockValidationMode' to an appropriate 'TxValidationMode'.
 toTxValidationMode :: BlockValidationMode -> TxValidationMode
 toTxValidationMode BlockValidation   = TxValidation

diff --git a/cardano-ledger/src/Cardano/Chain/Epoch/Validation.hs b/cardano-ledger/src/Cardano/Chain/Epoch/Validation.hs
@@ -30,7 +30,6 @@ import Cardano.Chain.Block
   , calcUTxOSize
   , updateChainBlockOrBoundary
   )
-import Cardano.Chain.Block.ValidationMode (BlockValidationMode)
 import Cardano.Chain.Epoch.File
   ( ParseError
   , mainnetEpochSlots
@@ -41,6 +40,7 @@ import qualified Cardano.Chain.Genesis as Genesis
 import Cardano.Chain.Slotting
   (EpochNumber, EpochAndSlotCount, slotNumberEpoch, fromSlotNumber)
 import Cardano.Chain.UTxO (UTxO)
+import Cardano.Chain.ValidationMode (ValidationMode)
 
 
 data EpochError
@@ -54,21 +54,18 @@ data EpochError
 validateEpochFile
   :: forall m
    . (MonadIO m, MonadError EpochError m)
-  => BlockValidationMode
+  => ValidationMode
   -> Genesis.Config
   -> LoggingLayer
   -> ChainValidationState
   -> FilePath
   -> m ChainValidationState
-validateEpochFile bvmode config ll cvs fp = do
+validateEpochFile vMode config ll cvs fp = do
   subTrace     <- llAppendName ll "epoch-validation" (llBasicTrace ll)
   utxoSubTrace <- llAppendName ll "utxo-stats" subTrace
   res          <- llBracketMonadX ll subTrace Log.Info "benchmark" $
-      liftIO $ runResourceT $ runExceptT $ foldChainValidationState
-        bvmode
-        config
-        cvs
-        stream
+      liftIO $ runResourceT $ (`runReaderT` vMode) $ runExceptT $
+        foldChainValidationState config cvs stream
   either throwError (logResult subTrace utxoSubTrace) res
  where
   stream = parseEpochFileWithBoundary mainnetEpochSlots fp
@@ -108,30 +105,30 @@ validateEpochFile bvmode config ll cvs fp = do
 
 -- | Check that a list of epochs 'Block's are valid.
 validateEpochFiles
-  :: BlockValidationMode
+  :: ValidationMode
   -> Genesis.Config
   -> ChainValidationState
   -> [FilePath]
   -> IO (Either EpochError ChainValidationState)
-validateEpochFiles bvmode config cvs fps =
-    runResourceT . runExceptT $ foldChainValidationState bvmode config cvs stream
+validateEpochFiles vMode config cvs fps =
+    runResourceT $ (`runReaderT` vMode) $ runExceptT
+      (foldChainValidationState config cvs stream)
   where stream = parseEpochFilesWithBoundary mainnetEpochSlots fps
 
 
 -- | Fold chain validation over a 'Stream' of 'Block's
 foldChainValidationState
-  :: BlockValidationMode
-  -> Genesis.Config
+  :: Genesis.Config
   -> ChainValidationState
   -> Stream (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-  -> ExceptT EpochError ResIO ChainValidationState
-foldChainValidationState bvmode config chainValState blocks = S.foldM_
+  -> ExceptT EpochError (ReaderT ValidationMode ResIO) ChainValidationState
+foldChainValidationState config chainValState blocks = S.foldM_
   (\cvs block ->
     withExceptT (EpochChainValidationError (blockOrBoundarySlot block))
-      $ updateChainBlockOrBoundary bvmode config cvs block
+      $ updateChainBlockOrBoundary config cvs block
   )
   (pure chainValState)
-  pure $ hoist (withExceptT EpochParseError) blocks
+  pure (pure (hoist (withExceptT EpochParseError) blocks))
  where
   blockOrBoundarySlot :: ABlockOrBoundary a -> Maybe EpochAndSlotCount
   blockOrBoundarySlot = \case