{-# 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
  )


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