content: {-# LANGUAGE FlexibleContexts  #-}
  {-# LANGUAGE LambdaCase        #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TemplateHaskell   #-}
  {-# LANGUAGE TupleSections     #-}
  
  module Test.Cardano.Chain.Block.Validation
    ( tests
    )
  where
  
  import Cardano.Prelude
  
  import Control.Monad.Trans.Resource (ResIO, runResourceT)
  import Data.Maybe (isJust)
  import Streaming (Of(..), Stream, hoist)
  import qualified Streaming.Prelude as S
  
  import Hedgehog
    ( Group(..)
    , annotate
    , assert
    , discover
    , evalEither
    , property
    , withTests
    )
  import System.Environment (lookupEnv)
  
  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 Test.Cardano.Chain.Config (readMainetCfg)
  import Test.Cardano.Mirror (mainnetEpochFiles)
  import Test.Options
    (ShouldAssertNF(..), TestScenario(..), TSGroup, TSProperty, concatTSGroups)
  
  
  -- | These tests perform chain validation over mainnet epoch files
  tests :: ShouldAssertNF -> TSGroup
  tests shouldAssertNF = concatTSGroups
    [ const $$discover
    , \scenario -> Group
      "Test.Cardano.Chain.Block.Validation"
      [ ( "ts_prop_mainnetEpochsValid"
        , ts_prop_mainnetEpochsValid shouldAssertNF scenario
        )
      ]
    ]
  
  ts_prop_mainnetEpochsValid :: ShouldAssertNF -> TSProperty
  ts_prop_mainnetEpochsValid shouldAssertNF scenario = withTests 1 . property $ do
    menv <- liftIO $ lookupEnv "CARDANO_MAINNET_MIRROR"
    assert $ isJust menv
  
    -- Get the 'Genesis.Config' from the mainnet genesis JSON
    config <- readMainetCfg
  
    -- Construct the initial 'ChainValidationState'
    let cvs = either (panic . show) identity $ initialChainValidationState config
  
    let
      takeFiles :: [FilePath] -> [FilePath]
      takeFiles = case scenario of
        ContinuousIntegration -> identity
        Development           -> take 15
        QualityAssurance      -> identity
  
    -- Get a list of epoch files to perform validation on
    files <- takeFiles <$> liftIO mainnetEpochFiles
  
    let stream = parseEpochFilesWithBoundary (configEpochSlots config) files
  
    annotate ("Did you build with `ghc -fhpc` or `stack --coverage`?\n"
      <> "If so, please be aware that hpc will introduce thunks around "
      <> "expressions for its program coverage measurement purposes and "
      <> "this assertion can fail as a result.\n"
      <> "Otherwise, for some reason, the `ChainValidationState` is not in "
      <> "normal form.")
  
    result <- (liftIO . runResourceT . runExceptT)
      (foldChainValidationState shouldAssertNF config cvs stream)
  
    void $ evalEither result
  
  
  data Error
    = ErrorParseError ParseError
    | ErrorChainValidationError (Maybe SlotNumber) ChainValidationError
    deriving (Eq, 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 cvs blocks =
    S.foldM_ validate (pure cvs) pure (hoist (withExceptT ErrorParseError) blocks)
   where
    validate
      :: MonadIO m
      => ChainValidationState
      -> ABlockOrBoundary ByteString
      -> ExceptT Error m ChainValidationState
    validate c b =
      withExceptT (ErrorChainValidationError (blockOrBoundarySlot b))
        . (`runReaderT` fromBlockValidationMode BlockValidation)
        $ case b of
            ABOBBoundary bvd -> do
              case shouldAssertNF of
                AssertNF -> do
                  isNF <- liftIO $ isNormalForm $! c
                  unless
                    isNF
                    (  panic
                    $  "ChainValidationState not in normal form at slot: "
                    <> show (cvsLastSlot c)
                    )
                NoAssertNF -> pure ()
              updateChainBoundary c bvd
            ABOBBlock block -> updateBlock config c block
  
    blockOrBoundarySlot :: ABlockOrBoundary a -> Maybe SlotNumber
    blockOrBoundarySlot = \case
      ABOBBoundary _     -> Nothing
      ABOBBlock    block -> Just $ blockSlot block
  