{-# 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 =
  EpochEnvironment :: Annotated ProtocolMagicId ByteString
-> BlockCount
-> Set KeyHash
-> Map
-> EpochNumber
-> EpochEnvironment
CC.EpochEnvironment
    { $sel:protocolMagic:EpochEnvironment :: Annotated ProtocolMagicId ByteString
CC.protocolMagic =
        ProtocolMagicId -> Annotated ProtocolMagicId ByteString
reAnnotateMagicId (ProtocolMagicId -> Annotated ProtocolMagicId ByteString)
-> ProtocolMagicId -> Annotated ProtocolMagicId ByteString
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 (State -> Map) -> State -> Map
forall a b. (a -> b) -> a -> b
$ ChainValidationState -> State
CC.cvsDelegationState ChainValidationState
cvs

mkBodyState :: CC.ChainValidationState -> CC.BodyState
mkBodyState :: ChainValidationState -> BodyState
mkBodyState ChainValidationState
cvs =
  BodyState :: UTxO -> State -> State -> BodyState
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 =
  BodyEnvironment :: AProtocolMagic ByteString
-> UTxOConfiguration
-> BlockCount
-> Set KeyHash
-> ProtocolParameters
-> EpochNumber
-> BodyEnvironment
CC.BodyEnvironment
    { $sel:protocolMagic:BodyEnvironment :: AProtocolMagic ByteString
CC.protocolMagic = ProtocolMagic -> AProtocolMagic ByteString
reAnnotateMagic (ProtocolMagic -> AProtocolMagic ByteString)
-> ProtocolMagic -> AProtocolMagic ByteString
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/input-output-hk/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 :: ValidationMode -> State -> AHeader ByteString -> m ()
validateHeader ValidationMode
validationMode State
updState AHeader ByteString
hdr =
  (ReaderT ValidationMode m () -> ValidationMode -> m ())
-> ValidationMode -> ReaderT ValidationMode m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ValidationMode m () -> ValidationMode -> m ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ValidationMode
validationMode (ReaderT ValidationMode m () -> m ())
-> ReaderT ValidationMode m () -> m ()
forall a b. (a -> b) -> a -> b
$
    State -> AHeader ByteString -> ReaderT ValidationMode m ()
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 :: ValidationMode
-> ABlock ByteString -> BodyEnvironment -> BodyState -> m BodyState
validateBody ValidationMode
validationMode ABlock ByteString
block BodyEnvironment
bodyEnv BodyState
bodyState =
  (ReaderT ValidationMode m BodyState
 -> ValidationMode -> m BodyState)
-> ValidationMode
-> ReaderT ValidationMode m BodyState
-> m BodyState
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ValidationMode m BodyState -> ValidationMode -> m BodyState
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ValidationMode
validationMode (ReaderT ValidationMode m BodyState -> m BodyState)
-> ReaderT ValidationMode m BodyState -> m BodyState
forall a b. (a -> b) -> a -> b
$
    BodyEnvironment
-> BodyState
-> ABlock ByteString
-> ReaderT ValidationMode m BodyState
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 :: Config
-> ValidationMode
-> ABlock ByteString
-> HeaderHash
-> ChainValidationState
-> m ChainValidationState
validateBlock Config
cfg ValidationMode
validationMode ABlock ByteString
block HeaderHash
blkHash ChainValidationState
cvs = do
  ValidationMode -> State -> AHeader ByteString -> m ()
forall (m :: * -> *).
MonadError ChainValidationError m =>
ValidationMode -> State -> AHeader ByteString -> m ()
validateHeader ValidationMode
validationMode State
updState (ABlock ByteString -> AHeader ByteString
forall a. ABlock a -> AHeader a
CC.blockHeader ABlock ByteString
block)
  BodyState
bodyState' <- ValidationMode
-> ABlock ByteString -> BodyEnvironment -> BodyState -> m BodyState
forall (m :: * -> *).
MonadError ChainValidationError m =>
ValidationMode
-> ABlock ByteString -> BodyEnvironment -> BodyState -> m BodyState
validateBody ValidationMode
validationMode ABlock ByteString
block BodyEnvironment
bodyEnv BodyState
bodyState
  ChainValidationState -> m ChainValidationState
forall (m :: * -> *) a. Monad m => a -> m a
return
    ChainValidationState
cvs
      { $sel:cvsLastSlot:ChainValidationState :: SlotNumber
CC.cvsLastSlot = ABlock ByteString -> SlotNumber
forall a. ABlock a -> SlotNumber
CC.blockSlot ABlock ByteString
block,
        $sel:cvsPreviousHash:ChainValidationState :: Either GenesisHash HeaderHash
CC.cvsPreviousHash = HeaderHash -> Either GenesisHash HeaderHash
forall a b. b -> Either a b
Right (HeaderHash -> Either GenesisHash HeaderHash)
-> HeaderHash -> Either GenesisHash HeaderHash
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)
        (ABlock ByteString -> SlotNumber
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 :: 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' <- ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
forall (m :: * -> *).
MonadError ChainValidationError m =>
ChainValidationState
-> ABoundaryBlock ByteString -> m ChainValidationState
CC.updateChainBoundary ChainValidationState
cvs ABoundaryBlock ByteString
blk
  ChainValidationState -> m ChainValidationState
forall (m :: * -> *) a. Monad m => a -> m a
return
    ChainValidationState
cvs'
      { $sel:cvsLastSlot:ChainValidationState :: SlotNumber
CC.cvsLastSlot = EpochSlots -> Word64 -> SlotNumber
CC.boundaryBlockSlot EpochSlots
epochSlots (ABoundaryHeader ByteString -> Word64
forall a. ABoundaryHeader a -> Word64
CC.boundaryEpoch ABoundaryHeader ByteString
hdr)
      }
  where
    hdr :: ABoundaryHeader ByteString
hdr = ABoundaryBlock ByteString -> ABoundaryHeader ByteString
forall a. ABoundaryBlock a -> ABoundaryHeader a
CC.boundaryHeader ABoundaryBlock ByteString
blk
    epochSlots :: EpochSlots
epochSlots = Config -> EpochSlots
Gen.configEpochSlots Config
cfg