{-# 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.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.Crypto.Raw (Raw)
import Cardano.Ledger.Binary (
  Annotated (..),
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  toByronCBOR,
 )
import Cardano.Prelude
import Data.Time (UTCTime)
import NoThunks.Class (NoThunks (..))

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

data Config = Config
  { Config -> GenesisData
configGenesisData :: !GenesisData
  -- ^ The data needed at genesis
  , Config -> GenesisHash
configGenesisHash :: !GenesisHash
  -- ^ The hash of the canonical JSON representation of the 'GenesisData'
  , Config -> RequiresNetworkMagic
configReqNetMagic :: !RequiresNetworkMagic
  -- ^ Differentiates between Testnet and Mainet/Staging
  , Config -> UTxOConfiguration
configUTxOConfiguration :: !UTxOConfiguration
  -- ^ Extra local data used in UTxO validation rules
  }
  deriving (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
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
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
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 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 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 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 :: forall f. Fractional f => Config -> f
configChainQualityThreshold = forall f. Fractional f => BlockCount -> f
kChainQualityThreshold 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 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 = forall a.
Annotated ProtocolMagicId a
-> RequiresNetworkMagic -> AProtocolMagic a
AProtocolMagic (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 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 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 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 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 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 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 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 :: forall (m :: * -> *).
(MonadError ConfigurationError m, MonadIO m) =>
RequiresNetworkMagic -> String -> Hash Raw -> m Config
mkConfigFromFile RequiresNetworkMagic
rnm String
fp Hash Raw
expectedHash = do
  (GenesisData
genesisData, GenesisHash
genesisHash) <-
    (forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` GenesisDataError -> ConfigurationError
ConfigurationGenesisDataError)
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (forall (m :: * -> *).
(MonadError GenesisDataError m, MonadIO m) =>
String -> m (GenesisData, GenesisHash)
readGenesisData String
fp)

  (GenesisHash -> Hash Raw
unGenesisHash GenesisHash
genesisHash forall a. Eq a => a -> a -> Bool
== Hash Raw
expectedHash)
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` GenesisHash -> Hash Raw -> ConfigurationError
GenesisHashMismatch GenesisHash
genesisHash Hash Raw
expectedHash

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ 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
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 = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR Config where
  fromCBOR :: forall s. Decoder s Config
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

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

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