{-# 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 (..)
  , ProtocolParamsAllegra (..)
  , ProtocolParamsAlonzo (..)
  , ProtocolParamsMary (..)
  , ProtocolParamsShelley (..)
  , ProtocolParamsShelleyBased (..)
  , SL.Nonce (..)
  , SL.ProtVer (..)
  , SL.ShelleyGenesis (..)
  , SL.ShelleyGenesisStaking (..)
  , SL.emptyGenesisStaking
  , ShelleyLeaderCredentials (..)
  , protocolClientInfoShelley
  , protocolInfoShelley
  , protocolInfoTPraosShelleyBased
  , registerGenesisStaking
  , registerInitialFunds
  , validateGenesis
  ) where



import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.Node.Run

import qualified Cardano.Ledger.Shelley.API as SL

import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol)
import           Ouroboros.Consensus.Protocol.TPraos
import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import           Ouroboros.Consensus.Shelley.Ledger
import           Ouroboros.Consensus.Shelley.Ledger.Inspect ()
import           Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ()
import           Ouroboros.Consensus.Shelley.Node.Serialisation ()
import           Ouroboros.Consensus.Shelley.Node.TPraos
import           Ouroboros.Consensus.Shelley.Protocol.Abstract (pHeaderIssuer)
{-------------------------------------------------------------------------------
  ProtocolInfo
-------------------------------------------------------------------------------}



protocolClientInfoShelley :: ProtocolClientInfo (ShelleyBlock proto era)
protocolClientInfoShelley :: ProtocolClientInfo (ShelleyBlock proto era)
protocolClientInfoShelley =
    ProtocolClientInfo :: forall b. CodecConfig b -> ProtocolClientInfo b
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 shdr _) = case Map
  (KeyHash 'BlockIssuer (ProtoCrypto proto))
  (VKey 'BlockIssuer (ProtoCrypto proto))
-> Int
forall k a. Map k a -> Int
Map.size Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
Map
  (KeyHash 'BlockIssuer (ProtoCrypto proto))
  (VKey 'BlockIssuer (ProtoCrypto proto))
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 (ProtoCrypto proto)
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto
-> VKey 'BlockIssuer (ProtoCrypto proto)
pHeaderIssuer ShelleyProtocolHeader proto
shdr VKey 'BlockIssuer (ProtoCrypto proto)
-> Map
     (KeyHash 'BlockIssuer (ProtoCrypto proto))
     (VKey 'BlockIssuer (ProtoCrypto proto))
-> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
Map
  (KeyHash 'BlockIssuer (ProtoCrypto proto))
  (VKey 'BlockIssuer (ProtoCrypto proto))
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 (ProtoCrypto proto)
-> KeyHash 'BlockIssuer (ProtoCrypto proto)
forall crypto (kd :: KeyRole).
Crypto crypto =>
VKey kd crypto -> KeyHash kd crypto
SL.hashKey (ShelleyProtocolHeader proto
-> VKey 'BlockIssuer (ProtoCrypto proto)
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto
-> VKey 'BlockIssuer (ProtoCrypto proto)
pHeaderIssuer ShelleyProtocolHeader proto
shdr) KeyHash 'BlockIssuer (ProtoCrypto proto)
-> Map
     (KeyHash 'BlockIssuer (ProtoCrypto proto))
     (VKey 'BlockIssuer (ProtoCrypto proto))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
Map
  (KeyHash 'BlockIssuer (ProtoCrypto proto))
  (VKey 'BlockIssuer (ProtoCrypto proto))
issuerVKeys
        -> WhetherSelfIssued
IsSelfIssued
        | Bool
otherwise
        -> WhetherSelfIssued
IsNotSelfIssued
    where

      issuerVKeys :: Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era))
                         (SL.VKey 'SL.BlockIssuer (EraCrypto era))
      issuerVKeys :: Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
issuerVKeys = BlockConfig (ShelleyBlock proto era)
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
forall proto era.
BlockConfig (ShelleyBlock proto era)
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
shelleyBlockIssuerVKeys BlockConfig (ShelleyBlock proto era)
cfg


instance (ShelleyCompatible proto era, LedgerSupportsProtocol (ShelleyBlock proto era))
  => RunNode (ShelleyBlock proto era)