{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE QuantifiedConstraints      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilyDependencies     #-}
{-# 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           Cardano.Crypto.VRF (OutputVRF)
import           Cardano.Ledger.BHeaderView (BHeaderView)
import           Cardano.Ledger.BaseTypes (ProtVer)
import           Cardano.Ledger.Crypto (Crypto, VRF)
import           Cardano.Ledger.Hashes (EraIndependentBlockBody,
                     EraIndependentBlockHeader)
import           Cardano.Ledger.Keys (Hash, KeyRole (BlockIssuer), VKey)
import qualified Cardano.Ledger.Keys as SL (Hash)
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.Ticked (Ticked)
import           Ouroboros.Consensus.Util.Condense (Condense (..))

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

type family ProtoCrypto proto :: Type

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

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

deriving newtype instance
  ( Crypto crypto) =>
  FromCBOR (ShelleyHash crypto)

deriving newtype instance
  ( Crypto crypto) =>
  ToCBOR (ShelleyHash crypto)

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


instance Condense (ShelleyHash crypto) where
  condense :: ShelleyHash crypto -> String
condense = Hash (HASH crypto) EraIndependentBlockHeader -> String
forall a. Show a => a -> String
show (Hash (HASH crypto) EraIndependentBlockHeader -> String)
-> (ShelleyHash crypto
    -> Hash (HASH crypto) EraIndependentBlockHeader)
-> ShelleyHash crypto
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyHash crypto -> Hash (HASH crypto) EraIndependentBlockHeader
forall crypto.
ShelleyHash crypto -> Hash crypto 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 (ProtoCrypto proto)
  pHeaderPrevHash :: ShelleyProtocolHeader proto -> PrevHash (ProtoCrypto proto)
  pHeaderBodyHash :: ShelleyProtocolHeader proto -> Hash (ProtoCrypto proto) 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 ->
    Ticked (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 crypto ->
    -- | Hash of the block body to include in the header
    Hash crypto 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 (ProtoCrypto proto)
  pHeaderIssueNo ::
    ShelleyProtocolHeader proto -> Word64
  -- | VRF value in the header, used to choose between otherwise equally
  -- preferable chains.
  pHeaderVRFValue ::
    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 (ProtoCrypto proto)


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

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