Skip to content
Permalink
Browse files

introduce contra-tracer

Signed-off-by: Alexander Diemand <codieplusplus@apax.net>
  • Loading branch information...
CodiePP committed Aug 13, 2019
1 parent d5bd774 commit 2900a08677046ef02dedba03f486c63c5a864011
@@ -54,3 +54,8 @@ source-repository-package
tag: 69dc593dc30a4df954930f95a515239f7e8abad7
subdir: byron/chain/executable-spec

source-repository-package
type: git
location: https://github.com/input-output-hk/iohk-monitoring-framework
subdir: contra-tracer
tag: 6e3047f785efe874819e8654ab928b0d9e9ff499
@@ -132,6 +132,7 @@ library
, cardano-crypto-wrapper
, cardano-prelude
, containers
, contra-tracer
, concurrency
, cryptonite
, Cabal
@@ -246,6 +247,7 @@ test-suite cardano-ledger-test
, cardano-prelude
, cardano-prelude-test
, containers
, contra-tracer
, cryptonite
, cs-blockchain
, cs-ledger
@@ -302,6 +304,7 @@ test-suite epoch-validation-normal-form-test
, cardano-prelude
, cardano-prelude-test
, containers
, contra-tracer
, directory
, filepath
, formatting
@@ -40,6 +40,7 @@ where
import Cardano.Prelude

import Control.Monad.Trans.Resource (ResIO)
import Control.Tracer
import qualified Data.ByteString.Lazy as BSL
import Data.Coerce (coerce)
import qualified Data.Map.Strict as M
@@ -331,44 +332,62 @@ data ChainValidationError

deriving (Eq, Show)

orThrowErrorTraced :: MonadError e m => Bool -> (Tracer m e, e) -> m ()
orThrowErrorTraced condition (tr, e) =
if condition
then pure ()
else do
traceWith tr e
throwError e

infix 1 `orThrowErrorTraced`

throwErrorTraced :: MonadError e m => Tracer m e -> e -> m ()
throwErrorTraced tr e = do
traceWith tr e
throwError e

infix 1 `throwErrorTraced`

--------------------------------------------------------------------------------
-- Validation Functions
--------------------------------------------------------------------------------

updateChainBlockOrBoundary
:: (MonadError ChainValidationError m, MonadReader ValidationMode m)
=> Genesis.Config
=> Tracer m ChainValidationError
-> Genesis.Config
-> ChainValidationState
-> ABlockOrBoundary ByteString
-> m ChainValidationState
updateChainBlockOrBoundary config c b = case b of
ABOBBoundary bvd -> updateChainBoundary c bvd
updateChainBlockOrBoundary _tr config c b = case b of
ABOBBoundary bvd -> updateChainBoundary nullTracer c bvd
ABOBBlock block -> updateBlock config c block


updateChainBoundary
:: MonadError ChainValidationError m
=> ChainValidationState
=> Tracer m ChainValidationError
-> ChainValidationState
-> ABoundaryBlock ByteString
-> m ChainValidationState
updateChainBoundary cvs bvd = do
updateChainBoundary tr cvs bvd = do
case (cvsPreviousHash cvs, boundaryPrevHash (boundaryHeader bvd)) of
(Left expected, Left actual) ->
(expected == actual)
`orThrowError` ChainValidationGenesisHashMismatch expected actual
`orThrowErrorTraced` (tr, ChainValidationGenesisHashMismatch expected actual)
(Right expected, Right actual) ->
(expected == actual)
`orThrowError` ChainValidationInvalidHash expected actual
`orThrowErrorTraced` (tr, ChainValidationInvalidHash expected actual)

(Left gh, Right hh) ->
throwError $ ChainValidationExpectedGenesisHash gh hh
throwErrorTraced tr $ ChainValidationExpectedGenesisHash gh hh
(Right hh, Left gh) ->
throwError $ ChainValidationExpectedHeaderHash hh gh
throwErrorTraced tr $ ChainValidationExpectedHeaderHash hh gh

