{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Commonality between multiple protocols.
--
--   Everything in this module is indexed on the protocol (or the crypto),
--   rather than on the block type. This allows it to be imported in
--   @Ouroboros.Consensus.Shelley.Ledger.Block@.
module Ouroboros.Consensus.Shelley.Protocol.Abstract (
    ProtoCrypto
  , ProtocolHeaderSupportsEnvelope (..)
  , ProtocolHeaderSupportsKES (..)
  , ProtocolHeaderSupportsLedger (..)
  , ProtocolHeaderSupportsProtocol (..)
  , ShelleyHash (..)
  , ShelleyProtocol
  , ShelleyProtocolHeader
  ) where

import           Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR))
import qualified Cardano.Crypto.Hash as Hash
import           Cardano.Crypto.VRF (OutputVRF)
import           Cardano.Ledger.BaseTypes (ProtVer)
import           Cardano.Ledger.BHeaderView (BHeaderView)
import           Cardano.Ledger.Hashes (EraIndependentBlockBody,
                     EraIndependentBlockHeader, HASH)
import           Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey)
import           Cardano.Protocol.Crypto (Crypto, VRF)
import           Cardano.Protocol.TPraos.BHeader (PrevHash)
import           Cardano.Slotting.Block (BlockNo)
import           Cardano.Slotting.Slot (SlotNo)
import           Codec.Serialise (Serialise (..))
import           Control.Monad.Except (Except)
import           Data.Kind (Type)
import           Data.Typeable (Typeable)
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks)
import           Numeric.Natural (Natural)
import           Ouroboros.Consensus.Protocol.Abstract (CanBeLeader,
                     ChainDepState, ConsensusConfig, ConsensusProtocol,
                     IsLeader, LedgerView, ValidateView)
import           Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
import           Ouroboros.Consensus.Protocol.Signed (SignedHeader)
import           Ouroboros.Consensus.Util.Condense (Condense (..))

{-------------------------------------------------------------------------------
  Crypto
-------------------------------------------------------------------------------}

type family ProtoCrypto proto :: Type

{-------------------------------------------------------------------------------
  Header hash
-------------------------------------------------------------------------------}

