[#526] Implement multiple validation modes

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
@@ -53,6 +54,7 @@ library
                        Cardano.Chain.Block.Header
                        Cardano.Chain.Block.Proof
                        Cardano.Chain.Block.Validation
+                       Cardano.Chain.Block.ValidationMode
 
                        Cardano.Chain.Common.AddrAttributes
                        Cardano.Chain.Common.AddrSpendingData
@@ -99,6 +101,7 @@ library
                        Cardano.Chain.UTxO.UTxOConfiguration
                        Cardano.Chain.UTxO.TxProof
                        Cardano.Chain.UTxO.TxWitness
+                       Cardano.Chain.UTxO.ValidationMode
 
                        Cardano.Chain.Update.ApplicationName
                        Cardano.Chain.Update.InstallerHash
@@ -174,6 +177,7 @@ test-suite cardano-ledger-test
                        Test.Cardano.Chain.Block.Gen
                        Test.Cardano.Chain.Block.Model
                        Test.Cardano.Chain.Block.Validation
+                       Test.Cardano.Chain.Block.ValidationMode
 
                        Test.Cardano.Chain.Common.Address
                        Test.Cardano.Chain.Common.CBOR
@@ -193,6 +197,7 @@ test-suite cardano-ledger-test
                        Test.Cardano.Chain.Elaboration.Block
                        Test.Cardano.Chain.Elaboration.Delegation
                        Test.Cardano.Chain.Elaboration.Keys
+                       Test.Cardano.Chain.Elaboration.Update
                        Test.Cardano.Chain.Elaboration.UTxO
 
                        Test.Cardano.Chain.Epoch.File
@@ -220,6 +225,7 @@ test-suite cardano-ledger-test
                        Test.Cardano.Chain.UTxO.Gen
                        Test.Cardano.Chain.UTxO.Json
                        Test.Cardano.Chain.UTxO.Model
+                       Test.Cardano.Chain.UTxO.ValidationMode
 
                        Test.Cardano.Chain.Update.CBOR
                        Test.Cardano.Chain.Update.Example

cardano-ledger/src/Cardano/Chain/Block.hs

@@ -9,3 +9,4 @@ import Cardano.Chain.Block.Boundary as X
 import Cardano.Chain.Block.Header as X
 import Cardano.Chain.Block.Proof as X
 import Cardano.Chain.Block.Validation as X
+import Cardano.Chain.Block.ValidationMode as X

cardano-ledger/src/Cardano/Chain/Block/Proof.hs

@@ -28,7 +28,7 @@ import Cardano.Crypto (Hash, hash, hashDecoded)
 
 -- | Proof of everything contained in the payload
 data Proof = Proof
-  { proofUTxO        :: !TxProof
+  { proofUTxO       :: !TxProof
   , proofSsc        :: !SscProof
   , proofDelegation :: !(Hash Delegation.Payload)
   , proofUpdate     :: !Update.Proof

cardano-ledger/src/Cardano/Chain/Block/Validation.hs

@@ -108,6 +108,12 @@ import Cardano.Crypto
   , hashRaw
   , hashDecoded
   )
+import Cardano.Chain.ValidationMode
+  ( ValidationMode
+  , orThrowErrorInBlockValidationMode
+  , whenBlockValidation
+  , wrapErrorWithValidationMode
+  )
 
 --------------------------------------------------------------------------------
 -- SigningHistory
@@ -283,7 +289,7 @@ data ChainValidationError
 --------------------------------------------------------------------------------
 
 updateChainBlockOrBoundary
-  :: MonadError ChainValidationError m
+  :: (MonadError ChainValidationError m, MonadReader ValidationMode m)
   => Genesis.Config
   -> ChainValidationState
   -> ABlockOrBoundary ByteString
@@ -381,19 +387,20 @@ data BodyState = BodyState
 --   nor does it carry out anything which might be considered part of the
 --   protocol.
 updateBody
-  :: MonadError ChainValidationError m
+  :: (MonadError ChainValidationError m, MonadReader ValidationMode m)
   => BodyEnvironment
   -> BodyState
   -> ABlock ByteString
   -> m BodyState
 updateBody env bs b = do
   -- Validate the block size
   blockLength b <= maxBlockSize
-    `orThrowError` ChainValidationBlockTooLarge maxBlockSize (blockLength b)
+    `orThrowErrorInBlockValidationMode`
+      ChainValidationBlockTooLarge maxBlockSize (blockLength b)
 
   -- Validate the delegation, transaction, and update payload proofs.
-  validateBlockProofs b
-    `wrapError` ChainValidationProofValidationError
+  whenBlockValidation (validateBlockProofs b)
+    `wrapErrorWithValidationMode` ChainValidationProofValidationError
 
   -- Update the delegation state
   delegationState' <-
@@ -403,7 +410,7 @@ updateBody env bs b = do
   -- Update the UTxO
   utxo' <-
     UTxO.updateUTxO utxoEnv utxo txs
-      `wrapError` ChainValidationUTxOValidationError
+      `wrapErrorWithValidationMode` ChainValidationUTxOValidationError
 
   -- Update the update state
   updateState' <-
@@ -470,18 +477,19 @@ data HeaderEnvironment = HeaderEnvironment
 
 -- | This is an implementation of the the BHEAD rule.
 updateHeader
-  :: MonadError ChainValidationError m
+  :: (MonadError ChainValidationError m, MonadReader ValidationMode m)
   => HeaderEnvironment
   -> UPI.State
   -> AHeader ByteString
   -> m UPI.State
 updateHeader env st h = do
   -- Validate the header size
   headerLength h <= maxHeaderSize
-    `orThrowError` ChainValidationHeaderTooLarge maxHeaderSize (headerLength h)
+    `orThrowErrorInBlockValidationMode`
+      ChainValidationHeaderTooLarge maxHeaderSize (headerLength h)
 
   -- Perform epoch transition
-  epochTransition epochEnv st (headerSlot h)
+  pure $! epochTransition epochEnv st (headerSlot h)
  where
   maxHeaderSize = Update.ppMaxHeaderSize $ UPI.adoptedProtocolParameters st
 
@@ -514,16 +522,13 @@ data EpochEnvironment = EpochEnvironment
 --   confirmed proposals and cleans up the state. This corresponds to the EPOCH
 --   rules from the Byron chain specification.
 epochTransition
-  :: MonadError ChainValidationError m
-  => EpochEnvironment
+  :: EpochEnvironment
   -> UPI.State
   -> SlotNumber
-  -> m UPI.State
+  -> UPI.State
 epochTransition env st slot = if nextEpoch > currentEpoch
-  then
-    UPI.registerEpoch updateEnv st nextEpoch
-      `wrapError` ChainValidationUpdateError
-  else pure st
+  then UPI.registerEpoch updateEnv st nextEpoch
+  else st
  where
   EpochEnvironment { protocolMagic, k, numGenKeys, delegationMap, currentEpoch }
     = env
@@ -546,7 +551,7 @@ 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
+  :: (MonadError ChainValidationError m, MonadReader ValidationMode m)
   => Genesis.Config
   -> ChainValidationState
   -> ABlock ByteString
@@ -555,9 +560,10 @@ updateBlock config cvs b = do
 
   -- Compare the block's 'ProtocolMagic' to the configured value
   blockProtocolMagicId b == configProtocolMagicId config
-    `orThrowError` ChainValidationProtocolMagicMismatch
-                    (blockProtocolMagicId b)
-                    (configProtocolMagicId config)
+    `orThrowErrorInBlockValidationMode`
+      ChainValidationProtocolMagicMismatch
+        (blockProtocolMagicId b)
+        (configProtocolMagicId config)
 
   -- Update the header
   updateState' <- updateHeader headerEnv (cvsUpdateState cvs) (blockHeader b)
@@ -622,25 +628,25 @@ foldUTxO
   :: UTxO.Environment
   -> UTxO
   -> Stream (Of (ABlock ByteString)) (ExceptT ParseError ResIO) ()
-  -> ExceptT Error ResIO UTxO
+  -> 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
   :: UTxO.Environment
   -> UTxO
   -> ABlock ByteString
-  -> ExceptT Error ResIO UTxO
+  -> ExceptT Error (ReaderT ValidationMode ResIO) UTxO
 foldUTxOBlock env utxo block =
   withExceptT
-      (ErrorUTxOValidationError . fromSlotNumber mainnetEpochSlots $ blockSlot
-        block
-      )
-    $ UTxO.updateUTxO env utxo (aUnTxPayload $ blockTxPayload block)
+    (ErrorUTxOValidationError . fromSlotNumber mainnetEpochSlots $ blockSlot
+      block
+    )
+  $ UTxO.updateUTxO env utxo (aUnTxPayload $ blockTxPayload block)
 
 -- | Size of a heap value, in words
 newtype HeapSize a =

cardano-ledger/src/Cardano/Chain/Block/ValidationMode.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module Cardano.Chain.Block.ValidationMode
+  ( BlockValidationMode (..)
+  , toTxValidationMode
+  ) where
+
+import Cardano.Prelude
+
+import Cardano.Chain.UTxO.ValidationMode (TxValidationMode (..))
+
+--------------------------------------------------------------------------------
+-- BlockValidationMode
+--------------------------------------------------------------------------------
+
+-- | Indicates what sort of block validation should be performed.
+data BlockValidationMode
+  = BlockValidation
+  -- ^ Perform all block validations.
+  | NoBlockValidation
+  -- ^ Perform no block validations.
+  deriving (Eq, Show)
+
+-- | Translate a 'BlockValidationMode' to an appropriate 'TxValidationMode'.
+toTxValidationMode :: BlockValidationMode -> TxValidationMode
+toTxValidationMode BlockValidation   = TxValidation
+toTxValidationMode NoBlockValidation = NoTxValidation

cardano-ledger/src/Cardano/Chain/Epoch/Validation.hs

@@ -40,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
@@ -53,19 +54,18 @@ data EpochError
 validateEpochFile
   :: forall m
    . (MonadIO m, MonadError EpochError m)
-  => Genesis.Config
+  => ValidationMode
+  -> Genesis.Config
   -> LoggingLayer
   -> ChainValidationState
   -> FilePath
   -> m ChainValidationState
-validateEpochFile 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
-        config
-        cvs
-        stream
+      liftIO $ runResourceT $ (`runReaderT` vMode) $ runExceptT $
+        foldChainValidationState config cvs stream
   either throwError (logResult subTrace utxoSubTrace) res
  where
   stream = parseEpochFileWithBoundary mainnetEpochSlots fp
@@ -105,12 +105,14 @@ validateEpochFile config ll cvs fp = do
 
 -- | Check that a list of epochs 'Block's are valid.
 validateEpochFiles
-  :: Genesis.Config
+  :: ValidationMode
+  -> Genesis.Config
   -> ChainValidationState
   -> [FilePath]
   -> IO (Either EpochError ChainValidationState)
-validateEpochFiles config cvs fps =
-    runResourceT . runExceptT $ foldChainValidationState config cvs stream
+validateEpochFiles vMode config cvs fps =
+    runResourceT $ (`runReaderT` vMode) $ runExceptT
+      (foldChainValidationState config cvs stream)
   where stream = parseEpochFilesWithBoundary mainnetEpochSlots fps
 
 
@@ -119,14 +121,14 @@ foldChainValidationState
   :: Genesis.Config
   -> ChainValidationState
   -> Stream (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-  -> ExceptT EpochError ResIO ChainValidationState
+  -> ExceptT EpochError (ReaderT ValidationMode ResIO) ChainValidationState
 foldChainValidationState config chainValState blocks = S.foldM_
   (\cvs block ->
     withExceptT (EpochChainValidationError (blockOrBoundarySlot 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

cardano-ledger/src/Cardano/Chain/UTxO.hs

@@ -13,3 +13,4 @@ import Cardano.Chain.UTxO.TxProof as X
 import Cardano.Chain.UTxO.TxWitness as X
 import Cardano.Chain.UTxO.UTxO as X
 import Cardano.Chain.UTxO.Validation as X
+import Cardano.Chain.UTxO.ValidationMode as X