{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Auxiliary definitions to make working with the Byron ledger easier
module Cardano.Chain.Byron.API.Validation (
  applyChainTick,
  validateBlock,
  validateBoundary,
)
where

import qualified Cardano.Chain.Block as CC
import Cardano.Chain.Byron.API.Common
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Delegation.Validation.Interface as D.Iface
import qualified Cardano.Chain.Genesis as Gen
import qualified Cardano.Chain.Slotting as CC
import qualified Cardano.Chain.Update as Update
import qualified Cardano.Chain.Update.Validation.Interface as U.Iface
import qualified Cardano.Chain.ValidationMode as CC
import Cardano.Prelude

{-------------------------------------------------------------------------------
  Applying blocks
-------------------------------------------------------------------------------}

mkEpochEnvironment ::
  Gen.Config ->
  CC.ChainValidationState ->
  CC.EpochEnvironment
mkEpochEnvironment :: Config -> ChainValidationState -> EpochEnvironment
mkEpochEnvironment Config
cfg ChainValidationState
cvs =
  CC.EpochEnvironment
    { $sel:protocolMagic:EpochEnvironment :: Annotated ProtocolMagicId ByteString
CC.protocolMagic =
        ProtocolMagicId -> Annotated ProtocolMagicId ByteString
reAnnotateMagicId
          forall a b. (a -> b) -> a -> b
$ Config -> ProtocolMagicId
Gen.configProtocolMagicId Config
cfg
    , $sel:k:EpochEnvironment :: BlockCount
CC.k = Config -> BlockCount
Gen.configK Config
cfg
    , $sel:allowedDelegators:EpochEnvironment :: Set KeyHash
CC.allowedDelegators = Config -> Set KeyHash
allowedDelegators Config
cfg
    , $sel:delegationMap:EpochEnvironment :: Map
CC.delegationMap = Map
delegationMap
    , -- The 'currentEpoch' required by the epoch environment is the /old/
      -- epoch (i.e., the one in the ledger state), so that we can verify that
      -- the new epoch indeed is after the old.
      $sel:currentEpoch:EpochEnvironment :: EpochNumber
CC.currentEpoch =
        EpochSlots -> SlotNumber -> EpochNumber
CC.slotNumberEpoch
          (Config -> EpochSlots
Gen.configEpochSlots Config
cfg)
          (ChainValidationState -> SlotNumber
CC.cvsLastSlot ChainValidationState
cvs)
    }
  where
    delegationMap :: Delegation.Map
    delegationMap :: Map
delegationMap = State -> Map
D.Iface.delegationMap forall a b. (a -> b) -> a -> b
$ ChainValidationState -> State
CC.cvsDelegationState ChainValidationState
cvs

mkBodyState :: CC.ChainValidationState -> CC.BodyState
mkBodyState :: ChainValidationState -> BodyState
mkBodyState ChainValidationState
cvs =
  CC.BodyState
    { $sel:utxo:BodyState :: UTxO
CC.utxo = ChainValidationState -> UTxO
CC.cvsUtxo ChainValidationState
cvs
    , $sel:updateState:BodyState :: State
CC.updateState = ChainValidationState -> State
CC.cvsUpdateState ChainValidationState
cvs
    , $sel:delegationState:BodyState :: State
CC.delegationState = ChainValidationState -> State
CC.cvsDelegationState ChainValidationState
cvs
    }

mkBodyEnvironment ::
  Gen.Config ->
  Update.ProtocolParameters ->
  CC.SlotNumber ->
  CC.BodyEnvironment
mkBodyEnvironment :: Config -> ProtocolParameters -> SlotNumber -> BodyEnvironment
mkBodyEnvironment Config
cfg ProtocolParameters
params SlotNumber
slotNo =
  CC.BodyEnvironment
    { $sel:protocolMagic:BodyEnvironment :: AProtocolMagic ByteString
CC.protocolMagic = ProtocolMagic -> AProtocolMagic ByteString
reAnnotateMagic forall a b. (a -> b) -> a -> b
$ Config -> ProtocolMagic
Gen.configProtocolMagic Config
cfg
    , $sel:utxoConfiguration:BodyEnvironment :: UTxOConfiguration
CC.utxoConfiguration = Config -> UTxOConfiguration
Gen.configUTxOConfiguration Config
cfg
    , $sel:k:BodyEnvironment :: BlockCount
CC.k = Config -> BlockCount
Gen.configK Config
cfg
    , $sel:allowedDelegators:BodyEnvironment :: Set KeyHash
CC.allowedDelegators = Config -> Set KeyHash
allowedDelegators Config
cfg
    , $sel:protocolParameters:BodyEnvironment :: ProtocolParameters
CC.protocolParameters = ProtocolParameters
params
    , -- The 'currentEpoch' for validating a block should be the /current/
      -- epoch (that is, the epoch of the block), /not/ the old epoch
      -- (from the ledger state). This is to make sure delegation certificates
      -- are for the /next/ epoch.
      $sel:currentEpoch:BodyEnvironment :: EpochNumber
CC.currentEpoch =
        EpochSlots -> SlotNumber -> EpochNumber
CC.slotNumberEpoch
          (Config -> EpochSlots
Gen.configEpochSlots Config
cfg)
          SlotNumber
slotNo
    }

-- | Apply chain tick
--
-- This is the part of block processing that depends only on the slot number of
-- the block: We update
--
-- * The update state
-- * The delegation state
-- * The last applied slot number
--
-- NOTE: The spec currently only updates the update state here; this is not good
-- enough. Fortunately, updating the delegation state and slot number here
-- (currently done in body processing) is at least /conform/ spec, as these
-- updates are conform spec. See
--
-- <https://github.com/intersectmbo/cardano-ledger/issues/1046>
-- <https://github.com/input-output-hk/ouroboros-network/issues/1291>
applyChainTick ::
  Gen.Config ->
  CC.SlotNumber ->
  CC.ChainValidationState ->
  CC.ChainValidationState
applyChainTick :: Config
-> SlotNumber -> ChainValidationState -> ChainValidationState
applyChainTick Config
cfg SlotNumber
slotNo ChainValidationState
cvs =
  ChainValidationState
cvs
    { $sel:cvsUpdateState:ChainValidationState :: State
CC.cvsUpdateState =
        EpochEnvironment -> State -> SlotNumber -> State
CC.epochTransition
          (Config -> ChainValidationState -> EpochEnvironment
mkEpochEnvironment Config
cfg ChainValidationState
cvs)
          (ChainValidationState -> State
CC.cvsUpdateState ChainValidationState
cvs)
          SlotNumber
slotNo
    , $sel:cvsDelegationState:ChainValidationState :: State
CC.cvsDelegationState =
        EpochNumber -> SlotNumber -> State -> State
D.Iface.tickDelegation
          EpochNumber
currentEpoch
          SlotNumber
slotNo
          (ChainValidationState -> State
CC.cvsDelegationState ChainValidationState
cvs)
    }
  where
    currentEpoch :: EpochNumber
currentEpoch = EpochSlots -> SlotNumber -> EpochNumber
CC.slotNumberEpoch (Config -> EpochSlots
Gen.configEpochSlots Config
cfg) SlotNumber
slotNo

-- | Validate header
--
-- NOTE: Header validation does not produce any state changes; the only state
-- changes arising from processing headers come from 'applyChainTick'.
validateHeader ::
  MonadError CC.ChainValidationError m =>
  CC.ValidationMode ->
  U.Iface.State ->
  CC.AHeader ByteString ->
  m ()
validateHeader :: forall (m :: * -> *).
MonadError ChainValidationError m =>
ValidationMode -> State -> AHeader ByteString -> m ()
validateHeader ValidationMode
validationMode State
updState AHeader ByteString
hdr =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ValidationMode
validationMode
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
State -> AHeader ByteString -> m ()
CC.headerIsValid State
updState AHeader ByteString
hdr

validateBody ::
  MonadError CC.ChainValidationError m =>
  CC.ValidationMode ->
  CC.ABlock ByteString ->
  CC.BodyEnvironment ->
  CC.BodyState ->
  m CC.BodyState
validateBody :: forall (m :: * -> *).
MonadError ChainValidationError m =>
ValidationMode
-> ABlock ByteString -> BodyEnvironment -> BodyState -> m BodyState
validateBody ValidationMode
validationMode ABlock ByteString
block BodyEnvironment
bodyEnv BodyState
bodyState =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ValidationMode
validationMode
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError ChainValidationError m,
 MonadReader ValidationMode m) =>
