{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Byron.Ledger.HeaderValidation (
    ByronOtherHeaderEnvelopeError (..)
  , TipInfoIsEBB (..)
  ) where

import           Control.Monad.Except
import           Data.Word
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)

import qualified Cardano.Chain.Slotting as CC

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HeaderValidation

import           Ouroboros.Consensus.Byron.Ledger.Block
import           Ouroboros.Consensus.Byron.Ledger.Config
import           Ouroboros.Consensus.Byron.Ledger.Orphans ()
import           Ouroboros.Consensus.Byron.Ledger.PBFT ()

{-------------------------------------------------------------------------------
  Envelope
-------------------------------------------------------------------------------}

instance HasAnnTip ByronBlock where
  type TipInfo ByronBlock = TipInfoIsEBB ByronBlock
  tipInfoHash :: proxy ByronBlock -> TipInfo ByronBlock -> HeaderHash ByronBlock
tipInfoHash proxy ByronBlock
_ (TipInfoIsEBB h _) = HeaderHash ByronBlock
h
  getTipInfo :: Header ByronBlock -> TipInfo ByronBlock
getTipInfo Header ByronBlock
b = HeaderHash ByronBlock -> IsEBB -> TipInfoIsEBB ByronBlock
forall blk. HeaderHash blk -> IsEBB -> TipInfoIsEBB blk
TipInfoIsEBB (Header ByronBlock -> HeaderHash (Header ByronBlock)
forall b. HasHeader b => b -> HeaderHash b
blockHash Header ByronBlock
b) (Header ByronBlock -> IsEBB
byronHeaderIsEBB Header ByronBlock
b)

data ByronOtherHeaderEnvelopeError =
    UnexpectedEBBInSlot !SlotNo
  deriving (ByronOtherHeaderEnvelopeError
-> ByronOtherHeaderEnvelopeError -> Bool
(ByronOtherHeaderEnvelopeError
 -> ByronOtherHeaderEnvelopeError -> Bool)
-> (ByronOtherHeaderEnvelopeError
    -> ByronOtherHeaderEnvelopeError -> Bool)
-> Eq ByronOtherHeaderEnvelopeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ByronOtherHeaderEnvelopeError
-> ByronOtherHeaderEnvelopeError -> Bool
$c/= :: ByronOtherHeaderEnvelopeError
-> ByronOtherHeaderEnvelopeError -> Bool
== :: ByronOtherHeaderEnvelopeError
-> ByronOtherHeaderEnvelopeError -> Bool
$c== :: ByronOtherHeaderEnvelopeError
-> ByronOtherHeaderEnvelopeError -> Bool
Eq, Int -> ByronOtherHeaderEnvelopeError -> ShowS
[ByronOtherHeaderEnvelopeError] -> ShowS
ByronOtherHeaderEnvelopeError -> String
(Int -> ByronOtherHeaderEnvelopeError -> ShowS)
-> (ByronOtherHeaderEnvelopeError -> String)
-> ([ByronOtherHeaderEnvelopeError] -> ShowS)
-> Show ByronOtherHeaderEnvelopeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ByronOtherHeaderEnvelopeError] -> ShowS
$cshowList :: [ByronOtherHeaderEnvelopeError] -> ShowS
show :: ByronOtherHeaderEnvelopeError -> String
$cshow :: ByronOtherHeaderEnvelopeError -> String
showsPrec :: Int -> ByronOtherHeaderEnvelopeError -> ShowS
$cshowsPrec :: Int -> ByronOtherHeaderEnvelopeError -> ShowS
Show, (forall x.
 ByronOtherHeaderEnvelopeError
 -> Rep ByronOtherHeaderEnvelopeError x)
-> (forall x.
    Rep ByronOtherHeaderEnvelopeError x
    -> ByronOtherHeaderEnvelopeError)
-> Generic ByronOtherHeaderEnvelopeError
forall x.
Rep ByronOtherHeaderEnvelopeError x
-> ByronOtherHeaderEnvelopeError
forall x.
ByronOtherHeaderEnvelopeError
-> Rep ByronOtherHeaderEnvelopeError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep ByronOtherHeaderEnvelopeError x
-> ByronOtherHeaderEnvelopeError
$cfrom :: forall x.
ByronOtherHeaderEnvelopeError
-> Rep ByronOtherHeaderEnvelopeError x
Generic, Context -> ByronOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
Proxy ByronOtherHeaderEnvelopeError -> String
(Context -> ByronOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo))
-> (Context
    -> ByronOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo))
-> (Proxy ByronOtherHeaderEnvelopeError -> String)
-> NoThunks ByronOtherHeaderEnvelopeError
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ByronOtherHeaderEnvelopeError -> String
$cshowTypeOf :: Proxy ByronOtherHeaderEnvelopeError -> String
wNoThunks :: Context -> ByronOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ByronOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
noThunks :: Context -> ByronOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ByronOtherHeaderEnvelopeError -> IO (Maybe ThunkInfo)
NoThunks)

