{-# 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
    [ Group -> TSGroup
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 (Property -> Property)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
  Maybe String
menv <- IO (Maybe String) -> PropertyT IO (Maybe String)
forall a. IO a -> PropertyT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> PropertyT IO (Maybe String))
-> IO (Maybe String) -> PropertyT IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"CARDANO_MAINNET_MIRROR"
  Bool -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert (Bool -> PropertyT IO ()) -> Bool -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
menv

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

  -- Construct the initial 'ChainValidationState'
  let cvs :: ChainValidationState
cvs = (Error -> ChainValidationState)
-> (ChainValidationState -> ChainValidationState)
-> Either Error ChainValidationState
-> ChainValidationState
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> ChainValidationState
forall a. HasCallStack => Text -> a
panic (Text -> ChainValidationState)
-> (Error -> Text) -> Error -> ChainValidationState
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Error -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show) ChainValidationState -> ChainValidationState
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity (Either Error ChainValidationState -> ChainValidationState)
-> Either Error ChainValidationState -> ChainValidationState
forall a b. (a -> b) -> a -> b
$ Config -> Either Error ChainValidationState
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 -> [String] -> [String]
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity
        TestScenario
Development -> Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
15
        TestScenario
QualityAssurance -> [String] -> [String]
forall (cat :: * -> * -> *) a. Category cat => cat a a
identity

  -- Get a list of epoch files to perform validation on
  [String]
files <- [String] -> [String]
takeFiles ([String] -> [String])
-> PropertyT IO [String] -> PropertyT IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> PropertyT IO [String]
forall a. IO a -> PropertyT IO a
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

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

  Either Error ChainValidationState
result <-
    (IO (Either Error ChainValidationState)
-> PropertyT IO (Either Error ChainValidationState)
forall a. IO a -> PropertyT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Error ChainValidationState)
 -> PropertyT IO (Either Error ChainValidationState))
-> (ExceptT Error ResIO ChainValidationState
    -> IO (Either Error ChainValidationState))
-> ExceptT Error ResIO ChainValidationState
-> PropertyT IO (Either Error ChainValidationState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ResourceT IO (Either Error ChainValidationState)
-> IO (Either Error ChainValidationState)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (Either Error ChainValidationState)
 -> IO (Either Error ChainValidationState))
-> (ExceptT Error ResIO ChainValidationState
    -> ResourceT IO (Either Error ChainValidationState))
-> ExceptT Error ResIO ChainValidationState
-> IO (Either Error ChainValidationState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExceptT Error ResIO ChainValidationState
-> ResourceT IO (Either Error ChainValidationState)
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)

  PropertyT IO ChainValidationState -> PropertyT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyT IO ChainValidationState -> PropertyT IO ())
-> PropertyT IO ChainValidationState -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Either Error ChainValidationState
-> PropertyT IO ChainValidationState
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
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq, Int -> Error -> String -> String
[Error] -> String -> String
Error -> String
(Int -> Error -> String -> String)
-> (Error -> String) -> ([Error] -> String -> String) -> Show Error
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Error -> String -> String
showsPrec :: Int -> Error -> String -> String
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> String -> String
showList :: [Error] -> String -> String
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 =
  (ChainValidationState
 -> ABlockOrBoundary ByteString
 -> ExceptT Error ResIO ChainValidationState)
-> ExceptT Error ResIO ChainValidationState
-> (ChainValidationState
    -> ExceptT Error ResIO ChainValidationState)
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT Error ResIO) ()
-> ExceptT Error ResIO ChainValidationState
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_ ChainValidationState
-> ABlockOrBoundary ByteString
-> ExceptT Error ResIO ChainValidationState
forall (m :: * -> *).
MonadIO m =>
ChainValidationState
-> ABlockOrBoundary ByteString
-> ExceptT Error m ChainValidationState
validate (ChainValidationState -> ExceptT Error ResIO ChainValidationState
forall a. a -> ExceptT Error ResIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainValidationState
cvs) ChainValidationState -> ExceptT Error ResIO ChainValidationState
forall a. a -> ExceptT Error ResIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. ExceptT ParseError ResIO a -> ExceptT Error ResIO a)
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT Error ResIO) ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> Stream (Of (ABlockOrBoundary ByteString)) m b
-> Stream (Of (ABlockOrBoundary ByteString)) n b
hoist ((ParseError -> Error)
-> ExceptT ParseError ResIO a -> ExceptT Error ResIO a
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 =
      (ChainValidationError -> Error)
-> ExceptT ChainValidationError m ChainValidationState
-> ExceptT Error m ChainValidationState
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Maybe SlotNumber -> ChainValidationError -> Error
ErrorChainValidationError (ABlockOrBoundary ByteString -> Maybe SlotNumber
forall a. ABlockOrBoundary a -> Maybe SlotNumber
blockOrBoundarySlot ABlockOrBoundary ByteString
b))
        (ExceptT ChainValidationError m ChainValidationState
 -> ExceptT Error m ChainValidationState)