BodyEnvironment -> BodyState -> ABlock ByteString -> m BodyState
CC.updateBody BodyEnvironment
bodyEnv BodyState
bodyState ABlock ByteString
block

validateBlock ::
  MonadError CC.ChainValidationError m =>
  Gen.Config ->
  CC.ValidationMode ->
  CC.ABlock ByteString ->
  CC.HeaderHash ->
  CC.ChainValidationState ->
  m CC.ChainValidationState
validateBlock :: forall (m :: * -> *).
MonadError ChainValidationError m =>
Config
-> ValidationMode
-> ABlock ByteString
-> HeaderHash
-> ChainValidationState
-> m ChainValidationState
validateBlock Config
cfg ValidationMode
validationMode ABlock ByteString
block HeaderHash
blkHash ChainValidationState
cvs = do
  forall (m :: * -> *).
MonadError ChainValidationError m =>
ValidationMode -> State -> AHeader ByteString -> m ()
validateHeader ValidationMode
validationMode State
updState (forall a. ABlock a -> AHeader a
CC.blockHeader ABlock ByteString
block)
  BodyState
bodyState' <- forall (m :: * -> *).
MonadError ChainValidationError m =>
ValidationMode
-> ABlock ByteString -> BodyEnvironment -> BodyState -> m BodyState
validateBody ValidationMode
validationMode ABlock ByteString
block BodyEnvironment
bodyEnv BodyState
bodyState
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ChainValidationState
cvs
      { $sel:cvsLastSlot:ChainValidationState :: SlotNumber
CC.cvsLastSlot = forall a. ABlock a -> SlotNumber
CC.blockSlot ABlock ByteString
block
      , $sel:cvsPreviousHash:ChainValidationState :: Either GenesisHash HeaderHash
CC.cvsPreviousHash = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$! HeaderHash
blkHash
      , $sel:cvsUtxo:ChainValidationState :: UTxO
CC.cvsUtxo = BodyState -> UTxO
CC.utxo BodyState
bodyState'
      , $sel:cvsUpdateState:ChainValidationState :: State
CC.cvsUpdateState = BodyState -> State
CC.updateState BodyState
bodyState'
      , $sel:cvsDelegationState:ChainValidationState :: State
CC.cvsDelegationState = BodyState -> State
CC.delegationState BodyState
bodyState'
      }
  where
    updState :: State
