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

-- | Node configuration common to all (era, protocol) combinations deriving from
-- Shelley.
module Ouroboros.Consensus.Shelley.Node.Common
  ( ProtocolParamsShelleyBased (..)
  , ShelleyEraWithCrypto
  , ShelleyLeaderCredentials (..)
  , shelleyBlockIssuerVKey
  ) where

import Cardano.Crypto.KES (UnsoundPureSignKeyKES)
import Cardano.Ledger.BaseTypes (unNonZero)
import qualified Cardano.Ledger.Keys as SL
import qualified Cardano.Ledger.Shelley.API as SL
import Cardano.Ledger.Slot
import Cardano.Protocol.Crypto
import Data.Text (Text)
import Ouroboros.Consensus.Block
  ( CannotForge
  , ForgeStateInfo
  , ForgeStateUpdateError
  )
import Ouroboros.Consensus.Config (maxRollbacks)
import Ouroboros.Consensus.Config.SupportsNode
import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits)
import Ouroboros.Consensus.Node.InitStorage
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import Ouroboros.Consensus.Protocol.Praos.Common
  ( PraosCanBeLeader (praosCanBeLeaderColdVerKey)
  )
import Ouroboros.Consensus.Shelley.Ledger
  ( ShelleyBlock
  , ShelleyCompatible
  , shelleyNetworkMagic
  , shelleyStorageConfigSecurityParam
  , shelleyStorageConfigSlotsPerKESPeriod
  , shelleySystemStart
  , verifyBlockIntegrity
  )
import Ouroboros.Consensus.Shelley.Protocol.Abstract
  ( ProtoCrypto
  , ProtocolHeaderSupportsProtocol (CannotForgeError)
  )
import Ouroboros.Consensus.Storage.ImmutableDB

{-------------------------------------------------------------------------------
  Credentials
-------------------------------------------------------------------------------}

data ShelleyLeaderCredentials c = ShelleyLeaderCredentials
  { forall c.
ShelleyLeaderCredentials c -> UnsoundPureSignKeyKES (KES c)
shelleyLeaderCredentialsInitSignKey :: UnsoundPureSignKeyKES (KES c)
  -- ^ The unevolved signing KES key (at evolution 0).
  --
  -- Note that this is not inside 'ShelleyCanBeLeader' since it gets evolved
  -- automatically, whereas 'ShelleyCanBeLeader' does not change.
  , forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader :: PraosCanBeLeader c
  , forall c. ShelleyLeaderCredentials c -> Text
shelleyLeaderCredentialsLabel :: Text
  -- ^ Identifier for this set of credentials.
  --
  -- Useful when the node is running with multiple sets of credentials.
  }

shelleyBlockIssuerVKey ::
  ShelleyLeaderCredentials c -> SL.VKey 'SL.BlockIssuer
shelleyBlockIssuerVKey :: forall c. ShelleyLeaderCredentials c -> VKey 'BlockIssuer
shelleyBlockIssuerVKey =
  PraosCanBeLeader c -> VKey 'BlockIssuer
forall c. PraosCanBeLeader c -> VKey 'BlockIssuer
praosCanBeLeaderColdVerKey (PraosCanBeLeader c -> VKey 'BlockIssuer)
-> (ShelleyLeaderCredentials c -> PraosCanBeLeader c)
-> ShelleyLeaderCredentials c
-> VKey 'BlockIssuer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLeaderCredentials c -> PraosCanBeLeader c
forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader

{-------------------------------------------------------------------------------
  BlockForging
-------------------------------------------------------------------------------}

type instance CannotForge (ShelleyBlock proto era) = CannotForgeError proto

type instance ForgeStateInfo (ShelleyBlock proto era) = HotKey.KESInfo

type instance ForgeStateUpdateError (ShelleyBlock proto era) = HotKey.KESEvolutionError

-- | Needed in '*SharedBlockForging' because we can't partially apply
-- equality constraints.
class
  (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era), ProtoCrypto proto ~ c) =>
  ShelleyEraWithCrypto c proto era

instance
  (ShelleyCompatible proto era, TxLimits (ShelleyBlock proto era), ProtoCrypto proto ~ c) =>
  ShelleyEraWithCrypto c proto era

