{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Ledger.Config (
    BlockConfig (..)
  , CodecConfig (..)
  , StorageConfig (..)
  , compactGenesis
  , getCompactGenesis
  , mkShelleyBlockConfig
    -- * opaque
  , CompactGenesis
  ) where

import           Cardano.Ledger.Binary (FromCBOR, ToCBOR)
import qualified Cardano.Ledger.Shelley.API as SL
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Word (Word64)
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks (..))
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Protocol.Praos.Common
                     (VRFTiebreakerFlavor (..))
import           Ouroboros.Consensus.Shelley.Eras (isBeforeConway)
import           Ouroboros.Consensus.Shelley.Ledger.Block
import           Ouroboros.Network.Magic (NetworkMagic (..))

{-------------------------------------------------------------------------------
  Additional node configuration
-------------------------------------------------------------------------------}

data instance BlockConfig (ShelleyBlock proto era) = ShelleyConfig {
      -- | The highest protocol version this node supports. It will be stored
      -- the headers of produced blocks.
      forall proto era. BlockConfig (ShelleyBlock proto era) -> ProtVer
shelleyProtocolVersion     :: !SL.ProtVer
    , forall proto era.
BlockConfig (ShelleyBlock proto era) -> SystemStart
shelleySystemStart         :: !SystemStart
    , forall proto era.
BlockConfig (ShelleyBlock proto era) -> NetworkMagic
shelleyNetworkMagic        :: !NetworkMagic
      -- | For nodes that can produce blocks, this should be set to the
      -- verification key(s) corresponding to the node's signing key(s). For non
      -- block producing nodes, this can be set to the empty map.
    , forall proto era.
BlockConfig (ShelleyBlock proto era)
-> Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
shelleyBlockIssuerVKeys    :: !(Map (SL.KeyHash 'SL.BlockIssuer)
                                          (SL.VKey 'SL.BlockIssuer))
    , forall proto era.
BlockConfig (ShelleyBlock proto era) -> VRFTiebreakerFlavor
shelleyVRFTiebreakerFlavor :: !VRFTiebreakerFlavor
    }
  deriving stock ((forall x.
 BlockConfig (ShelleyBlock proto era)
 -> Rep (BlockConfig (ShelleyBlock proto era)) x)
-> (forall x.
    Rep (BlockConfig (ShelleyBlock proto era)) x
    -> BlockConfig (ShelleyBlock proto era))
-> Generic (BlockConfig (ShelleyBlock proto era))
forall x.
Rep (BlockConfig (ShelleyBlock proto era)) x
-> BlockConfig (ShelleyBlock proto era)
forall x.
BlockConfig (ShelleyBlock proto era)
-> Rep (BlockConfig (ShelleyBlock proto era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (BlockConfig (ShelleyBlock proto era)) x
-> BlockConfig (ShelleyBlock proto era)
forall proto era x.
BlockConfig (ShelleyBlock proto era)
-> Rep (BlockConfig (ShelleyBlock proto era)) x
$cfrom :: forall proto era x.
BlockConfig (ShelleyBlock proto era)
-> Rep (BlockConfig (ShelleyBlock proto era)) x
from :: forall x.
BlockConfig (ShelleyBlock proto era)
-> Rep (BlockConfig (ShelleyBlock proto era)) x
$cto :: forall proto era x.
Rep (BlockConfig (ShelleyBlock proto era)) x
-> BlockConfig (ShelleyBlock proto era)
to :: forall x.
Rep (BlockConfig (ShelleyBlock proto era)) x
-> BlockConfig (ShelleyBlock proto era)
Generic)

deriving instance ShelleyBasedEra era => Show     (BlockConfig (ShelleyBlock proto era))
deriving instance ShelleyBasedEra era => NoThunks (BlockConfig (ShelleyBlock proto era))

mkShelleyBlockConfig ::
     forall proto era. ShelleyBasedEra era
  => SL.ProtVer
  -> SL.ShelleyGenesis
  -> [SL.VKey 'SL.BlockIssuer]
  -> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig :: forall proto era.
ShelleyBasedEra era =>
ProtVer
-> ShelleyGenesis
-> [VKey 'BlockIssuer]
-> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig ProtVer
protVer ShelleyGenesis
genesis [VKey 'BlockIssuer]
blockIssuerVKeys = ShelleyConfig {
      shelleyProtocolVersion :: ProtVer
shelleyProtocolVersion     = ProtVer
protVer
    , shelleySystemStart :: SystemStart
shelleySystemStart         = UTCTime -> SystemStart
SystemStart  (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> UTCTime
SL.sgSystemStart  ShelleyGenesis
genesis
    , shelleyNetworkMagic :: NetworkMagic
shelleyNetworkMagic        = Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkMagic) -> Word32 -> NetworkMagic
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> Word32
SL.sgNetworkMagic ShelleyGenesis
genesis
    , shelleyBlockIssuerVKeys :: Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
shelleyBlockIssuerVKeys    = [(KeyHash 'BlockIssuer, VKey 'BlockIssuer)]
-> Map (KeyHash 'BlockIssuer) (VKey 'BlockIssuer)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (VKey 'BlockIssuer -> KeyHash 'BlockIssuer
forall (kd :: KeyRole). VKey kd -> KeyHash kd
SL.hashKey VKey 'BlockIssuer
k, VKey 'BlockIssuer
k)
        | VKey 'BlockIssuer
k <- [VKey 'BlockIssuer]
blockIssuerVKeys
        ]
    , VRFTiebreakerFlavor
shelleyVRFTiebreakerFlavor :: VRFTiebreakerFlavor
shelleyVRFTiebreakerFlavor :: VRFTiebreakerFlavor
shelleyVRFTiebreakerFlavor
    }
  where
    shelleyVRFTiebreakerFlavor :: VRFTiebreakerFlavor
shelleyVRFTiebreakerFlavor
      | Proxy era -> Bool
forall era. Era era => Proxy era -> Bool
isBeforeConway (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @era)
      = VRFTiebreakerFlavor
UnrestrictedVRFTiebreaker
      | Bool
otherwise
      -- See 'RestrictedVRFTiebreaker' for context. 5 slots is the "usual" value
      -- we consider when talking about the maximum propagation delay.
      = SlotNo -> VRFTiebreakerFlavor
RestrictedVRFTiebreaker SlotNo
5

{-------------------------------------------------------------------------------
  Codec config
-------------------------------------------------------------------------------}

-- | No particular codec configuration is needed for Shelley
data instance CodecConfig (ShelleyBlock proto era) = ShelleyCodecConfig
  deriving ((forall x.
 CodecConfig (ShelleyBlock proto era)
 -> Rep (CodecConfig (ShelleyBlock proto era)) x)
-> (forall x.
    Rep (CodecConfig (ShelleyBlock proto era)) x
    -> CodecConfig (ShelleyBlock proto era))
-> Generic (CodecConfig (ShelleyBlock proto era))
forall x.
Rep (CodecConfig (ShelleyBlock proto era)) x
-> CodecConfig (ShelleyBlock proto era)
forall x.
CodecConfig (ShelleyBlock proto era)
-> Rep (CodecConfig (ShelleyBlock proto era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (CodecConfig (ShelleyBlock proto era)) x
-> CodecConfig (ShelleyBlock proto era)
forall proto era x.
CodecConfig (ShelleyBlock proto era)
-> Rep (CodecConfig (ShelleyBlock proto era)) x
$cfrom :: forall proto era x.
CodecConfig (ShelleyBlock proto era)
-> Rep (CodecConfig (ShelleyBlock proto era)) x
from :: forall x.
CodecConfig (ShelleyBlock proto era)
-> Rep (CodecConfig (ShelleyBlock proto era)) x
$cto :: forall proto era x.
Rep (CodecConfig (ShelleyBlock proto era)) x
-> CodecConfig (ShelleyBlock proto era)
to :: forall x.
Rep (CodecConfig (ShelleyBlock proto era)) x
-> CodecConfig (ShelleyBlock proto era)
Generic, Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
Proxy (CodecConfig (ShelleyBlock proto era)) -> String
(Context
 -> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo))
-> (Context
    -> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo))
-> (Proxy (CodecConfig (ShelleyBlock proto era)) -> String)
-> NoThunks (CodecConfig (ShelleyBlock proto era))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall proto era.
Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
forall proto era.
Proxy (CodecConfig (ShelleyBlock proto era)) -> String
$cnoThunks :: forall proto era.
Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall proto era.
Proxy (CodecConfig (ShelleyBlock proto era)) -> String
showTypeOf :: Proxy (CodecConfig (ShelleyBlock proto era)) -> String
NoThunks)

{-------------------------------------------------------------------------------
  Storage config
-------------------------------------------------------------------------------}

data instance StorageConfig (ShelleyBlock proto era) = ShelleyStorageConfig {
      -- | Needed for 'nodeCheckIntegrity'
      forall proto era. StorageConfig (ShelleyBlock proto era) -> Word64
shelleyStorageConfigSlotsPerKESPeriod :: !Word64
      -- | Needed for 'nodeImmutableDbChunkInfo'
    , forall proto era.
StorageConfig (ShelleyBlock proto era) -> SecurityParam
shelleyStorageConfigSecurityParam     :: !SecurityParam
    }
  deriving ((forall x.
 StorageConfig (ShelleyBlock proto era)
 -> Rep (StorageConfig (ShelleyBlock proto era)) x)
-> (forall x.
    Rep (StorageConfig (ShelleyBlock proto era)) x
    -> StorageConfig (ShelleyBlock proto era))
-> Generic (StorageConfig (ShelleyBlock proto era))
forall x.
Rep (StorageConfig (ShelleyBlock proto era)) x
-> StorageConfig (ShelleyBlock proto era)
forall x.
StorageConfig (ShelleyBlock proto era)
-> Rep (StorageConfig (ShelleyBlock proto era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall proto era x.
Rep (StorageConfig (ShelleyBlock proto era)) x
-> StorageConfig (ShelleyBlock proto era)
forall proto era x.
StorageConfig (ShelleyBlock proto era)
-> Rep (StorageConfig (ShelleyBlock proto era)) x
$cfrom :: forall proto era x.
StorageConfig (ShelleyBlock proto era)
-> Rep (StorageConfig (ShelleyBlock proto era)) x
from :: forall x.
StorageConfig (ShelleyBlock proto era)
-> Rep (StorageConfig (ShelleyBlock proto era)) x
$cto :: forall proto era x.
Rep (StorageConfig (ShelleyBlock proto era)) x
-> StorageConfig (ShelleyBlock proto era)
to :: forall x.
Rep (StorageConfig (ShelleyBlock proto era)) x
-> StorageConfig (ShelleyBlock proto era)
Generic, Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
Proxy (StorageConfig (ShelleyBlock proto era)) -> String
(Context
 -> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo))
-> (Context
    -> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo))
-> (Proxy (StorageConfig (ShelleyBlock proto era)) -> String)
-> NoThunks (StorageConfig (ShelleyBlock proto era))
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall proto era.
Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
forall proto era.
Proxy (StorageConfig (ShelleyBlock proto era)) -> String
$cnoThunks :: forall proto era.
Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall proto era.
Proxy (StorageConfig (ShelleyBlock proto era)) -> String
showTypeOf :: Proxy (StorageConfig (ShelleyBlock proto era)) -> String
NoThunks)

{-------------------------------------------------------------------------------
  Compact genesis
-------------------------------------------------------------------------------}

-- | Compact variant of 'SL.ShelleyGenesis' with some fields erased that are
-- only used on start-up and that should not be kept in memory forever.
--
-- Concretely:
--
-- * The 'sgInitialFunds' field is erased. It is only used to set up the initial
--   UTxO in tests and testnets.
--
-- * The 'sgStaking' field is erased. It is only used to register initial stake
--   pools in tests and benchmarks.
newtype CompactGenesis = CompactGenesis { CompactGenesis -> ShelleyGenesis
getCompactGenesis :: SL.ShelleyGenesis }
  deriving stock (CompactGenesis -> CompactGenesis -> Bool
(CompactGenesis -> CompactGenesis -> Bool)
-> (CompactGenesis -> CompactGenesis -> Bool) -> Eq CompactGenesis
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompactGenesis -> CompactGenesis -> Bool
== :: CompactGenesis -> CompactGenesis -> Bool
$c/= :: CompactGenesis -> CompactGenesis -> Bool
/= :: CompactGenesis -> CompactGenesis -> Bool
Eq, Int -> CompactGenesis -> ShowS
[CompactGenesis] -> ShowS
CompactGenesis -> String
(Int -> CompactGenesis -> ShowS)
-> (CompactGenesis -> String)
-> ([CompactGenesis] -> ShowS)
-> Show CompactGenesis
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompactGenesis -> ShowS
showsPrec :: Int -> CompactGenesis -> ShowS
$cshow :: CompactGenesis -> String
show :: CompactGenesis -> String
$cshowList :: [CompactGenesis] -> ShowS
showList :: [CompactGenesis] -> ShowS
Show, (forall x. CompactGenesis -> Rep CompactGenesis x)
-> (forall x. Rep CompactGenesis x -> CompactGenesis)
-> Generic CompactGenesis
forall x. Rep CompactGenesis x -> CompactGenesis
forall x. CompactGenesis -> Rep CompactGenesis x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CompactGenesis -> Rep CompactGenesis x
from :: forall x. CompactGenesis -> Rep CompactGenesis x
$cto :: forall x. Rep CompactGenesis x -> CompactGenesis
to :: forall x. Rep CompactGenesis x -> CompactGenesis
Generic)
  deriving newtype (Typeable CompactGenesis
Typeable CompactGenesis =>
(CompactGenesis -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy CompactGenesis -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy [CompactGenesis] -> Size)
-> ToCBOR CompactGenesis
CompactGenesis -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy CompactGenesis -> Size
forall a.
Typeable a =>
(a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
$ctoCBOR :: CompactGenesis -> Encoding
toCBOR :: CompactGenesis -> Encoding
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy CompactGenesis -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy CompactGenesis -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis] -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis] -> Size
ToCBOR, Typeable CompactGenesis
Typeable CompactGenesis =>
(forall s. Decoder s CompactGenesis)
-> (Proxy CompactGenesis -> Text) -> FromCBOR CompactGenesis
Proxy CompactGenesis -> Text
forall s. Decoder s CompactGenesis
forall a.
Typeable a =>
(forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
$cfromCBOR :: forall s. Decoder s CompactGenesis
fromCBOR :: forall s. Decoder s CompactGenesis
$clabel :: Proxy CompactGenesis -> Text
label :: Proxy CompactGenesis -> Text
FromCBOR)

deriving anyclass instance NoThunks CompactGenesis

-- | Compacts the given 'SL.ShelleyGenesis'.
compactGenesis :: SL.ShelleyGenesis -> CompactGenesis
compactGenesis :: ShelleyGenesis -> CompactGenesis
compactGenesis ShelleyGenesis
genesis = ShelleyGenesis -> CompactGenesis
CompactGenesis (ShelleyGenesis -> CompactGenesis)
-> ShelleyGenesis -> CompactGenesis
forall a b. (a -> b) -> a -> b
$
    ShelleyGenesis
genesis {
        SL.sgInitialFunds = mempty
      , SL.sgStaking      = SL.emptyGenesisStaking
      }