newtype ShelleyHash = ShelleyHash
  { ShelleyHash -> Hash HASH EraIndependentBlockHeader
unShelleyHash :: Hash.Hash HASH EraIndependentBlockHeader
  }
  deriving stock (ShelleyHash -> ShelleyHash -> Bool
(ShelleyHash -> ShelleyHash -> Bool)
-> (ShelleyHash -> ShelleyHash -> Bool) -> Eq ShelleyHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShelleyHash -> ShelleyHash -> Bool
== :: ShelleyHash -> ShelleyHash -> Bool
$c/= :: ShelleyHash -> ShelleyHash -> Bool
/= :: ShelleyHash -> ShelleyHash -> Bool
Eq, Eq ShelleyHash
Eq ShelleyHash =>
(ShelleyHash -> ShelleyHash -> Ordering)
-> (ShelleyHash -> ShelleyHash -> Bool)
-> (ShelleyHash -> ShelleyHash -> Bool)
-> (ShelleyHash -> ShelleyHash -> Bool)
-> (ShelleyHash -> ShelleyHash -> Bool)
-> (ShelleyHash -> ShelleyHash -> ShelleyHash)
-> (ShelleyHash -> ShelleyHash -> ShelleyHash)
-> Ord ShelleyHash
ShelleyHash -> ShelleyHash -> Bool
ShelleyHash -> ShelleyHash -> Ordering
ShelleyHash -> ShelleyHash -> ShelleyHash
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ShelleyHash -> ShelleyHash -> Ordering
compare :: ShelleyHash -> ShelleyHash -> Ordering
$c< :: ShelleyHash -> ShelleyHash -> Bool
< :: ShelleyHash -> ShelleyHash -> Bool
$c<= :: ShelleyHash -> ShelleyHash -> Bool
<= :: ShelleyHash -> ShelleyHash -> Bool
$c> :: ShelleyHash -> ShelleyHash -> Bool
> :: ShelleyHash -> ShelleyHash -> Bool
$c>= :: ShelleyHash -> ShelleyHash -> Bool
>= :: ShelleyHash -> ShelleyHash -> Bool
$cmax :: ShelleyHash -> ShelleyHash -> ShelleyHash
max :: ShelleyHash -> ShelleyHash -> ShelleyHash
$cmin :: ShelleyHash -> ShelleyHash -> ShelleyHash
min :: ShelleyHash -> ShelleyHash -> ShelleyHash
Ord, Int -> ShelleyHash -> ShowS
[ShelleyHash] -> ShowS
ShelleyHash -> String
(Int -> ShelleyHash -> ShowS)
-> (ShelleyHash -> String)
-> ([ShelleyHash] -> ShowS)
-> Show ShelleyHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShelleyHash -> ShowS
showsPrec :: Int -> ShelleyHash -> ShowS
$cshow :: ShelleyHash -> String
show :: ShelleyHash -> String
$cshowList :: [ShelleyHash] -> ShowS
showList :: [ShelleyHash] -> ShowS
Show, (forall x. ShelleyHash -> Rep ShelleyHash x)
-> (forall x. Rep ShelleyHash x -> ShelleyHash)
-> Generic ShelleyHash
forall x. Rep ShelleyHash x -> ShelleyHash
forall x. ShelleyHash -> Rep ShelleyHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ShelleyHash -> Rep ShelleyHash x
from :: forall x. ShelleyHash -> Rep ShelleyHash x
$cto :: forall x. Rep ShelleyHash x -> ShelleyHash
to :: forall x. Rep ShelleyHash x -> ShelleyHash
Generic)
  deriving anyclass (Context -> ShelleyHash -> IO (Maybe ThunkInfo)
Proxy ShelleyHash -> String
(Context -> ShelleyHash -> IO (Maybe ThunkInfo))
-> (Context -> ShelleyHash -> IO (Maybe ThunkInfo))
-> (Proxy ShelleyHash -> String)
-> NoThunks ShelleyHash
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ShelleyHash -> IO (Maybe ThunkInfo)
noThunks :: Context -> ShelleyHash -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ShelleyHash -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ShelleyHash -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ShelleyHash -> String
showTypeOf :: Proxy ShelleyHash -> String
NoThunks)

deriving newtype instance ToCBOR ShelleyHash

deriving newtype instance FromCBOR ShelleyHash

instance
  Serialise ShelleyHash
  where
  encode :: ShelleyHash -> Encoding
encode = ShelleyHash -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
  decode :: forall s. Decoder s ShelleyHash
decode = Decoder s ShelleyHash
forall s. Decoder s ShelleyHash
forall a s. FromCBOR a => Decoder s a
fromCBOR


instance Condense ShelleyHash where
  condense :: ShelleyHash -> String
condense = Hash HASH EraIndependentBlockHeader -> String
forall a. Show a => a -> String
show (Hash HASH EraIndependentBlockHeader -> String)
-> (ShelleyHash -> Hash HASH EraIndependentBlockHeader)
-> ShelleyHash
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyHash -> Hash HASH EraIndependentBlockHeader
unShelleyHash

{-------------------------------------------------------------------------------
  Header
-------------------------------------------------------------------------------}

-- | Shelley header, determined by the associated protocol.
--
type family ShelleyProtocolHeader proto = (sh :: Type) | sh -> proto