{-------------------------------------------------------------------------------
  ConfigSupportsNode instance
-------------------------------------------------------------------------------}

instance ConfigSupportsNode (ShelleyBlock proto era) where
  getSystemStart :: BlockConfig (ShelleyBlock proto era) -> SystemStart
getSystemStart = BlockConfig (ShelleyBlock proto era) -> SystemStart
forall proto era.
BlockConfig (ShelleyBlock proto era) -> SystemStart
shelleySystemStart
  getNetworkMagic :: BlockConfig (ShelleyBlock proto era) -> NetworkMagic
getNetworkMagic = BlockConfig (ShelleyBlock proto era) -> NetworkMagic
forall proto era.
BlockConfig (ShelleyBlock proto era) -> NetworkMagic
shelleyNetworkMagic

{-------------------------------------------------------------------------------
  NodeInitStorage instance
-------------------------------------------------------------------------------}

instance ShelleyCompatible proto era => NodeInitStorage (ShelleyBlock proto era) where
  -- We fix the chunk size to @10k@ so that we have the same chunk size as
  -- Byron. Consequently, a Shelley net will have the same chunk size as the
  -- Byron-to-Shelley net with the same @k@.
  nodeImmutableDbChunkInfo :: StorageConfig (ShelleyBlock proto era) -> ChunkInfo
nodeImmutableDbChunkInfo =
    EpochSize -> ChunkInfo
simpleChunkInfo
      (EpochSize -> ChunkInfo)
-> (StorageConfig (ShelleyBlock proto era) -> EpochSize)
-> StorageConfig (ShelleyBlock proto era)
-> ChunkInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> EpochSize
EpochSize
      (Word64 -> EpochSize)
-> (StorageConfig (ShelleyBlock proto era) -> Word64)
-> StorageConfig (ShelleyBlock proto era)
-> EpochSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
10)
      (Word64 -> Word64)
-> (StorageConfig (ShelleyBlock proto era) -> Word64)
-> StorageConfig (ShelleyBlock proto era)
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero
      (NonZero Word64 -> Word64)
-> (StorageConfig (ShelleyBlock proto era) -> NonZero Word64)
-> StorageConfig (ShelleyBlock proto era)
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecurityParam -> NonZero Word64
maxRollbacks
      (SecurityParam -> NonZero Word64)
-> (StorageConfig (ShelleyBlock proto era) -> SecurityParam)
-> StorageConfig (ShelleyBlock proto era)
-> NonZero Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageConfig (ShelleyBlock proto era) -> SecurityParam
forall proto era.
StorageConfig (ShelleyBlock proto era) -> SecurityParam
shelleyStorageConfigSecurityParam

  nodeCheckIntegrity :: StorageConfig (ShelleyBlock proto era)
-> ShelleyBlock proto era -> Bool
nodeCheckIntegrity StorageConfig (ShelleyBlock proto era)
cfg =
    Word64 -> ShelleyBlock proto era -> Bool
forall proto era.
ShelleyCompatible proto era =>
Word64 -> ShelleyBlock proto era -> Bool
verifyBlockIntegrity (StorageConfig (ShelleyBlock proto era) -> Word64
forall proto era. StorageConfig (ShelleyBlock proto era) -> Word64
shelleyStorageConfigSlotsPerKESPeriod StorageConfig (ShelleyBlock proto era)
cfg)

{-------------------------------------------------------------------------------
  Protocol parameters
-------------------------------------------------------------------------------}

-- | Parameters common to all Shelley-based ledgers.
--
-- When running a chain with multiple Shelley-based eras, in addition to the
-- per-era protocol parameters, one value of 'ProtocolParamsShelleyBased' will
-- be needed, which is shared among all Shelley-based eras.
data ProtocolParamsShelleyBased c = ProtocolParamsShelleyBased
  { forall c. ProtocolParamsShelleyBased c -> Nonce
shelleyBasedInitialNonce :: SL.Nonce
  -- ^ The initial nonce, typically derived from the hash of Genesis
  -- config JSON file.
  --
  -- WARNING: chains using different values of this parameter will be
  -- mutually incompatible.
  , forall c.
ProtocolParamsShelleyBased c -> [ShelleyLeaderCredentials c]
shelleyBasedLeaderCredentials :: [ShelleyLeaderCredentials c]
  }