instance BasicEnvelopeValidation ByronBlock where
  expectedFirstBlockNo :: proxy ByronBlock -> BlockNo
expectedFirstBlockNo  proxy ByronBlock
_ = Word64 -> BlockNo
BlockNo Word64
0
  minimumPossibleSlotNo :: Proxy ByronBlock -> SlotNo
minimumPossibleSlotNo Proxy ByronBlock
_ = Word64 -> SlotNo
SlotNo Word64
0

  -- EBB shares its block number with its predecessor
  expectedNextBlockNo :: proxy ByronBlock
-> TipInfo ByronBlock -> TipInfo ByronBlock -> BlockNo -> BlockNo
expectedNextBlockNo proxy ByronBlock
_ (TipInfoIsEBB _ prevIsEBB) (TipInfoIsEBB _ curIsEBB) BlockNo
b =
     case (IsEBB
prevIsEBB, IsEBB
curIsEBB) of
       (IsEBB
IsNotEBB, IsEBB
IsEBB) -> BlockNo
b
       (IsEBB, IsEBB)
_otherwise        -> BlockNo -> BlockNo
forall a. Enum a => a -> a
succ BlockNo
b

  -- EBB shares its slot number with its successor
  minimumNextSlotNo :: proxy ByronBlock
-> TipInfo ByronBlock -> TipInfo ByronBlock -> SlotNo -> SlotNo
minimumNextSlotNo proxy ByronBlock
_ (TipInfoIsEBB _ prevIsEBB) (TipInfoIsEBB _ curIsEBB) SlotNo
s =
      case (IsEBB
prevIsEBB, IsEBB
curIsEBB) of
        (IsEBB
IsEBB, IsEBB
IsNotEBB) -> SlotNo
s
        (IsEBB, IsEBB)
_otherwise        -> SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s

instance ValidateEnvelope ByronBlock where
  type OtherHeaderEnvelopeError ByronBlock = ByronOtherHeaderEnvelopeError

  additionalEnvelopeChecks :: TopLevelConfig ByronBlock
-> Ticked (LedgerView (BlockProtocol ByronBlock))
-> Header ByronBlock
-> Except (OtherHeaderEnvelopeError ByronBlock) ()
additionalEnvelopeChecks TopLevelConfig ByronBlock
cfg Ticked (LedgerView (BlockProtocol ByronBlock))
_ledgerView Header ByronBlock
hdr =
      Bool
-> ExceptT ByronOtherHeaderEnvelopeError Identity ()
-> ExceptT ByronOtherHeaderEnvelopeError Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IsEBB -> Bool
fromIsEBB IsEBB
newIsEBB Bool -> Bool -> Bool
&& Bool -> Bool
not (SlotNo -> Bool
canBeEBB SlotNo
actualSlotNo)) (ExceptT ByronOtherHeaderEnvelopeError Identity ()
 -> ExceptT ByronOtherHeaderEnvelopeError Identity ())
-> ExceptT ByronOtherHeaderEnvelopeError Identity ()
-> ExceptT ByronOtherHeaderEnvelopeError Identity ()
forall a b. (a -> b) -> a -> b
$
        ByronOtherHeaderEnvelopeError
-> ExceptT ByronOtherHeaderEnvelopeError Identity ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ByronOtherHeaderEnvelopeError
 -> ExceptT ByronOtherHeaderEnvelopeError Identity ())
-> ByronOtherHeaderEnvelopeError
-> ExceptT ByronOtherHeaderEnvelopeError Identity ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> ByronOtherHeaderEnvelopeError
UnexpectedEBBInSlot SlotNo
actualSlotNo
    where
      actualSlotNo :: SlotNo
      actualSlotNo :: SlotNo
actualSlotNo = Header ByronBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header ByronBlock
hdr

      newIsEBB :: IsEBB
      newIsEBB :: IsEBB
newIsEBB = Header ByronBlock -> IsEBB
byronHeaderIsEBB Header ByronBlock
hdr

      canBeEBB :: SlotNo -> Bool
      canBeEBB :: SlotNo -> Bool
canBeEBB (SlotNo Word64
s) = Word64
s Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` Word64
epochSlots Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0

      epochSlots :: Word64
      epochSlots :: Word64
epochSlots =
          EpochSlots -> Word64
CC.unEpochSlots
        (EpochSlots -> Word64)
-> (TopLevelConfig ByronBlock -> EpochSlots)
-> TopLevelConfig ByronBlock
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockConfig ByronBlock -> EpochSlots
byronEpochSlots
        (BlockConfig ByronBlock -> EpochSlots)
-> (TopLevelConfig ByronBlock -> BlockConfig ByronBlock)
-> TopLevelConfig ByronBlock
-> EpochSlots
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock
        (TopLevelConfig ByronBlock -> Word64)
-> TopLevelConfig ByronBlock -> Word64
forall a b. (a -> b) -> a -> b
$ TopLevelConfig ByronBlock
cfg