{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Test.Cardano.Chain.Block.Validation (
  tests,
)
where

import Cardano.Chain.Block (
  ABlockOrBoundary (..),
  BlockValidationMode (BlockValidation),
  ChainValidationError,
  ChainValidationState (..),
  blockSlot,
  initialChainValidationState,
  updateBlock,
  updateChainBoundary,
 )
import Cardano.Chain.Epoch.File (ParseError, parseEpochFilesWithBoundary)
import Cardano.Chain.Genesis as Genesis (Config (..), configEpochSlots)
import Cardano.Chain.Slotting (SlotNumber)
import Cardano.Chain.ValidationMode (fromBlockValidationMode)
import Cardano.Prelude
import Control.Monad.Trans.Resource (ResIO, runResourceT)
import Hedgehog (
  Group (..),
  annotate,
  assert,
  discover,
  evalEither,
  property,
  withTests,
 )
import Streaming (Of (..), Stream, hoist)
import qualified Streaming.Prelude as S
import System.Environment (lookupEnv)
import Test.Cardano.Chain.Config (readMainetCfg)
import Test.Cardano.Mirror (mainnetEpochFiles)
import Test.Options (
  ShouldAssertNF (..),
  TSGroup,
  TSProperty,
  TestScenario (..),
  concatTSGroups,
 )

-- | These tests perform chain validation over mainnet epoch files
tests :: ShouldAssertNF -> TSGroup
tests :: ShouldAssertNF -> TSGroup
tests ShouldAssertNF
shouldAssertNF =
  [TSGroup] -> TSGroup
concatTSGroups
    [ forall a b. a -> b -> a
const $$String
[(PropertyName, Property)]
String -> GroupName
GroupName -> [(PropertyName, Property)] -> Group
discover
    , \TestScenario
scenario ->
        GroupName -> [(PropertyName, Property)] -> Group
Group
          GroupName
"Test.Cardano.Chain.Block.Validation"
          [
            ( PropertyName
"ts_prop_mainnetEpochsValid"
            , ShouldAssertNF -> TSProperty
ts_prop_mainnetEpochsValid ShouldAssertNF
shouldAssertNF TestScenario
scenario
            )
          ]
    ]

ts_prop_mainnetEpochsValid :: ShouldAssertNF -> TSProperty
ts_prop_mainnetEpochsValid :: ShouldAssertNF -> TSProperty
ts_prop_mainnetEpochsValid ShouldAssertNF
shouldAssertNF TestScenario
scenario = TestLimit -> Property -> Property
withTests TestLimit
1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
property forall a b. (a -> b) -> a -> b
$ do
  Maybe String
menv <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"CARDANO_MAINNET_MIRROR"
  forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isJust Maybe String
menv

  -- Get the 'Genesis.Config' from the mainnet genesis JSON
  Config
config <- forall (m :: * -> *). MonadIO m => m Config
readMainetCfg

  -- Construct the initial 'ChainValidationState'
  let cvs :: ChainValidationState
cvs = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => Text -> a
panic forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Show a, ConvertText String b) => a -> b
show) forall (cat :: * -> * -> *) a. Category cat => cat a a
identity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError Error m =>
Config -> m ChainValidationState
initialChainValidationState Config
config

  let takeFiles :: [FilePath] -> [FilePath]
      takeFiles :: [String] -> [String]
takeFiles = case TestScenario
scenario of
        TestScenario
ContinuousIntegration -> forall (cat :: * -> * -> *) a. Category cat => cat a a
identity
        TestScenario
Development -> forall a. Int -> [a] -> [a]
take Int
15
        TestScenario
QualityAssurance -> forall (cat :: * -> * -> *) a. Category cat => cat a a
identity

  -- Get a list of epoch files to perform validation on
  [String]
files <- [String] -> [String]
takeFiles forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [String]
mainnetEpochFiles

  let stream :: Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
stream = EpochSlots
-> [String]
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFilesWithBoundary (Config -> EpochSlots
configEpochSlots Config
config) [String]
files

  forall (m :: * -> *). (MonadTest m, HasCallStack) => String -> m ()
