{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingVia                #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Shelley.Ledger.Config (
    BlockConfig (..)
  , CodecConfig (..)
  , StorageConfig (..)
  , compactGenesis
  , getCompactGenesis
  , mkShelleyBlockConfig
    -- * opaque
  , CompactGenesis
  ) where

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           Cardano.Binary (FromCBOR, ToCBOR)

import           Ouroboros.Network.Magic (NetworkMagic (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Config

import qualified Cardano.Ledger.Shelley.API as SL

import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import           Ouroboros.Consensus.Shelley.Ledger.Block

{-------------------------------------------------------------------------------
  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.
      BlockConfig (ShelleyBlock proto era) -> ProtVer
shelleyProtocolVersion  :: !SL.ProtVer
    , BlockConfig (ShelleyBlock proto era) -> SystemStart
shelleySystemStart      :: !SystemStart
    , 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.
    , 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)))
    }
  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
$cto :: forall proto era x.
Rep (BlockConfig (ShelleyBlock proto era)) x
-> BlockConfig (ShelleyBlock proto era)
$cfrom :: forall proto era x.
BlockConfig (ShelleyBlock proto era)
-> Rep (BlockConfig (ShelleyBlock proto era)) x
Generic)

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

mkShelleyBlockConfig ::
     ShelleyBasedEra era
  => SL.ProtVer
  -> SL.ShelleyGenesis era
  -> [SL.VKey 'SL.BlockIssuer (EraCrypto era)]
  -> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig :: ProtVer
-> ShelleyGenesis era
-> [VKey 'BlockIssuer (EraCrypto era)]
-> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig ProtVer
protVer ShelleyGenesis era
genesis [VKey 'BlockIssuer (EraCrypto era)]
blockIssuerVKeys = ShelleyConfig :: forall proto era.
ProtVer
-> SystemStart
-> NetworkMagic
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
-> BlockConfig (ShelleyBlock proto era)
ShelleyConfig {
      shelleyProtocolVersion :: ProtVer
shelleyProtocolVersion  = ProtVer
protVer
    , shelleySystemStart :: SystemStart
shelleySystemStart      = UTCTime -> SystemStart
SystemStart  (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis era -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
SL.sgSystemStart  ShelleyGenesis era
genesis
    , shelleyNetworkMagic :: NetworkMagic
shelleyNetworkMagic     = Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkMagic) -> Word32 -> NetworkMagic
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis era -> Word32
forall era. ShelleyGenesis era -> Word32
SL.sgNetworkMagic ShelleyGenesis 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 crypto (kd :: KeyRole).
Crypto crypto =>
VKey kd crypto -> KeyHash kd crypto
SL.hashKey VKey 'BlockIssuer (EraCrypto era)
k, VKey 'BlockIssuer (EraCrypto era)
k)
        | VKey 'BlockIssuer (EraCrypto era)
k <- [VKey 'BlockIssuer (EraCrypto era)]
blockIssuerVKeys
        ]
    }

{-------------------------------------------------------------------------------
  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
$cto :: forall proto era x.
Rep (CodecConfig (ShelleyBlock proto era)) x
-> CodecConfig (ShelleyBlock proto era)
$cfrom :: forall proto era x.
CodecConfig (ShelleyBlock proto era)
-> Rep (CodecConfig (ShelleyBlock proto era)) x
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
showTypeOf :: Proxy (CodecConfig (ShelleyBlock proto era)) -> String
$cshowTypeOf :: forall proto era.
Proxy (CodecConfig (ShelleyBlock proto era)) -> String
wNoThunks :: Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
$cnoThunks :: forall proto era.
Context
-> CodecConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
NoThunks)

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

data instance StorageConfig (ShelleyBlock proto era) = ShelleyStorageConfig {
      -- | Needed for 'nodeCheckIntegrity'
      StorageConfig (ShelleyBlock proto era) -> Word64
shelleyStorageConfigSlotsPerKESPeriod :: !Word64
      -- | Needed for 'nodeImmutableDbChunkInfo'
    , 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
$cto :: forall proto era x.
Rep (StorageConfig (ShelleyBlock proto era)) x
-> StorageConfig (ShelleyBlock proto era)
$cfrom :: forall proto era x.
StorageConfig (ShelleyBlock proto era)
-> Rep (StorageConfig (ShelleyBlock proto era)) x
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
showTypeOf :: Proxy (StorageConfig (ShelleyBlock proto era)) -> String
$cshowTypeOf :: forall proto era.
Proxy (StorageConfig (ShelleyBlock proto era)) -> String
wNoThunks :: Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall proto era.
Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
$cnoThunks :: forall proto era.
Context
-> StorageConfig (ShelleyBlock proto era) -> IO (Maybe ThunkInfo)
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 era = CompactGenesis {
      CompactGenesis era -> ShelleyGenesis era
getCompactGenesis :: SL.ShelleyGenesis era
    }
  deriving stock (CompactGenesis era -> CompactGenesis era -> Bool
(CompactGenesis era -> CompactGenesis era -> Bool)
-> (CompactGenesis era -> CompactGenesis era -> Bool)
-> Eq (CompactGenesis era)
forall era. CompactGenesis era -> CompactGenesis era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompactGenesis era -> CompactGenesis era -> Bool
$c/= :: forall era. CompactGenesis era -> CompactGenesis era -> Bool
== :: CompactGenesis era -> CompactGenesis era -> Bool
$c== :: forall era. CompactGenesis era -> CompactGenesis era -> Bool
Eq, Int -> CompactGenesis era -> ShowS
[CompactGenesis era] -> ShowS
CompactGenesis era -> String
(Int -> CompactGenesis era -> ShowS)
-> (CompactGenesis era -> String)
-> ([CompactGenesis era] -> ShowS)
-> Show (CompactGenesis era)
forall era. Int -> CompactGenesis era -> ShowS
forall era. [CompactGenesis era] -> ShowS
forall era. CompactGenesis era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompactGenesis era] -> ShowS
$cshowList :: forall era. [CompactGenesis era] -> ShowS
show :: CompactGenesis era -> String
$cshow :: forall era. CompactGenesis era -> String
showsPrec :: Int -> CompactGenesis era -> ShowS
$cshowsPrec :: forall era. Int -> CompactGenesis era -> ShowS
Show, (forall x. CompactGenesis era -> Rep (CompactGenesis era) x)
-> (forall x. Rep (CompactGenesis era) x -> CompactGenesis era)
-> Generic (CompactGenesis era)
forall x. Rep (CompactGenesis era) x -> CompactGenesis era
forall x. CompactGenesis era -> Rep (CompactGenesis era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (CompactGenesis era) x -> CompactGenesis era
forall era x. CompactGenesis era -> Rep (CompactGenesis era) x
$cto :: forall era x. Rep (CompactGenesis era) x -> CompactGenesis era
$cfrom :: forall era x. CompactGenesis era -> Rep (CompactGenesis era) x
Generic)
  deriving newtype (Typeable (CompactGenesis era)
Decoder s (CompactGenesis era)
Typeable (CompactGenesis era)
-> (forall s. Decoder s (CompactGenesis era))
-> (Proxy (CompactGenesis era) -> Text)
-> FromCBOR (CompactGenesis era)
Proxy (CompactGenesis era) -> Text
forall s. Decoder s (CompactGenesis era)
forall a.
Typeable a
-> (forall s. Decoder s a) -> (Proxy a -> Text) -> FromCBOR a
forall era. Era era => Typeable (CompactGenesis era)
forall era. Era era => Proxy (CompactGenesis era) -> Text
forall era s. Era era => Decoder s (CompactGenesis era)
label :: Proxy (CompactGenesis era) -> Text
$clabel :: forall era. Era era => Proxy (CompactGenesis era) -> Text
fromCBOR :: Decoder s (CompactGenesis era)
$cfromCBOR :: forall era s. Era era => Decoder s (CompactGenesis era)
$cp1FromCBOR :: forall era. Era era => Typeable (CompactGenesis era)
FromCBOR, Typeable (CompactGenesis era)
Typeable (CompactGenesis era)
-> (CompactGenesis era -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy (CompactGenesis era) -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy [CompactGenesis era] -> Size)
-> ToCBOR (CompactGenesis era)
CompactGenesis era -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis era] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CompactGenesis era) -> 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 era. Era era => Typeable (CompactGenesis era)
forall era. Era era => CompactGenesis era -> Encoding
forall era.
Era era =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis era] -> Size
forall era.
Era era =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CompactGenesis era) -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis era] -> Size
$cencodedListSizeExpr :: forall era.
Era era =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [CompactGenesis era] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CompactGenesis era) -> Size
$cencodedSizeExpr :: forall era.
Era era =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (CompactGenesis era) -> Size
toCBOR :: CompactGenesis era -> Encoding
$ctoCBOR :: forall era. Era era => CompactGenesis era -> Encoding
$cp1ToCBOR :: forall era. Era era => Typeable (CompactGenesis era)
ToCBOR)

deriving anyclass instance ShelleyBasedEra era => NoThunks (CompactGenesis era)

-- | Compacts the given 'SL.ShelleyGenesis'.
compactGenesis :: SL.ShelleyGenesis era -> CompactGenesis era
compactGenesis :: ShelleyGenesis era -> CompactGenesis era
compactGenesis ShelleyGenesis era
genesis = ShelleyGenesis era -> CompactGenesis era
forall era. ShelleyGenesis era -> CompactGenesis era
CompactGenesis (ShelleyGenesis era -> CompactGenesis era)
-> ShelleyGenesis era -> CompactGenesis era
forall a b. (a -> b) -> a -> b
$
    ShelleyGenesis era
genesis {
        sgInitialFunds :: Map (Addr (Crypto era)) Coin
SL.sgInitialFunds = Map (Addr (Crypto era)) Coin
forall a. Monoid a => a
mempty
      , sgStaking :: ShelleyGenesisStaking (Crypto era)
SL.sgStaking      = ShelleyGenesisStaking (Crypto era)
forall crypto. ShelleyGenesisStaking crypto
SL.emptyGenesisStaking
      }