{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Chain.Genesis.Data (
  GenesisData (..),
  GenesisDataError (..),
  mainnetProtocolMagicId,
  readGenesisData,
)
where

import Cardano.Chain.Common (BlockCount (..))
import Cardano.Chain.Genesis.AvvmBalances (GenesisAvvmBalances)
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.Update.ProtocolParameters (ProtocolParameters)
import Cardano.Crypto (
  ProtocolMagicId (..),
  hashRaw,
 )
import Cardano.Ledger.Binary
import Cardano.Prelude
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.List (lookup)
import Data.Time (UTCTime)
import Formatting (bprint, build, stext)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))
import Text.JSON.Canonical (
  FromJSON (..),
  Int54,
  JSValue (..),
  ToJSON (..),
  expected,
  fromJSField,
  fromJSObject,
  mkObject,
  parseCanonicalJSON,
  renderCanonicalJSON,
 )

-- | Genesis data contains all data which determines consensus rules. It must be
--   same for all nodes. It's used to initialize global state, slotting, etc.
data GenesisData = GenesisData
  { GenesisData -> GenesisKeyHashes
gdGenesisKeyHashes :: !GenesisKeyHashes
  , GenesisData -> GenesisDelegation
gdHeavyDelegation :: !GenesisDelegation
  , GenesisData -> UTCTime
gdStartTime :: !UTCTime
  , GenesisData -> GenesisNonAvvmBalances
gdNonAvvmBalances :: !GenesisNonAvvmBalances
  , GenesisData -> ProtocolParameters
gdProtocolParameters :: !ProtocolParameters
  , GenesisData -> BlockCount
gdK :: !BlockCount
  , GenesisData -> ProtocolMagicId
gdProtocolMagicId :: !ProtocolMagicId
  , GenesisData -> GenesisAvvmBalances
gdAvvmDistr :: !GenesisAvvmBalances
  }
  deriving (Int -> GenesisData -> ShowS
[GenesisData] -> ShowS
GenesisData -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisData] -> ShowS
$cshowList :: [GenesisData] -> ShowS
show :: GenesisData -> String
$cshow :: GenesisData -> String
showsPrec :: Int -> GenesisData -> ShowS
$cshowsPrec :: Int -> GenesisData -> ShowS
Show, GenesisData -> GenesisData -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisData -> GenesisData -> Bool
$c/= :: GenesisData -> GenesisData -> Bool
== :: GenesisData -> GenesisData -> Bool
$c== :: GenesisData -> GenesisData -> Bool
Eq, forall x. Rep GenesisData x -> GenesisData
forall x. GenesisData -> Rep GenesisData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GenesisData x -> GenesisData
$cfrom :: forall x. GenesisData -> Rep GenesisData x
Generic, Context -> GenesisData -> IO (Maybe ThunkInfo)
Proxy GenesisData -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy GenesisData -> String
$cshowTypeOf :: Proxy GenesisData -> String
wNoThunks :: Context -> GenesisData -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> GenesisData -> IO (Maybe ThunkInfo)
noThunks :: Context -> GenesisData -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> GenesisData -> IO (Maybe ThunkInfo)
NoThunks)

instance Monad m => ToJSON m GenesisData where
  toJSON :: GenesisData -> m JSValue
toJSON GenesisData
gd =
    forall (m :: * -> *).
Monad m =>
[(JSString, m JSValue)] -> m JSValue
mkObject
      [ (JSString
"bootStakeholders", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisKeyHashes
gdGenesisKeyHashes GenesisData
gd)
      , (JSString
"heavyDelegation", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisDelegation
gdHeavyDelegation GenesisData
gd)
      , (JSString
"startTime", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ GenesisData -> UTCTime
gdStartTime GenesisData
gd)
      , (JSString
"nonAvvmBalances", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisNonAvvmBalances
gdNonAvvmBalances GenesisData
gd)
      , (JSString
"blockVersionData", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ GenesisData -> ProtocolParameters
gdProtocolParameters GenesisData
gd)
      , --  The above is called blockVersionData for backwards compatibility with
        --  mainnet genesis block

        ( JSString
"protocolConsts"
        , forall (m :: * -> *).
Monad m =>
[(JSString, m JSValue)] -> m JSValue
mkObject
            [ (JSString
"k", forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Int54 -> JSValue
JSNum forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BlockCount -> Word64
unBlockCount forall a b. (a -> b) -> a -> b
$ GenesisData -> BlockCount
gdK GenesisData
gd)
            , (JSString
"protocolMagic", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ GenesisData -> ProtocolMagicId
gdProtocolMagicId GenesisData
gd)
            ]
        )
      , (JSString
"avvmDistr", forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisAvvmBalances
gdAvvmDistr GenesisData
gd)
      ]

instance MonadError SchemaError m => FromJSON m GenesisData where
  fromJSON :: JSValue -> m GenesisData
fromJSON JSValue
obj = do
    [(JSString, JSValue)]
objAssoc <- forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(JSString, JSValue)]
fromJSObject JSValue
obj
    JSValue
protocolConsts <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup JSString
"protocolConsts" [(JSString, JSValue)]
objAssoc of
      Just JSValue
fld -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JSValue
fld
      Maybe JSValue
Nothing -> forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"field protocolConsts" forall a. Maybe a
Nothing

    GenesisKeyHashes
-> GenesisDelegation
-> UTCTime
-> GenesisNonAvvmBalances
-> ProtocolParameters
-> BlockCount
-> ProtocolMagicId
-> GenesisAvvmBalances
-> GenesisData
GenesisData
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"bootStakeholders"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"heavyDelegation"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. NFData a => a -> a
force forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"startTime")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"nonAvvmBalances"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"blockVersionData"
      -- The above is called blockVersionData for backwards compatibility with
      -- mainnet genesis block
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word64 -> BlockCount
BlockCount forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int54 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
protocolConsts JSString
"k")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word32 -> ProtocolMagicId
ProtocolMagicId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
protocolConsts JSString
"protocolMagic")
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"avvmDistr"

