{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Chain.Epoch.Validation (
  EpochError (..),
  validateEpochFile,
  validateEpochFiles,
)
where

import Cardano.Chain.Block (
  ABlockOrBoundary (..),
  ChainValidationError,
  ChainValidationState (..),
  blockSlot,
  updateChainBlockOrBoundary,
 )
import Cardano.Chain.Epoch.File (
  ParseError,
  mainnetEpochSlots,
  parseEpochFileWithBoundary,
  parseEpochFilesWithBoundary,
 )
import qualified Cardano.Chain.Genesis as Genesis
import Cardano.Chain.Slotting (
  EpochAndSlotCount,
  fromSlotNumber,
 )
import Cardano.Chain.ValidationMode (ValidationMode)
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

data EpochError
  = EpochParseError ParseError
  | EpochChainValidationError (Maybe EpochAndSlotCount) ChainValidationError
  | Initial
  deriving (EpochError -> EpochError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EpochError -> EpochError -> Bool
$c/= :: EpochError -> EpochError -> Bool
== :: EpochError -> EpochError -> Bool
$c== :: EpochError -> EpochError -> Bool
Eq, Int -> EpochError -> ShowS
[EpochError] -> ShowS
EpochError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EpochError] -> ShowS
$cshowList :: [EpochError] -> ShowS
show :: EpochError -> String
$cshow :: EpochError -> String
showsPrec :: Int -> EpochError -> ShowS
$cshowsPrec :: Int -> EpochError -> ShowS
Show)

-- | Check that a single epoch's `Block`s are valid by folding over them
-- TODO(KS): We should use contra-tracer here!
-- tracing is orthogonal to throwing errors; it does not change the program flow.
validateEpochFile ::
  forall m.
  MonadIO m =>
  Tracer m EpochError ->
  ValidationMode ->
  Genesis.Config ->
  ChainValidationState ->
  FilePath ->
  m ChainValidationState
validateEpochFile :: forall (m :: * -> *).
MonadIO m =>
Tracer m EpochError
-> ValidationMode
-> Config
-> ChainValidationState
-> String
-> m ChainValidationState
validateEpochFile Tracer m EpochError
tr ValidationMode
vMode Config
config ChainValidationState
cvs String
fp = do
  Either EpochError ChainValidationState
res <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
      forall a b. (a -> b) -> a -> b
$ (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
      forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
      forall a b. (a -> b) -> a -> b
$ Config
-> ChainValidationState
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
foldChainValidationState Config
config ChainValidationState
cvs Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
stream

  case Either EpochError ChainValidationState
res of
    Left EpochError
e -> forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m EpochError
tr EpochError
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainValidationState
cvs
    Right ChainValidationState
cvs' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainValidationState
cvs'
  where
    stream :: Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
stream = EpochSlots
-> String
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFileWithBoundary EpochSlots
mainnetEpochSlots String
fp

-- | Check that a list of epochs 'Block's are valid.
validateEpochFiles ::
  ValidationMode ->
  Genesis.Config ->
  ChainValidationState ->
  [FilePath] ->
  IO (Either EpochError ChainValidationState)
validateEpochFiles :: ValidationMode
-> Config
-> ChainValidationState
-> [String]
-> IO (Either EpochError ChainValidationState)
validateEpochFiles ValidationMode
vMode Config
config ChainValidationState
cvs [String]
fps =
  forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT
    forall a b. (a -> b) -> a -> b
$ (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
    forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
      (Config
-> ChainValidationState
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
foldChainValidationState Config
config ChainValidationState
cvs Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
stream)
  where
    stream :: Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
stream = EpochSlots
-> [String]
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
parseEpochFilesWithBoundary EpochSlots
mainnetEpochSlots [String]
fps

-- | Fold chain validation over a 'Stream' of 'Block's
foldChainValidationState ::
  Genesis.Config ->
  ChainValidationState ->
  Stream (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) () ->
  ExceptT EpochError (ReaderT ValidationMode ResIO) ChainValidationState
foldChainValidationState :: Config
-> ChainValidationState
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
foldChainValidationState Config
config ChainValidationState
chainValState 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_
    ( \ChainValidationState
cvs ABlockOrBoundary ByteString
block ->
        forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Maybe EpochAndSlotCount -> ChainValidationError -> EpochError
EpochChainValidationError (forall a. ABlockOrBoundary a -> Maybe EpochAndSlotCount
blockOrBoundarySlot ABlockOrBoundary ByteString
block))
          forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
Config
-> ChainValidationState
-> ABlockOrBoundary ByteString
-> m ChainValidationState
updateChainBlockOrBoundary Config
config ChainValidationState
cvs ABlockOrBoundary ByteString
block
    )
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainValidationState
chainValState)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (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 -> EpochError
EpochParseError) Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
blocks))
  where
    blockOrBoundarySlot :: ABlockOrBoundary a -> Maybe EpochAndSlotCount
    blockOrBoundarySlot :: forall a. ABlockOrBoundary a -> Maybe EpochAndSlotCount
blockOrBoundarySlot = \case
      ABOBBoundary ABoundaryBlock a
_ -> forall a. Maybe a
Nothing
      ABOBBlock ABlock a
block -> forall a. a -> Maybe a
Just forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EpochSlots -> SlotNumber -> EpochAndSlotCount
fromSlotNumber EpochSlots
mainnetEpochSlots forall a b. (a -> b) -> a -> b
$ forall a. ABlock a -> SlotNumber
blockSlot ABlock a
block