{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Node
  ( MaxMajorProtVer (..)
  , ProtocolParamsShelleyBased (..)
  , SL.Nonce (..)
  , SL.ProtVer (..)
  , SL.ShelleyGenesis (..)
  , SL.ShelleyGenesisStaking (..)
  , SL.emptyGenesisStaking
  , ShelleyLeaderCredentials (..)
  , protocolClientInfoShelley
  , protocolInfoShelley
  , protocolInfoTPraosShelleyBased
  , validateGenesis
  ) where

import qualified Cardano.Ledger.Shelley.API as SL
import Cardano.Protocol.Crypto (Crypto)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits)
import Ouroboros.Consensus.Ledger.SupportsProtocol
  ( LedgerSupportsProtocol
  )
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Node.Run
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Protocol.TPraos
import Ouroboros.Consensus.Shelley.Ledger
import Ouroboros.Consensus.Shelley.Ledger.Inspect ()
import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ()
import Ouroboros.Consensus.Shelley.Node.DiffusionPipelining ()
import Ouroboros.Consensus.Shelley.Node.Serialisation ()
import Ouroboros.Consensus.Shelley.Node.TPraos
import Ouroboros.Consensus.Shelley.Protocol.Abstract
  ( ProtoCrypto
  , pHeaderIssuer
  )

{-------------------------------------------------------------------------------
  ProtocolInfo
-------------------------------------------------------------------------------}

protocolClientInfoShelley :: ProtocolClientInfo (ShelleyBlock proto era)
protocolClientInfoShelley :: forall proto era. ProtocolClientInfo (ShelleyBlock proto era)
protocolClientInfoShelley =
  ProtocolClientInfo
    { -- No particular codec configuration is needed for Shelley
      pClientInfoCodecConfig :: CodecConfig (ShelleyBlock proto era)
pClientInfoCodecConfig = CodecConfig (ShelleyBlock proto era)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
    }

{-------------------------------------------------------------------------------
  RunNode instance
-------------------------------------------------------------------------------}

instance ShelleyCompatible proto era => BlockSupportsMetrics (ShelleyBlock proto era) where
  -- \| Premature optimisation: we assume everywhere that metrics are
  -- cheap, so micro-optimise checking whether the issuer vkey is one of our
  -- own vkeys.
  --
  -- \* Equality of vkeys takes roughly 40ns
  -- \* Hashing a vkey takes roughly 850ns
  -- \* Equality of hashes takes roughly 10ns
  --
  -- We want to avoid the hashing of a vkey as it is more expensive than
  -- simply doing a linear search, comparing vkeys for equality. Only when
  -- we have to do a linear search across a large number of vkeys does it
  -- become more efficient to first hash the vkey and look up its hash in
  -- the map.
  --
  -- We could try to be clever and estimate the number of keys after which
  -- we switch from a linear search to hashing + a O(log n) map lookup, but
  -- we keep it (relatively) simple and optimise for the common case: 0 or 1
  -- key.
  isSelfIssued :: BlockConfig (ShelleyBlock proto era)
-> Header (ShelleyBlock proto era) -> WhetherSelfIssued
isSelfIssued BlockConfig (ShelleyBlock proto era)
cfg (ShelleyHeader ShelleyProtocolHeader proto
shdr ShelleyHash
_) = case Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer) -> Int
forall k a. Map k a -> Int
Map.size Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
issuerVKeys of
    -- The most common case: a non-block producing node
    Int
0 -> WhetherSelfIssued
IsNotSelfIssued
    -- A block producing node with a single set of credentials: just do an
    -- equality check of the single VKey, skipping the more expensive
    -- computation of the hash.
    Int
1
      | ShelleyProtocolHeader proto -> VKey 'BlockIssuer
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> VKey 'BlockIssuer
pHeaderIssuer ShelleyProtocolHeader proto
shdr VKey 'BlockIssuer
-> Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer) -> Bool
forall a. Eq a => a -> Map (KeyHash 'BlockIssuer) a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
issuerVKeys ->
          WhetherSelfIssued
IsSelfIssued
      | Bool
otherwise ->
          WhetherSelfIssued
IsNotSelfIssued
    -- When we are running with multiple sets of credentials, which should
    -- only happen when benchmarking, do a hash lookup, as the number of
    -- keys can grow to 100-250.
    Int
_
      | VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
SL.hashKey (ShelleyProtocolHeader proto -> VKey 'BlockIssuer
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> VKey 'BlockIssuer
pHeaderIssuer ShelleyProtocolHeader proto
shdr) KeyHash 'BlockIssuer
-> Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
issuerVKeys ->
          WhetherSelfIssued
IsSelfIssued
      | Bool
otherwise ->
          WhetherSelfIssued
IsNotSelfIssued
   where
    issuerVKeys ::
      Map
        (SL.KeyHash 'SL.BlockIssuer)
        (SL.VKey 'SL.BlockIssuer)
    issuerVKeys :: Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
issuerVKeys = BlockConfig (ShelleyBlock proto era)
-> Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
forall proto era.
BlockConfig (ShelleyBlock proto era)
-> Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
shelleyBlockIssuerVKeys BlockConfig (ShelleyBlock proto era)
cfg

instance ConsensusProtocol proto => BlockSupportsSanityCheck (ShelleyBlock proto era) where
  configAllSecurityParams :: TopLevelConfig (ShelleyBlock proto era) -> NonEmpty SecurityParam
configAllSecurityParams = SecurityParam -> NonEmpty SecurityParam
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SecurityParam -> NonEmpty SecurityParam)
-> (TopLevelConfig (ShelleyBlock proto era) -> SecurityParam)
-> TopLevelConfig (ShelleyBlock proto era)
-> NonEmpty SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig proto -> SecurityParam
forall p. ConsensusProtocol p => ConsensusConfig p -> SecurityParam
protocolSecurityParam (ConsensusConfig proto -> SecurityParam)
-> (TopLevelConfig (ShelleyBlock proto era)
    -> ConsensusConfig proto)
-> TopLevelConfig (ShelleyBlock proto era)
-> SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig (ShelleyBlock proto era) -> ConsensusConfig proto
TopLevelConfig (ShelleyBlock proto era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock proto era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
topLevelConfigProtocol

instance
  ( ShelleyCompatible proto era
  , LedgerSupportsProtocol (ShelleyBlock proto era)
  , BlockSupportsSanityCheck (ShelleyBlock proto era)
  , TxLimits (ShelleyBlock proto era)
  , SerialiseNodeToClientConstraints (ShelleyBlock proto era)
  , Crypto (ProtoCrypto proto)
  ) =>
  RunNode (ShelleyBlock proto era)