annotate
    ( String
"Did you build with `ghc -fhpc` or `stack --coverage`?\n"
        forall a. Semigroup a => a -> a -> a
<> String
"If so, please be aware that hpc will introduce thunks around "
        forall a. Semigroup a => a -> a -> a
<> String
"expressions for its program coverage measurement purposes and "
        forall a. Semigroup a => a -> a -> a
<> String
"this assertion can fail as a result.\n"
        forall a. Semigroup a => a -> a -> a
<> String
"Otherwise, for some reason, the `ChainValidationState` is not in "
        forall a. Semigroup a => a -> a -> a
<> String
"normal form."
    )

  Either Error ChainValidationState
result <-
    (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT)
      (ShouldAssertNF
-> Config
-> ChainValidationState
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> ExceptT Error ResIO ChainValidationState
foldChainValidationState ShouldAssertNF
shouldAssertNF Config
config ChainValidationState
cvs Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
stream)

  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x a.
(MonadTest m, Show x, HasCallStack) =>
Either x a -> m a
evalEither Either Error ChainValidationState
result

data Error
  = ErrorParseError ParseError
  | ErrorChainValidationError (Maybe SlotNumber) ChainValidationError
  deriving (Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show)

-- | Fold chain validation over a 'Stream' of 'Block's
foldChainValidationState ::
  ShouldAssertNF ->
  Genesis.Config ->
  ChainValidationState ->
  Stream (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) () ->
  ExceptT Error ResIO ChainValidationState
foldChainValidationState :: ShouldAssertNF
-> Config
-> ChainValidationState
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> ExceptT Error ResIO ChainValidationState
foldChainValidationState ShouldAssertNF
shouldAssertNF Config
config ChainValidationState
cvs Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
blocks =
  forall (m :: * -> *) x a b r.
Monad m =>
(x -> a -> m x) -> m x -> (x -> m b) -> Stream (Of a) m r -> m b
S.foldM_ forall (m :: * -> *).
MonadIO m =>
ChainValidationState
-> ABlockOrBoundary ByteString
-> ExceptT Error m ChainValidationState
validate (forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainValidationState
cvs) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist (forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ParseError -> Error
ErrorParseError) Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
blocks)
  where
    validate ::
      MonadIO m =>
      ChainValidationState ->
      ABlockOrBoundary ByteString ->
      ExceptT Error m ChainValidationState
    validate :: forall (m :: * -> *).
MonadIO m =>
ChainValidationState
-> ABlockOrBoundary ByteString
-> ExceptT Error m ChainValidationState
validate ChainValidationState
c ABlockOrBoundary ByteString
b =
      forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Maybe SlotNumber -> ChainValidationError -> Error
ErrorChainValidationError (forall a. ABlockOrBoundary a -> Maybe SlotNumber
blockOrBoundarySlot ABlockOrBoundary ByteString
b))
        forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` BlockValidationMode -> ValidationMode
fromBlockValidationMode BlockValidationMode
BlockValidation)
        forall a b. (a -> b) -> a -> b
$ case ABlockOrBoundary ByteString
b of
          ABOBBoundary ABoundaryBlock ByteString
bvd -> do
            case ShouldAssertNF
shouldAssertNF of
              ShouldAssertNF
AssertNF -> do
                Bool
isNF <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO Bool
isNormalForm forall a b. (a -> b) -> a -> b
$! ChainValidationState
c
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                  Bool
isNF
                  ( forall a. HasCallStack => Text -> a
panic
                      forall a b. (a -> b) -> a -> b
$ Text
"ChainValidationState not in normal form at slot: "
                      forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, ConvertText String b) => a -> b
show (ChainValidationState -> SlotNumber
cvsLastSlot ChainValidationState
c)
                  )
              ShouldAssertNF
NoAssertNF -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            forall (m :: * -> *).
MonadError ChainValidationError m =>
ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
updateChainBoundary ChainValidationState
c ABoundaryBlock ByteString
bvd
          ABOBBlock ABlock ByteString
block -> forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
Config
-> ChainValidationState
-> ABlock ByteString
-> m ChainValidationState
updateBlock Config
config ChainValidationState
c ABlock ByteString
block

    blockOrBoundarySlot :: ABlockOrBoundary a -> Maybe SlotNumber
    blockOrBoundarySlot :: forall a. ABlockOrBoundary a -> Maybe SlotNumber
blockOrBoundarySlot = \case
      ABOBBoundary ABoundaryBlock a
_ -> forall a. Maybe a
Nothing
      ABOBBlock ABlock a
block -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> SlotNumber
blockSlot ABlock a
block