data GenesisDataError
  = GenesisDataParseError Text
  | GenesisDataSchemaError SchemaError
  | GenesisDataIOError IOException
  deriving (Int -> GenesisDataError -> ShowS
[GenesisDataError] -> ShowS
GenesisDataError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisDataError] -> ShowS
$cshowList :: [GenesisDataError] -> ShowS
show :: GenesisDataError -> String
$cshow :: GenesisDataError -> String
showsPrec :: Int -> GenesisDataError -> ShowS
$cshowsPrec :: Int -> GenesisDataError -> ShowS
Show)

instance B.Buildable GenesisDataError where
  build :: GenesisDataError -> Builder
build = \case
    GenesisDataParseError Text
err ->
      forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Failed to parse GenesisData.\n Error: " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext) Text
err
    GenesisDataSchemaError SchemaError
err ->
      forall a. Format Builder a -> a
bprint (Format (SchemaError -> Builder) (SchemaError -> Builder)
"Incorrect schema for GenesisData.\n Error: " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a r. Buildable a => Format r (a -> r)
build) SchemaError
err
    GenesisDataIOError IOException
err ->
      forall a. Format Builder a -> a
bprint
        (Format (Text -> Builder) (Text -> Builder)
"Failed with " forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall r. Format r (Text -> r)
stext forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder Builder
" when tried to read GenesisData file")
        (forall a b. (Show a, ConvertText String b) => a -> b
show IOException
err)

instance ToCBOR GenesisData where
  toCBOR :: GenesisData -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

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

instance EncCBOR GenesisData where
  encCBOR :: GenesisData -> Encoding
encCBOR
    ( GenesisData
        GenesisKeyHashes
gdGenesisKeyHashes_
        GenesisDelegation
gdHeavyDelegation_
        UTCTime
gdStartTime_
        GenesisNonAvvmBalances
gdNonAvvmBalances_
        ProtocolParameters
gdProtocolParameters_
        BlockCount
gdK_
        ProtocolMagicId
gdProtocolMagicId_
        GenesisAvvmBalances
gdAvvmDistr_
      ) =
      forall a. Monoid a => [a] -> a
mconcat
        [ Word -> Encoding
encodeListLen Word
8
        , forall a. EncCBOR a => a -> Encoding
encCBOR @GenesisKeyHashes GenesisKeyHashes
gdGenesisKeyHashes_
        , forall a. EncCBOR a => a -> Encoding
encCBOR @GenesisDelegation GenesisDelegation
gdHeavyDelegation_
        , forall a. EncCBOR a => a -> Encoding
encCBOR {- @UTCTime -} UTCTime
gdStartTime_
        , forall a. EncCBOR a => a -> Encoding
encCBOR @GenesisNonAvvmBalances GenesisNonAvvmBalances
gdNonAvvmBalances_
        , forall a. EncCBOR a => a -> Encoding
encCBOR @ProtocolParameters ProtocolParameters
gdProtocolParameters_
        , forall a. EncCBOR a => a -> Encoding
encCBOR @BlockCount BlockCount
gdK_
        , forall a. EncCBOR a => a -> Encoding
encCBOR @ProtocolMagicId ProtocolMagicId
gdProtocolMagicId_
        , forall a. EncCBOR a => a -> Encoding
encCBOR @GenesisAvvmBalances GenesisAvvmBalances
gdAvvmDistr_
        ]

instance DecCBOR GenesisData where
  decCBOR :: forall s. Decoder s GenesisData
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"GenesisData" Int
8
    GenesisKeyHashes
-> GenesisDelegation
-> UTCTime
-> GenesisNonAvvmBalances
-> ProtocolParameters
-> BlockCount
-> ProtocolMagicId
-> GenesisAvvmBalances
-> GenesisData
GenesisData
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR @GenesisKeyHashes
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR @GenesisDelegation
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR -- @UTCTime
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR @GenesisNonAvvmBalances
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR @ProtocolParameters
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR @BlockCount
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR @ProtocolMagicId
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR @GenesisAvvmBalances

-- | Parse @GenesisData@ from a JSON file and annotate with Canonical JSON hash
readGenesisData ::
  (MonadError GenesisDataError m, MonadIO m) =>
  FilePath ->
  m (GenesisData, GenesisHash)
readGenesisData :: forall (m :: * -> *).
(MonadError GenesisDataError m, MonadIO m) =>
String -> m (GenesisData, GenesisHash)
readGenesisData String
fp = do
  ByteString
bytes <-
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
fp)
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` IOException -> GenesisDataError
GenesisDataIOError)

  JSValue
genesisDataJSON <-
    ByteString -> Either String JSValue
parseCanonicalJSON ByteString
bytes forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Text -> GenesisDataError
GenesisDataParseError forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. ConvertText a b => a -> b
toS

  GenesisData
genesisData <- forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
genesisDataJSON forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` SchemaError -> GenesisDataError
GenesisDataSchemaError

  let genesisHash :: GenesisHash
genesisHash = Hash Raw -> GenesisHash
GenesisHash forall a b. (a -> b) -> a -> b
$ ByteString -> Hash Raw
hashRaw (JSValue -> ByteString
renderCanonicalJSON JSValue
genesisDataJSON)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenesisData
genesisData, GenesisHash
genesisHash)

mainnetProtocolMagicId :: ProtocolMagicId
mainnetProtocolMagicId :: ProtocolMagicId
mainnetProtocolMagicId = Word32 -> ProtocolMagicId
ProtocolMagicId Word32
764824073