{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Chain.Genesis.Config
  ( Config (..),
    ConfigurationError (..),
    configGenesisHeaderHash,
    configK,
    configSlotSecurityParam,
    configChainQualityThreshold,
    configEpochSlots,
    configProtocolMagic,
    configProtocolMagicId,
    configGenesisKeyHashes,
    configHeavyDelegation,
    configStartTime,
    configNonAvvmBalances,
    configProtocolParameters,
    configAvvmDistr,
    mkConfigFromFile,
  )
where

import Cardano.Binary
  ( Annotated (..),
    FromCBOR (..),
    Raw,
    ToCBOR (..),
    encodeListLen,
    enforceSize,
  )
import Cardano.Chain.Block.Header (HeaderHash, genesisHeaderHash)
import Cardano.Chain.Common (BlockCount)
import Cardano.Chain.Genesis.AvvmBalances (GenesisAvvmBalances (..))
import Cardano.Chain.Genesis.Data
  ( GenesisData (..),
    GenesisDataError,
    readGenesisData,
  )
import Cardano.Chain.Genesis.Delegation (GenesisDelegation)
import Cardano.Chain.Genesis.Hash (GenesisHash (..))
import Cardano.Chain.Genesis.KeyHashes (GenesisKeyHashes)
import Cardano.Chain.Genesis.NonAvvmBalances (GenesisNonAvvmBalances)
import Cardano.Chain.ProtocolConstants
  ( kChainQualityThreshold,
    kEpochSlots,
    kSlotSecurityParam,
  )
import Cardano.Chain.Slotting (EpochSlots, SlotCount)
import Cardano.Chain.UTxO.UTxOConfiguration
  ( UTxOConfiguration,
    defaultUTxOConfiguration,
  )
import Cardano.Chain.Update (ProtocolParameters)
import Cardano.Crypto
  ( AProtocolMagic (..),
    Hash,
    ProtocolMagic,
    ProtocolMagicId (..),
    RequiresNetworkMagic,
  )
import Cardano.Prelude
import Data.Time (UTCTime)
import NoThunks.Class (NoThunks (..))

--------------------------------------------------------------------------------
-- Config
--------------------------------------------------------------------------------

data Config = Config
  { -- | The data needed at genesis
    Config -> GenesisData
configGenesisData :: !GenesisData,
    -- | The hash of the canonical JSON representation of the 'GenesisData'
    Config -> GenesisHash
configGenesisHash :: !GenesisHash,
    -- | Differentiates between Testnet and Mainet/Staging
    Config -> RequiresNetworkMagic
configReqNetMagic :: !RequiresNetworkMagic,
    -- | Extra local data used in UTxO validation rules
    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, Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show, 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
configGenesisHeaderHash :: Config -> HeaderHash
configGenesisHeaderHash = 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

-- | There isn't a full @ProtocolMagic@ in @Config@, but the requisite
-- @ProtocolMagicId@ and @RequiresNetworkMagic@ are stored separately.
-- We use them to construct and return a @ProtocolMagic@.
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

-- | Construct a 'Config' from an external genesis file.
--
-- The 'FilePath' refers to a canonical JSON file. It will be hashed and
-- checked against the expected hash, which should be known from config.
mkConfigFromFile ::
  (MonadError ConfigurationError m, MonadIO m) =>
  RequiresNetworkMagic ->
  FilePath ->
  -- | The expected hash of the file
  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 -- TODO: add further config plumbing
      }

data ConfigurationError
  = -- | An error in constructing 'GenesisData'
    ConfigurationGenesisDataError GenesisDataError
  | -- | The GenesisData canonical JSON hash is different than expected
    GenesisHashMismatch GenesisHash (Hash Raw)
  | -- | An error occured while decoding the genesis hash.
    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)

instance ToCBOR Config where
  toCBOR :: Config -> Encoding
toCBOR
    ( Config
        GenesisData
configGenesisData_
        GenesisHash
configGenesisHash_
        RequiresNetworkMagic
configReqNetMagic_
        UTxOConfiguration
configUTxOConfiguration_
      ) =
      [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
        [ Word -> Encoding
encodeListLen Word
4,
          GenesisData -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR @GenesisData GenesisData
configGenesisData_,
          GenesisHash -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR @GenesisHash GenesisHash
configGenesisHash_,
          RequiresNetworkMagic -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR @RequiresNetworkMagic RequiresNetworkMagic
configReqNetMagic_,
          UTxOConfiguration -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR @UTxOConfiguration UTxOConfiguration
configUTxOConfiguration_
        ]

instance FromCBOR Config where
  fromCBOR :: Decoder s Config
fromCBOR = do
    Text -> Int -> Decoder s ()
forall s. Text -> Int -> Decoder s ()
enforceSize Text
"Config" Int
4
    GenesisData
-> GenesisHash
-> RequiresNetworkMagic
-> UTxOConfiguration
-> Config
Config
      (GenesisData
 -> GenesisHash
 -> RequiresNetworkMagic
 -> UTxOConfiguration
 -> Config)
-> Decoder s GenesisData
-> Decoder
     s
     (GenesisHash
      -> RequiresNetworkMagic -> UTxOConfiguration -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. FromCBOR GenesisData => Decoder s GenesisData
forall a s. FromCBOR a => Decoder s a
fromCBOR @GenesisData
      Decoder
  s
  (GenesisHash
   -> RequiresNetworkMagic -> UTxOConfiguration -> Config)
-> Decoder s GenesisHash
-> Decoder s (RequiresNetworkMagic -> UTxOConfiguration -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. FromCBOR GenesisHash => Decoder s GenesisHash
forall a s. FromCBOR a => Decoder s a
fromCBOR @GenesisHash
      Decoder s (RequiresNetworkMagic -> UTxOConfiguration -> Config)
-> Decoder s RequiresNetworkMagic
-> Decoder s (UTxOConfiguration -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s.
FromCBOR RequiresNetworkMagic =>
Decoder s RequiresNetworkMagic
forall a s. FromCBOR a => Decoder s a
fromCBOR @RequiresNetworkMagic
      Decoder s (UTxOConfiguration -> Config)
-> Decoder s UTxOConfiguration -> Decoder s Config
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. FromCBOR UTxOConfiguration => Decoder s UTxOConfiguration
forall a s. FromCBOR a => Decoder s a
fromCBOR @UTxOConfiguration