-- Validate that the block is within the size bounds
(boundaryBlockLength bvd <= 2e6)
`orThrowError` ChainValidationBoundaryTooLarge
`orThrowErrorTraced` (tr, ChainValidationBoundaryTooLarge)

-- Update the previous hash
pure $ cvs
@@ -384,30 +403,32 @@ updateChainBoundary cvs bvd = do

validateHeaderMatchesBody
:: MonadError ProofValidationError m
=> AHeader ByteString
=> Tracer m ProofValidationError
-> AHeader ByteString
-> ABody ByteString
-> m ()
validateHeaderMatchesBody hdr body = do
validateHeaderMatchesBody tr hdr body = do
let hdrProof = headerProof hdr

-- Validate the delegation payload signature
proofDelegation hdrProof == hashDecoded (bodyDlgPayload body)
`orThrowError` DelegationProofValidationError
`orThrowErrorTraced` (tr, DelegationProofValidationError)

-- Validate the transaction payload proof
proofUTxO hdrProof == recoverTxProof (bodyTxPayload body)
`orThrowError` UTxOProofValidationError
`orThrowErrorTraced` (tr, UTxOProofValidationError)

-- Validate the update payload proof
proofUpdate hdrProof == hashDecoded (bodyUpdatePayload body)
`orThrowError` UpdateProofValidationError
`orThrowErrorTraced` (tr, UpdateProofValidationError)

validateBlockProofs
:: MonadError ProofValidationError m
=> ABlock ByteString
=> Tracer m ProofValidationError
-> ABlock ByteString
-> m ()
validateBlockProofs b =
validateHeaderMatchesBody blockHeader blockBody
validateBlockProofs tr b =
validateHeaderMatchesBody tr blockHeader blockBody
where
ABlock
{ blockHeader
@@ -448,7 +469,7 @@ updateBody env bs b = do
ChainValidationBlockTooLarge maxBlockSize (blockLength b)

-- Validate the delegation, transaction, and update payload proofs.
whenBlockValidation (validateBlockProofs b)
whenBlockValidation (validateBlockProofs nullTracer b)
`wrapErrorWithValidationMode` ChainValidationProofValidationError

-- Update the delegation state
@@ -13,6 +13,7 @@ where
import Cardano.Prelude hiding (trace)

import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Control.Tracer
import Streaming (Of(..), Stream, hoist)
import qualified Streaming.Prelude as S

@@ -83,7 +84,7 @@ foldChainValidationState
foldChainValidationState config chainValState blocks = S.foldM_
(\cvs block ->
withExceptT (EpochChainValidationError (blockOrBoundarySlot block))
$ updateChainBlockOrBoundary config cvs block
$ updateChainBlockOrBoundary nullTracer config cvs block
)
(pure chainValState)
pure (pure (hoist (withExceptT EpochParseError) blocks))
@@ -12,6 +12,7 @@ where
import Cardano.Prelude

import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Control.Tracer
import qualified Data.Map.Strict as M
import Data.Maybe (isJust)
import qualified Data.Sequence as Seq
@@ -145,7 +146,7 @@ foldChainValidationState shouldAssertNF config cvs blocks =
<> show (cvsLastSlot c)
)
NoAssertNF -> pure ()
updateChainBoundary c bvd
updateChainBoundary nullTracer c bvd
ABOBBlock block -> updateBlock config c block

blockOrBoundarySlot :: ABlockOrBoundary a -> Maybe SlotNumber
@@ -33,6 +33,11 @@ extra-deps:
- byron/ledger/executable-spec
- byron/chain/executable-spec

- git: https://github.com/input-output-hk/iohk-monitoring-framework
commit: 6e3047f785efe874819e8654ab928b0d9e9ff499
subdirs:
- contra-tracer

# Not yet in Stack
- bimap-0.4.0

0 comments on commit 2900a08

Please sign in to comment.
You can’t perform that action at this time.