{-# 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
(EpochError -> EpochError -> Bool)
-> (EpochError -> EpochError -> Bool) -> Eq EpochError
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
(Int -> EpochError -> ShowS)
-> (EpochError -> String)
-> ([EpochError] -> ShowS)
-> Show EpochError
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 :: 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 <-
    IO (Either EpochError ChainValidationState)
-> m (Either EpochError ChainValidationState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either EpochError ChainValidationState)
 -> m (Either EpochError ChainValidationState))
-> IO (Either EpochError ChainValidationState)
-> m (Either EpochError ChainValidationState)
forall a b. (a -> b) -> a -> b
$
      ResourceT IO (Either EpochError ChainValidationState)
-> IO (Either EpochError ChainValidationState)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (Either EpochError ChainValidationState)
 -> IO (Either EpochError ChainValidationState))
-> ResourceT IO (Either EpochError ChainValidationState)
-> IO (Either EpochError ChainValidationState)
forall a b. (a -> b) -> a -> b
$
        (ReaderT
  ValidationMode ResIO (Either EpochError ChainValidationState)
-> ValidationMode
-> ResourceT IO (Either EpochError ChainValidationState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode) (ReaderT
   ValidationMode ResIO (Either EpochError ChainValidationState)
 -> ResourceT IO (Either EpochError ChainValidationState))
-> ReaderT
     ValidationMode ResIO (Either EpochError ChainValidationState)
-> ResourceT IO (Either EpochError ChainValidationState)
forall a b. (a -> b) -> a -> b
$
          ExceptT
  EpochError (ReaderT ValidationMode ResIO) ChainValidationState
-> ReaderT
     ValidationMode ResIO (Either EpochError ChainValidationState)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   EpochError (ReaderT ValidationMode ResIO) ChainValidationState
 -> ReaderT
      ValidationMode ResIO (Either EpochError ChainValidationState))
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
-> ReaderT
     ValidationMode ResIO (Either EpochError ChainValidationState)
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 -> Tracer m EpochError -> EpochError -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m EpochError
tr EpochError
e m () -> m ChainValidationState -> m ChainValidationState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ChainValidationState -> m ChainValidationState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainValidationState
cvs
    Right ChainValidationState
cvs' -> ChainValidationState -> m ChainValidationState
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 =
  ResourceT IO (Either EpochError ChainValidationState)
-> IO (Either EpochError ChainValidationState)
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO (Either EpochError ChainValidationState)
 -> IO (Either EpochError ChainValidationState))
-> ResourceT IO (Either EpochError ChainValidationState)
-> IO (Either EpochError ChainValidationState)
forall a b. (a -> b) -> a -> b
$
    (ReaderT
  ValidationMode ResIO (Either EpochError ChainValidationState)
-> ValidationMode
-> ResourceT IO (Either EpochError ChainValidationState)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode) (ReaderT
   ValidationMode ResIO (Either EpochError ChainValidationState)
 -> ResourceT IO (Either EpochError ChainValidationState))
-> ReaderT
     ValidationMode ResIO (Either EpochError ChainValidationState)
-> ResourceT IO (Either EpochError ChainValidationState)
forall a b. (a -> b) -> a -> b
$
      ExceptT
  EpochError (ReaderT ValidationMode ResIO) ChainValidationState
-> ReaderT
     ValidationMode ResIO (Either EpochError ChainValidationState)
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 =
  (ChainValidationState
 -> ABlockOrBoundary ByteString
 -> ExceptT
      EpochError (ReaderT ValidationMode ResIO) ChainValidationState)
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
-> (ChainValidationState
    -> ExceptT
         EpochError (ReaderT ValidationMode ResIO) ChainValidationState)
-> Stream
     (Of (ABlockOrBoundary ByteString))
     (ExceptT EpochError (ReaderT ValidationMode ResIO))
     (Stream
        (Of (ABlockOrBoundary ByteString)) (ExceptT EpochError ResIO) ())
-> ExceptT
     EpochError (ReaderT ValidationMode 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
cvs ABlockOrBoundary ByteString
block ->
        (ChainValidationError -> EpochError)
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode ResIO)
     ChainValidationState
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (Maybe EpochAndSlotCount -> ChainValidationError -> EpochError
EpochChainValidationError (ABlockOrBoundary ByteString -> Maybe EpochAndSlotCount
forall a. ABlockOrBoundary a -> Maybe EpochAndSlotCount
blockOrBoundarySlot ABlockOrBoundary ByteString
block)) (ExceptT
   ChainValidationError
   (ReaderT ValidationMode ResIO)
   ChainValidationState
 -> ExceptT
      EpochError (ReaderT ValidationMode ResIO) ChainValidationState)
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode ResIO)
     ChainValidationState
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
forall a b. (a -> b) -> a -> b
$
          Config
-> ChainValidationState
-> ABlockOrBoundary ByteString
-> ExceptT
     ChainValidationError
     (ReaderT ValidationMode ResIO)
     ChainValidationState
forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
Config
-> ChainValidationState
-> ABlockOrBoundary ByteString
-> m ChainValidationState
updateChainBlockOrBoundary Config
config ChainValidationState
cvs ABlockOrBoundary ByteString
block
    )
    (ChainValidationState
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
forall (f :: * -> *) a. Applicative f => a -> f a
pure ChainValidationState
chainValState)
    ChainValidationState
-> ExceptT
     EpochError (ReaderT ValidationMode ResIO) ChainValidationState
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Stream
  (Of (ABlockOrBoundary ByteString)) (ExceptT EpochError ResIO) ()
-> Stream
     (Of (ABlockOrBoundary ByteString))
     (ExceptT EpochError (ReaderT ValidationMode ResIO))
     (Stream
        (Of (ABlockOrBoundary ByteString)) (ExceptT EpochError ResIO) ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a.
 ExceptT ParseError ResIO a -> ExceptT EpochError ResIO a)
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT ParseError ResIO) ()
-> Stream
     (Of (ABlockOrBoundary ByteString)) (ExceptT EpochError 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
hoist ((ParseError -> EpochError)
-> ExceptT ParseError ResIO a -> ExceptT EpochError ResIO a
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 :: ABlockOrBoundary a -> Maybe EpochAndSlotCount
blockOrBoundarySlot = \case
      ABOBBoundary ABoundaryBlock a
_ -> Maybe EpochAndSlotCount
forall a. Maybe a
Nothing
      ABOBBlock ABlock a
block -> EpochAndSlotCount -> Maybe EpochAndSlotCount
forall a. a -> Maybe a
Just (EpochAndSlotCount -> Maybe EpochAndSlotCount)
-> (SlotNumber -> EpochAndSlotCount)
-> SlotNumber
-> Maybe EpochAndSlotCount
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 (SlotNumber -> Maybe EpochAndSlotCount)
-> SlotNumber -> Maybe EpochAndSlotCount
forall a b. (a -> b) -> a -> b
$ ABlock a -> SlotNumber
forall a. ABlock a -> SlotNumber
blockSlot ABlock a
block