-- | Indicates that the header (determined by the protocol) supports " Envelope
-- " functionality. Envelope functionality refers to the minimal functionality
-- required to construct a chain.
class
  ( Eq (EnvelopeCheckError proto),
    NoThunks (EnvelopeCheckError proto),
    Show (EnvelopeCheckError proto)
  ) =>
  ProtocolHeaderSupportsEnvelope proto
  where
  pHeaderHash :: ShelleyProtocolHeader proto -> ShelleyHash
  pHeaderPrevHash :: ShelleyProtocolHeader proto -> PrevHash
  pHeaderBodyHash :: ShelleyProtocolHeader proto -> Hash.Hash HASH EraIndependentBlockBody
  pHeaderSlot :: ShelleyProtocolHeader proto -> SlotNo
  pHeaderBlock :: ShelleyProtocolHeader proto -> BlockNo
  pHeaderSize :: ShelleyProtocolHeader proto -> Natural
  pHeaderBlockSize :: ShelleyProtocolHeader proto -> Natural

  type EnvelopeCheckError proto :: Type

  -- | Carry out any protocol-specific envelope checks. For example, this might
  -- check things like maximum header size.
  envelopeChecks ::
    ConsensusConfig proto ->
    LedgerView proto ->
    ShelleyProtocolHeader proto ->
    Except (EnvelopeCheckError proto) ()

-- | `ProtocolHeaderSupportsKES` describes functionality common to protocols
--    using key evolving signature schemes. This includes verifying the header
--    integrity (e.g. validating the KES signature), as well as constructing the
--    header (made specific to KES-using protocols through the need to handle
--    the hot key).
class ProtocolHeaderSupportsKES proto where

  -- | Extract the "slots per KES period" value from the protocol config.
  --
  --   Note that we do not require `ConsensusConfig` in 'verifyHeaderIntegrity'
  --   since that function is also invoked with 'StorageConfig'.
  configSlotsPerKESPeriod :: ConsensusConfig proto -> Word64

  -- | Verify that the signature on a header is correct and valid.
  verifyHeaderIntegrity ::
    -- | Slots per KES period
    Word64 ->
    ShelleyProtocolHeader proto ->
    Bool

  mkHeader ::
    forall crypto m.
    (Crypto crypto, Monad m, crypto ~ ProtoCrypto proto) =>
    HotKey crypto m ->
    CanBeLeader proto ->
    IsLeader proto ->
    -- | Slot no
    SlotNo ->
    -- | Block no
    BlockNo ->
    -- | Hash of the previous block
    PrevHash ->
    -- | Hash of the block body to include in the header
    Hash.Hash HASH EraIndependentBlockBody ->
    -- | Size of the block body
    Int ->
    -- | Protocol version
    ProtVer ->
    m (ShelleyProtocolHeader proto)

-- | ProtocolHeaderSupportsProtocol` provides support for the concrete
--   block header to support the `ConsensusProtocol` itself.
class ProtocolHeaderSupportsProtocol proto where

  type CannotForgeError proto :: Type

  protocolHeaderView ::
    ShelleyProtocolHeader proto -> ValidateView proto

  pHeaderIssuer ::
    ShelleyProtocolHeader proto -> VKey 'BlockIssuer
  pHeaderIssueNo ::
    ShelleyProtocolHeader proto -> Word64
  -- | A VRF value in the header, used to choose between otherwise equally
  -- preferable chains.
  pTieBreakVRFValue ::
    ShelleyProtocolHeader proto -> OutputVRF (VRF (ProtoCrypto proto))

-- | Indicates that the protocol header supports the Shelley ledger. We may need
-- to generalise this if, in the future, the ledger requires different things
-- from the protocol.
class ProtocolHeaderSupportsLedger proto where
  mkHeaderView :: ShelleyProtocolHeader proto -> BHeaderView


{-------------------------------------------------------------------------------
  Key constraints
-------------------------------------------------------------------------------}

class
  ( ConsensusProtocol proto,
    Typeable (ShelleyProtocolHeader proto),
    ProtocolHeaderSupportsEnvelope proto,
    ProtocolHeaderSupportsKES proto,
    ProtocolHeaderSupportsProtocol proto,
    ProtocolHeaderSupportsLedger proto,
    Serialise (ChainDepState proto),
    SignedHeader (ShelleyProtocolHeader proto)
  ) =>
  ShelleyProtocol proto