-> (ReaderT
      ValidationMode
      (ExceptT ChainValidationError m)
      ChainValidationState
    -> ExceptT ChainValidationError m ChainValidationState)
-> ReaderT
     ValidationMode
     (ExceptT ChainValidationError m)
     ChainValidationState
-> ExceptT Error m ChainValidationState
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ReaderT
  ValidationMode
  (ExceptT ChainValidationError m)
  ChainValidationState
-> ValidationMode
-> ExceptT ChainValidationError m ChainValidationState
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` BlockValidationMode -> ValidationMode
fromBlockValidationMode BlockValidationMode
BlockValidation)
        (ReaderT
   ValidationMode
   (ExceptT ChainValidationError m)
   ChainValidationState
 -> ExceptT Error m ChainValidationState)
-> ReaderT
     ValidationMode
     (ExceptT ChainValidationError m)
     ChainValidationState
-> ExceptT Error m ChainValidationState
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 <- IO Bool
-> ReaderT ValidationMode (ExceptT ChainValidationError m) Bool
forall a.
IO a -> ReaderT ValidationMode (ExceptT ChainValidationError m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool
 -> ReaderT ValidationMode (ExceptT ChainValidationError m) Bool)
-> IO Bool
-> ReaderT ValidationMode (ExceptT ChainValidationError m) Bool
forall a b. (a -> b) -> a -> b
$ ChainValidationState -> IO Bool
forall a. a -> IO Bool
isNormalForm (ChainValidationState -> IO Bool)
-> ChainValidationState -> IO Bool
forall a b. (a -> b) -> a -> b
$! ChainValidationState
c
                Bool
-> ReaderT ValidationMode (ExceptT ChainValidationError m) ()
-> ReaderT ValidationMode (ExceptT ChainValidationError m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
                  Bool
isNF
                  ( Text -> ReaderT ValidationMode (ExceptT ChainValidationError m) ()
forall a. HasCallStack => Text -> a
panic
                      (Text
 -> ReaderT ValidationMode (ExceptT ChainValidationError m) ())
-> Text
-> ReaderT ValidationMode (ExceptT ChainValidationError m) ()
forall a b. (a -> b) -> a -> b
$ Text
"ChainValidationState not in normal form at slot: "
                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SlotNumber -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (ChainValidationState -> SlotNumber
cvsLastSlot ChainValidationState
c)
                  )
              ShouldAssertNF
NoAssertNF -> () -> ReaderT ValidationMode (ExceptT ChainValidationError m) ()
forall a.
a -> ReaderT ValidationMode (ExceptT ChainValidationError m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ChainValidationState
-> ABoundaryBlock ByteString
-> ReaderT
     ValidationMode
     (ExceptT ChainValidationError m)
     ChainValidationState
forall (m :: * -> *).
MonadError ChainValidationError m =>
ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
updateChainBoundary ChainValidationState
c ABoundaryBlock ByteString
bvd
          ABOBBlock ABlock ByteString
block -> Config
-> ChainValidationState
-> ABlock ByteString
-> ReaderT
     ValidationMode
     (ExceptT ChainValidationError m)
     ChainValidationState
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
_ -> Maybe SlotNumber
forall a. Maybe a
Nothing
      ABOBBlock ABlock a
block -> SlotNumber -> Maybe SlotNumber
forall a. a -> Maybe a
Just (SlotNumber -> Maybe SlotNumber) -> SlotNumber -> Maybe SlotNumber
forall a b. (a -> b) -> a -> b
$ ABlock a -> SlotNumber
forall a. ABlock a -> SlotNumber
blockSlot ABlock a
block