{-# 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)