{-# 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           Cardano.Ledger.Crypto (Crypto)
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 (EraCrypto, 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 (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
shelleyBlockIssuerVKeys    :: !(Map (SL.KeyHash 'SL.BlockIssuer (EraCrypto era))
                                          (SL.VKey 'SL.BlockIssuer (EraCrypto era)))
    , 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 (EraCrypto era)
  -> [SL.VKey 'SL.BlockIssuer (EraCrypto era)]
  -> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig :: forall proto era.
ShelleyBasedEra era =>
ProtVer
-> ShelleyGenesis (EraCrypto era)
-> [VKey 'BlockIssuer (EraCrypto era)]
-> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig ProtVer
protVer ShelleyGenesis (EraCrypto era)
genesis [VKey 'BlockIssuer (EraCrypto era)]
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 (EraCrypto era) -> UTCTime
forall c. ShelleyGenesis c -> UTCTime
SL.sgSystemStart  ShelleyGenesis (EraCrypto era)
genesis
    , shelleyNetworkMagic :: NetworkMagic
shelleyNetworkMagic        = Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkMagic) -> Word32 -> NetworkMagic
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis (EraCrypto era) -> Word32
forall c. ShelleyGenesis c -> Word32
SL.sgNetworkMagic ShelleyGenesis (EraCrypto era)
genesis
    , shelleyBlockIssuerVKeys :: Map
  (KeyHash 'BlockIssuer (EraCrypto era))
  (VKey 'BlockIssuer (EraCrypto era))
shelleyBlockIssuerVKeys    = [(KeyHash 'BlockIssuer (EraCrypto era),
  VKey 'BlockIssuer (EraCrypto era))]
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (VKey 'BlockIssuer (EraCrypto era)
-> KeyHash 'BlockIssuer (EraCrypto era)
forall c (kd :: KeyRole). Crypto c => VKey kd c -> KeyHash kd c
SL.hashKey VKey 'BlockIssuer (EraCrypto era)
k, VKey 'BlockIssuer (EraCrypto era)
k)
        | VKey 'BlockIssuer (EraCrypto era)
k <- [VKey 'BlockIssuer (EraCrypto era)]
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 c = CompactGenesis {
      forall c. CompactGenesis c -> ShelleyGenesis c
getCompactGenesis :: SL.ShelleyGenesis c
    }
  deriving stock (CompactGenesis c -> CompactGenesis c -> Bool
(CompactGenesis c -> CompactGenesis c -> Bool)
-> (CompactGenesis c -> CompactGenesis c -> Bool)
-> Eq (CompactGenesis c)
forall c. Crypto c => CompactGenesis c -> CompactGenesis c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall c. Crypto c => CompactGenesis c -> CompactGenesis c -> Bool
== :: CompactGenesis c -> CompactGenesis c -> Bool
$c/= :: forall c. Crypto c => CompactGenesis c -> CompactGenesis c -> Bool
/= :: CompactGenesis c -> CompactGenesis c -> Bool
Eq, Int -> CompactGenesis c -> ShowS
[CompactGenesis c] -> ShowS
CompactGenesis c -> String
(Int -> CompactGenesis c -> ShowS)
-> (CompactGenesis c -> String)
-> ([CompactGenesis c] -> ShowS)
-> Show (CompactGenesis c)
forall c. Crypto c => Int -> CompactGenesis c -> ShowS
forall c. Crypto c => [CompactGenesis c] -> ShowS
forall c. Crypto c => CompactGenesis c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall c. Crypto c => Int -> CompactGenesis c -> ShowS
showsPrec :: Int -> CompactGenesis c -> ShowS
$cshow :: forall c. Crypto c => CompactGenesis c -> String
show :: CompactGenesis c -> String
$cshowList :: forall c. Crypto c => [CompactGenesis c] -> ShowS
showList :: [CompactGenesis c] -> ShowS
Show, (forall x. CompactGenesis c -> Rep (CompactGenesis c) x)
-> (forall x. Rep (CompactGenesis c) x -> CompactGenesis c)
-> Generic (CompactGenesis c)
forall x. Rep (CompactGenesis c) x -> CompactGenesis c
forall x. CompactGenesis c -> Rep (CompactGenesis c) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (CompactGenesis c) x -> CompactGenesis c
forall c x. CompactGenesis c -> Rep (CompactGenesis c) x
$cfrom :: forall c x. CompactGenesis c -> Rep (CompactGenesis c) x
from :: forall x. CompactGenesis c -> Rep (CompactGenesis c) x
$cto :: forall c x. Rep (CompactGenesis c) x -> CompactGenesis c
to :: forall x. Rep (CompactGenesis c) x -> CompactGenesis c
Generic)
  deriving newtype (Typeable (CompactGenesis c)
Typeable (CompactGenesis c) =>
(CompactGenesis c -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy (CompactGenesis c) -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy [CompactGenesis c] -> Size)
-> ToCBOR (CompactGenesis c)
CompactGenesis c -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis c] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CompactGenesis c) -> 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
forall c. Crypto c => Typeable (CompactGenesis c)
forall c. Crypto c => CompactGenesis c -> Encoding
forall c.
Crypto c =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis c] -> Size
forall c.
Crypto c =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CompactGenesis c) -> Size
$ctoCBOR :: forall c. Crypto c => CompactGenesis c -> Encoding
toCBOR :: CompactGenesis c -> Encoding
$cencodedSizeExpr :: forall c.
Crypto c =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CompactGenesis c) -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CompactGenesis c) -> Size
$cencodedListSizeExpr :: forall c.
Crypto c =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis c] -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis c] -> Size
ToCBOR, Typeable (CompactGenesis c)
Typeable (CompactGenesis c) =>
(forall s. Decoder s (CompactGenesis c))
-> (Proxy (CompactGenesis c) -> Text)
-> FromCBOR (CompactGenesis c)
Proxy (CompactGenesis c) -> Text
forall s. Decoder s (CompactGenesis c)
forall a.
Typeable a =>
(forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
forall c. Crypto c => Typeable (CompactGenesis c)
forall c. Crypto c => Proxy (CompactGenesis c) -> Text
forall c s. Crypto c => Decoder s (CompactGenesis c)
$cfromCBOR :: forall c s. Crypto c => Decoder s (CompactGenesis c)
fromCBOR :: forall s. Decoder s (CompactGenesis c)
$clabel :: forall c. Crypto c => Proxy (CompactGenesis c) -> Text
label :: Proxy (CompactGenesis c) -> Text
FromCBOR)

deriving anyclass instance Crypto c => NoThunks (CompactGenesis c)

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