{-# 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 (..)
  , mkShelleyBlockConfig
  , CodecConfig (..)
  , StorageConfig (..)
  , CompactGenesis -- opaque
  , getCompactGenesis
  , 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 Shelley.Spec.Ledger.API as SL

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

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

data instance BlockConfig (ShelleyBlock era) = ShelleyConfig {
      -- | The highest protocol version this node supports. It will be stored
      -- the headers of produced blocks.
      BlockConfig (ShelleyBlock era) -> ProtVer
shelleyProtocolVersion  :: !SL.ProtVer
    , BlockConfig (ShelleyBlock era) -> SystemStart
shelleySystemStart      :: !SystemStart
    , BlockConfig (ShelleyBlock era) -> NetworkMagic
shelleyNetworkMagic     :: !NetworkMagic
      -- | When chain selection is comparing two fragments, it will prefer the
      -- fragment with a tip signed by (one of) its own key(s) (provided that
      -- the 'BlockNo's and 'SlotNo's of the two tips are equal). For nodes that
      -- can produce blocks, this should be set to the verification key(s)
      -- corresponding to the node's signing key(s), to make sure we prefer
      -- self-issued blocks. For non block producing nodes, this can be set to
      -- the empty map.
    , BlockConfig (ShelleyBlock 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 era)
 -> Rep (BlockConfig (ShelleyBlock era)) x)
-> (forall x.
    Rep (BlockConfig (ShelleyBlock era)) x
    -> BlockConfig (ShelleyBlock era))
-> Generic (BlockConfig (ShelleyBlock era))
forall x.
Rep (BlockConfig (ShelleyBlock era)) x
-> BlockConfig (ShelleyBlock era)
forall x.
BlockConfig (ShelleyBlock era)
-> Rep (BlockConfig (ShelleyBlock era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (BlockConfig (ShelleyBlock era)) x
-> BlockConfig (ShelleyBlock era)
forall era x.
BlockConfig (ShelleyBlock era)
-> Rep (BlockConfig (ShelleyBlock era)) x
$cto :: forall era x.
Rep (BlockConfig (ShelleyBlock era)) x
-> BlockConfig (ShelleyBlock era)
$cfrom :: forall era x.
BlockConfig (ShelleyBlock era)
-> Rep (BlockConfig (ShelleyBlock era)) x
Generic)

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

mkShelleyBlockConfig ::
     ShelleyBasedEra era
  => SL.ProtVer
  -> SL.ShelleyGenesis era
  -> [SL.VKey 'SL.BlockIssuer (EraCrypto era)]
  -> BlockConfig (ShelleyBlock era)
mkShelleyBlockConfig :: ProtVer
-> ShelleyGenesis era
-> [VKey 'BlockIssuer (EraCrypto era)]
-> BlockConfig (ShelleyBlock era)
mkShelleyBlockConfig ProtVer
protVer ShelleyGenesis era
genesis [VKey 'BlockIssuer (EraCrypto era)]
blockIssuerVKeys = ShelleyConfig :: forall era.
ProtVer
-> SystemStart
-> NetworkMagic
-> Map
     (KeyHash 'BlockIssuer (EraCrypto era))
     (VKey 'BlockIssuer (EraCrypto era))
-> BlockConfig (ShelleyBlock 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 era) = ShelleyCodecConfig
  deriving ((forall x.
 CodecConfig (ShelleyBlock era)
 -> Rep (CodecConfig (ShelleyBlock era)) x)
-> (forall x.
    Rep (CodecConfig (ShelleyBlock era)) x
    -> CodecConfig (ShelleyBlock era))
-> Generic (CodecConfig (ShelleyBlock era))
forall x.
Rep (CodecConfig (ShelleyBlock era)) x
-> CodecConfig (ShelleyBlock era)
forall x.
CodecConfig (ShelleyBlock era)
-> Rep (CodecConfig (ShelleyBlock era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (CodecConfig (ShelleyBlock era)) x
-> CodecConfig (ShelleyBlock era)
forall era x.
CodecConfig (ShelleyBlock era)
-> Rep (CodecConfig (ShelleyBlock era)) x
$cto :: forall era x.
Rep (CodecConfig (ShelleyBlock era)) x
-> CodecConfig (ShelleyBlock era)
$cfrom :: forall era x.
CodecConfig (ShelleyBlock era)
-> Rep (CodecConfig (ShelleyBlock era)) x
Generic, Context -> CodecConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
Proxy (CodecConfig (ShelleyBlock era)) -> String
(Context -> CodecConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo))
-> (Context
    -> CodecConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo))
-> (Proxy (CodecConfig (ShelleyBlock era)) -> String)
-> NoThunks (CodecConfig (ShelleyBlock era))
forall era.
Context -> CodecConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
forall era. Proxy (CodecConfig (ShelleyBlock era)) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (CodecConfig (ShelleyBlock era)) -> String
$cshowTypeOf :: forall era. Proxy (CodecConfig (ShelleyBlock era)) -> String
wNoThunks :: Context -> CodecConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
Context -> CodecConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
noThunks :: Context -> CodecConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era.
Context -> CodecConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
NoThunks)

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

data instance StorageConfig (ShelleyBlock era) = ShelleyStorageConfig {
      -- | Needed for 'nodeCheckIntegrity'
      StorageConfig (ShelleyBlock era) -> Word64
shelleyStorageConfigSlotsPerKESPeriod :: !Word64
      -- | Needed for 'nodeImmutableDbChunkInfo'
    , StorageConfig (ShelleyBlock era) -> SecurityParam
shelleyStorageConfigSecurityParam     :: !SecurityParam
    }
  deriving ((forall x.
 StorageConfig (ShelleyBlock era)
 -> Rep (StorageConfig (ShelleyBlock era)) x)
-> (forall x.
    Rep (StorageConfig (ShelleyBlock era)) x
    -> StorageConfig (ShelleyBlock era))
-> Generic (StorageConfig (ShelleyBlock era))
forall x.
Rep (StorageConfig (ShelleyBlock era)) x
-> StorageConfig (ShelleyBlock era)
forall x.
StorageConfig (ShelleyBlock era)
-> Rep (StorageConfig (ShelleyBlock era)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (StorageConfig (ShelleyBlock era)) x
-> StorageConfig (ShelleyBlock era)
forall era x.
StorageConfig (ShelleyBlock era)
-> Rep (StorageConfig (ShelleyBlock era)) x
$cto :: forall era x.
Rep (StorageConfig (ShelleyBlock era)) x
-> StorageConfig (ShelleyBlock era)
$cfrom :: forall era x.
StorageConfig (ShelleyBlock era)
-> Rep (StorageConfig (ShelleyBlock era)) x
Generic, Context -> StorageConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
Proxy (StorageConfig (ShelleyBlock era)) -> String
(Context
 -> StorageConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo))
-> (Context
    -> StorageConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo))
-> (Proxy (StorageConfig (ShelleyBlock era)) -> String)
-> NoThunks (StorageConfig (ShelleyBlock era))
forall era.
Context -> StorageConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
forall era. Proxy (StorageConfig (ShelleyBlock era)) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (StorageConfig (ShelleyBlock era)) -> String
$cshowTypeOf :: forall era. Proxy (StorageConfig (ShelleyBlock era)) -> String
wNoThunks :: Context -> StorageConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
Context -> StorageConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
noThunks :: Context -> StorageConfig (ShelleyBlock era) -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era.
Context -> StorageConfig (ShelleyBlock 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 era) Coin
SL.sgInitialFunds = Map (Addr era) Coin
forall a. Monoid a => a
mempty
      , sgStaking :: ShelleyGenesisStaking era
SL.sgStaking      = ShelleyGenesisStaking era
forall era. ShelleyGenesisStaking era
SL.emptyGenesisStaking
      }