{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
module Cardano.Chain.Genesis.Config
( Config(..)
, ConfigurationError(..)
, configGenesisHeaderHash
, configK
, configSlotSecurityParam
, configChainQualityThreshold
, configEpochSlots
, configProtocolMagic
, configProtocolMagicId
, configGenesisKeyHashes
, configHeavyDelegation
, configStartTime
, configNonAvvmBalances
, configProtocolParameters
, configAvvmDistr
, mkConfigFromFile
)
where
import Cardano.Prelude
import Data.Time (UTCTime)
import NoThunks.Class (NoThunks (..))
import Cardano.Binary (Annotated(..), Raw)
import Cardano.Chain.Block.Header (HeaderHash, genesisHeaderHash)
import Cardano.Chain.Common (BlockCount)
import Cardano.Chain.Genesis.Data
(GenesisData(..), GenesisDataError, readGenesisData)
import Cardano.Chain.Genesis.Hash (GenesisHash(..))
import Cardano.Chain.Genesis.AvvmBalances (GenesisAvvmBalances(..))
import Cardano.Chain.Genesis.KeyHashes (GenesisKeyHashes)
import Cardano.Chain.Genesis.Delegation (GenesisDelegation)
import Cardano.Chain.Genesis.NonAvvmBalances (GenesisNonAvvmBalances)
import Cardano.Chain.ProtocolConstants
(kEpochSlots, kSlotSecurityParam, kChainQualityThreshold)
import Cardano.Chain.Slotting (EpochSlots, SlotCount)
import Cardano.Chain.Update (ProtocolParameters)
import Cardano.Chain.UTxO.UTxOConfiguration
(UTxOConfiguration, defaultUTxOConfiguration)
import Cardano.Crypto
( AProtocolMagic(..)
, Hash
, ProtocolMagic
, ProtocolMagicId(..)
, RequiresNetworkMagic
)
data Config = Config
{ Config -> GenesisData
configGenesisData :: !GenesisData
, Config -> GenesisHash
configGenesisHash :: !GenesisHash
, Config -> RequiresNetworkMagic
configReqNetMagic :: !RequiresNetworkMagic
, Config -> UTxOConfiguration
configUTxOConfiguration :: !UTxOConfiguration
}
deriving ((forall x. Config -> Rep Config x)
-> (forall x. Rep Config x -> Config) -> Generic Config
forall x. Rep Config x -> Config
forall x. Config -> Rep Config x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Config x -> Config
$cfrom :: forall x. Config -> Rep Config x
Generic, Context -> Config -> IO (Maybe ThunkInfo)
Proxy Config -> String
(Context -> Config -> IO (Maybe ThunkInfo))
-> (Context -> Config -> IO (Maybe ThunkInfo))
-> (Proxy Config -> String)
-> NoThunks Config
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Config -> String
$cshowTypeOf :: Proxy Config -> String
wNoThunks :: Context -> Config -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Config -> IO (Maybe ThunkInfo)
noThunks :: Context -> Config -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Config -> IO (Maybe ThunkInfo)
NoThunks)
configGenesisHeaderHash :: Config -> HeaderHash
= GenesisHash -> HeaderHash
genesisHeaderHash (GenesisHash -> HeaderHash)
-> (Config -> GenesisHash) -> Config -> HeaderHash
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisHash
configGenesisHash
configK :: Config -> BlockCount
configK :: Config -> BlockCount
configK = GenesisData -> BlockCount
gdK (GenesisData -> BlockCount)
-> (Config -> GenesisData) -> Config -> BlockCount
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisData
configGenesisData
configSlotSecurityParam :: Config -> SlotCount
configSlotSecurityParam :: Config -> SlotCount
configSlotSecurityParam = BlockCount -> SlotCount
kSlotSecurityParam (BlockCount -> SlotCount)
-> (Config -> BlockCount) -> Config -> SlotCount
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> BlockCount
configK
configChainQualityThreshold :: Fractional f => Config -> f
configChainQualityThreshold :: Config -> f
configChainQualityThreshold = BlockCount -> f
forall f. Fractional f => BlockCount -> f
kChainQualityThreshold (BlockCount -> f) -> (Config -> BlockCount) -> Config -> f
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> BlockCount
configK
configEpochSlots :: Config -> EpochSlots
configEpochSlots :: Config -> EpochSlots
configEpochSlots = BlockCount -> EpochSlots
kEpochSlots (BlockCount -> EpochSlots)
-> (Config -> BlockCount) -> Config -> EpochSlots
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> BlockCount
configK
configProtocolMagic :: Config -> ProtocolMagic
configProtocolMagic :: Config -> ProtocolMagic
configProtocolMagic Config
config = Annotated ProtocolMagicId ()
-> RequiresNetworkMagic -> ProtocolMagic
forall a.
Annotated ProtocolMagicId a
-> RequiresNetworkMagic -> AProtocolMagic a
AProtocolMagic (ProtocolMagicId -> () -> Annotated ProtocolMagicId ()
forall b a. b -> a -> Annotated b a
Annotated ProtocolMagicId
pmi ()) RequiresNetworkMagic
rnm
where
pmi :: ProtocolMagicId
pmi = Config -> ProtocolMagicId
configProtocolMagicId Config
config
rnm :: RequiresNetworkMagic
rnm = Config -> RequiresNetworkMagic
configReqNetMagic Config
config
configProtocolMagicId :: Config -> ProtocolMagicId
configProtocolMagicId :: Config -> ProtocolMagicId
configProtocolMagicId = GenesisData -> ProtocolMagicId
gdProtocolMagicId (GenesisData -> ProtocolMagicId)
-> (Config -> GenesisData) -> Config -> ProtocolMagicId
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisData
configGenesisData
configGenesisKeyHashes :: Config -> GenesisKeyHashes
configGenesisKeyHashes :: Config -> GenesisKeyHashes
configGenesisKeyHashes = GenesisData -> GenesisKeyHashes
gdGenesisKeyHashes (GenesisData -> GenesisKeyHashes)
-> (Config -> GenesisData) -> Config -> GenesisKeyHashes
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisData
configGenesisData
configHeavyDelegation :: Config -> GenesisDelegation
configHeavyDelegation :: Config -> GenesisDelegation
configHeavyDelegation = GenesisData -> GenesisDelegation
gdHeavyDelegation (GenesisData -> GenesisDelegation)
-> (Config -> GenesisData) -> Config -> GenesisDelegation
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisData
configGenesisData
configStartTime :: Config -> UTCTime
configStartTime :: Config -> UTCTime
configStartTime = GenesisData -> UTCTime
gdStartTime (GenesisData -> UTCTime)
-> (Config -> GenesisData) -> Config -> UTCTime
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisData
configGenesisData
configNonAvvmBalances :: Config -> GenesisNonAvvmBalances
configNonAvvmBalances :: Config -> GenesisNonAvvmBalances
configNonAvvmBalances = GenesisData -> GenesisNonAvvmBalances
gdNonAvvmBalances (GenesisData -> GenesisNonAvvmBalances)
-> (Config -> GenesisData) -> Config -> GenesisNonAvvmBalances
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisData
configGenesisData
configProtocolParameters :: Config -> ProtocolParameters
configProtocolParameters :: Config -> ProtocolParameters
configProtocolParameters = GenesisData -> ProtocolParameters
gdProtocolParameters (GenesisData -> ProtocolParameters)
-> (Config -> GenesisData) -> Config -> ProtocolParameters
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisData
configGenesisData
configAvvmDistr :: Config -> GenesisAvvmBalances
configAvvmDistr :: Config -> GenesisAvvmBalances
configAvvmDistr = GenesisData -> GenesisAvvmBalances
gdAvvmDistr (GenesisData -> GenesisAvvmBalances)
-> (Config -> GenesisData) -> Config -> GenesisAvvmBalances
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Config -> GenesisData
configGenesisData
mkConfigFromFile
:: (MonadError ConfigurationError m, MonadIO m)
=> RequiresNetworkMagic
-> FilePath
-> Hash Raw
-> m Config
mkConfigFromFile :: RequiresNetworkMagic -> String -> Hash Raw -> m Config
mkConfigFromFile RequiresNetworkMagic
rnm String
fp Hash Raw
expectedHash = do
(GenesisData
genesisData, GenesisHash
genesisHash) <-
(Either GenesisDataError (GenesisData, GenesisHash)
-> (GenesisDataError -> ConfigurationError)
-> m (GenesisData, GenesisHash)
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` GenesisDataError -> ConfigurationError
ConfigurationGenesisDataError) (Either GenesisDataError (GenesisData, GenesisHash)
-> m (GenesisData, GenesisHash))
-> m (Either GenesisDataError (GenesisData, GenesisHash))
-> m (GenesisData, GenesisHash)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT GenesisDataError m (GenesisData, GenesisHash)
-> m (Either GenesisDataError (GenesisData, GenesisHash))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
(String -> ExceptT GenesisDataError m (GenesisData, GenesisHash)
forall (m :: * -> *).
(MonadError GenesisDataError m, MonadIO m) =>
String -> m (GenesisData, GenesisHash)
readGenesisData String
fp)
(GenesisHash -> Hash Raw
unGenesisHash GenesisHash
genesisHash Hash Raw -> Hash Raw -> Bool
forall a. Eq a => a -> a -> Bool
== Hash Raw
expectedHash)
Bool -> ConfigurationError -> m ()
forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` GenesisHash -> Hash Raw -> ConfigurationError
GenesisHashMismatch GenesisHash
genesisHash Hash Raw
expectedHash
Config -> m Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> m Config) -> Config -> m Config
forall a b. (a -> b) -> a -> b
$ Config :: GenesisData
-> GenesisHash
-> RequiresNetworkMagic
-> UTxOConfiguration
-> Config
Config
{ configGenesisData :: GenesisData
configGenesisData = GenesisData
genesisData
, configGenesisHash :: GenesisHash
configGenesisHash = GenesisHash
genesisHash
, configReqNetMagic :: RequiresNetworkMagic
configReqNetMagic = RequiresNetworkMagic
rnm
, configUTxOConfiguration :: UTxOConfiguration
configUTxOConfiguration = UTxOConfiguration
defaultUTxOConfiguration
}
data ConfigurationError
= ConfigurationGenesisDataError GenesisDataError
| GenesisHashMismatch GenesisHash (Hash Raw)
| GenesisHashDecodeError Text
deriving (Int -> ConfigurationError -> ShowS
[ConfigurationError] -> ShowS
ConfigurationError -> String
(Int -> ConfigurationError -> ShowS)
-> (ConfigurationError -> String)
-> ([ConfigurationError] -> ShowS)
-> Show ConfigurationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigurationError] -> ShowS
$cshowList :: [ConfigurationError] -> ShowS
show :: ConfigurationError -> String
$cshow :: ConfigurationError -> String
showsPrec :: Int -> ConfigurationError -> ShowS
$cshowsPrec :: Int -> ConfigurationError -> ShowS
Show)