updState = ChainValidationState -> State
CC.cvsUpdateState ChainValidationState
cvs
    bodyEnv :: BodyEnvironment
bodyEnv =
      Config -> ProtocolParameters -> SlotNumber -> BodyEnvironment
mkBodyEnvironment
        Config
cfg
        (ChainValidationState -> ProtocolParameters
getProtocolParams ChainValidationState
cvs)
        (forall a. ABlock a -> SlotNumber
CC.blockSlot ABlock ByteString
block)
    bodyState :: BodyState
bodyState = ChainValidationState -> BodyState
mkBodyState ChainValidationState
cvs

-- | Apply a boundary block
--
-- NOTE: The `cvsLastSlot` calculation must match the one in 'abobHdrSlotNo'.
validateBoundary ::
  MonadError CC.ChainValidationError m =>
  Gen.Config ->
  CC.ABoundaryBlock ByteString ->
  CC.ChainValidationState ->
  m CC.ChainValidationState
validateBoundary :: forall (m :: * -> *).
MonadError ChainValidationError m =>
Config
-> ABoundaryBlock ByteString
-> ChainValidationState
-> m ChainValidationState
validateBoundary Config
cfg ABoundaryBlock ByteString
blk ChainValidationState
cvs = do
  -- TODO: Unfortunately, 'updateChainBoundary' doesn't take a hash as an
  -- argument but recomputes it.
  ChainValidationState
cvs' <- forall (m :: * -> *).
MonadError ChainValidationError m =>
ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
CC.updateChainBoundary ChainValidationState
cvs ABoundaryBlock ByteString
blk
  forall (m :: * -> *) a. Monad m => a -> m a
return
    ChainValidationState
cvs'
      { $sel:cvsLastSlot:ChainValidationState :: SlotNumber
CC.cvsLastSlot = EpochSlots -> Word64 -> SlotNumber
CC.boundaryBlockSlot EpochSlots
epochSlots (forall a. ABoundaryHeader a -> Word64
CC.boundaryEpoch ABoundaryHeader ByteString
hdr)
      }
  where
    hdr :: ABoundaryHeader ByteString
hdr = forall a. ABoundaryBlock a -> ABoundaryHeader a
CC.boundaryHeader ABoundaryBlock ByteString
blk
    epochSlots :: EpochSlots
epochSlots = Config -> EpochSlots
Gen.configEpochSlots Config
cfg