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

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.NonAvvmBalances (GenesisNonAvvmBalances)
import Cardano.Chain.Genesis.KeyHashes (GenesisKeyHashes)
import Cardano.Chain.Update.ProtocolParameters (ProtocolParameters)
import Cardano.Crypto
  ( ProtocolMagicId(..)
  , hashRaw
  )


-- | 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
(Int -> GenesisData -> ShowS)
-> (GenesisData -> String)
-> ([GenesisData] -> ShowS)
-> Show GenesisData
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
(GenesisData -> GenesisData -> Bool)
-> (GenesisData -> GenesisData -> Bool) -> Eq GenesisData
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. GenesisData -> Rep GenesisData x)
-> (forall x. Rep GenesisData x -> GenesisData)
-> Generic GenesisData
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
(Context -> GenesisData -> IO (Maybe ThunkInfo))
-> (Context -> GenesisData -> IO (Maybe ThunkInfo))
-> (Proxy GenesisData -> String)
-> NoThunks GenesisData
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 = [(JSString, m JSValue)] -> m JSValue
forall (m :: * -> *).
Monad m =>
[(JSString, m JSValue)] -> m JSValue
mkObject
    [ (JSString
"bootStakeholders", GenesisKeyHashes -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (GenesisKeyHashes -> m JSValue) -> GenesisKeyHashes -> m JSValue
forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisKeyHashes
gdGenesisKeyHashes GenesisData
gd)
    , (JSString
"heavyDelegation" , GenesisDelegation -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (GenesisDelegation -> m JSValue) -> GenesisDelegation -> m JSValue
forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisDelegation
gdHeavyDelegation GenesisData
gd)
    , (JSString
"startTime"       , UTCTime -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (UTCTime -> m JSValue) -> UTCTime -> m JSValue
forall a b. (a -> b) -> a -> b
$ GenesisData -> UTCTime
gdStartTime GenesisData
gd)
    , (JSString
"nonAvvmBalances" , GenesisNonAvvmBalances -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (GenesisNonAvvmBalances -> m JSValue)
-> GenesisNonAvvmBalances -> m JSValue
forall a b. (a -> b) -> a -> b
$ GenesisData -> GenesisNonAvvmBalances
gdNonAvvmBalances GenesisData
gd)
    , (JSString
"blockVersionData", ProtocolParameters -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (ProtocolParameters -> m JSValue)
-> ProtocolParameters -> m JSValue
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"
      , [(JSString, m JSValue)] -> m JSValue
forall (m :: * -> *).
Monad m =>
[(JSString, m JSValue)] -> m JSValue
mkObject
        [ (JSString
"k"            , JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSValue -> m JSValue)
-> (BlockCount -> JSValue) -> BlockCount -> m JSValue
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 (Int54 -> JSValue)
-> (BlockCount -> Int54) -> BlockCount -> JSValue
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> Int54
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int54) -> (BlockCount -> Word64) -> BlockCount -> Int54
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 (BlockCount -> m JSValue) -> BlockCount -> m JSValue
forall a b. (a -> b) -> a -> b
$ GenesisData -> BlockCount
gdK GenesisData
gd)
        , (JSString
"protocolMagic", ProtocolMagicId -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (ProtocolMagicId -> m JSValue) -> ProtocolMagicId -> m JSValue
forall a b. (a -> b) -> a -> b
$ GenesisData -> ProtocolMagicId
gdProtocolMagicId GenesisData
gd)
        ]
      )
    , (JSString
"avvmDistr", GenesisAvvmBalances -> m JSValue
forall (m :: * -> *) a. ToJSON m a => a -> m JSValue
toJSON (GenesisAvvmBalances -> m JSValue)
-> GenesisAvvmBalances -> m JSValue
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       <- JSValue -> m [(JSString, JSValue)]
forall (m :: * -> *).
ReportSchemaErrors m =>
JSValue -> m [(JSString, JSValue)]
fromJSObject JSValue
obj
    JSValue
protocolConsts <- case JSString -> [(JSString, JSValue)] -> Maybe JSValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup JSString
"protocolConsts" [(JSString, JSValue)]
objAssoc of
      Just JSValue
fld -> JSValue -> m JSValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSValue
fld
      Maybe JSValue
Nothing  -> String -> Maybe String -> m JSValue
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
"field protocolConsts" Maybe String
forall a. Maybe a
Nothing

    GenesisKeyHashes
-> GenesisDelegation
-> UTCTime
-> GenesisNonAvvmBalances
-> ProtocolParameters
-> BlockCount
-> ProtocolMagicId
-> GenesisAvvmBalances
-> GenesisData
GenesisData
      (GenesisKeyHashes
 -> GenesisDelegation
 -> UTCTime
 -> GenesisNonAvvmBalances
 -> ProtocolParameters
 -> BlockCount
 -> ProtocolMagicId
 -> GenesisAvvmBalances
 -> GenesisData)
-> m GenesisKeyHashes
-> m (GenesisDelegation
      -> UTCTime
      -> GenesisNonAvvmBalances
      -> ProtocolParameters
      -> BlockCount
      -> ProtocolMagicId
      -> GenesisAvvmBalances
      -> GenesisData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> JSString -> m GenesisKeyHashes
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"bootStakeholders"
      m (GenesisDelegation
   -> UTCTime
   -> GenesisNonAvvmBalances
   -> ProtocolParameters
   -> BlockCount
   -> ProtocolMagicId
   -> GenesisAvvmBalances
   -> GenesisData)
-> m GenesisDelegation
-> m (UTCTime
      -> GenesisNonAvvmBalances
      -> ProtocolParameters
      -> BlockCount
      -> ProtocolMagicId
      -> GenesisAvvmBalances
      -> GenesisData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue -> JSString -> m GenesisDelegation
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"heavyDelegation"
      m (UTCTime
   -> GenesisNonAvvmBalances
   -> ProtocolParameters
   -> BlockCount
   -> ProtocolMagicId
   -> GenesisAvvmBalances
   -> GenesisData)
-> m UTCTime
-> m (GenesisNonAvvmBalances
      -> ProtocolParameters
      -> BlockCount
      -> ProtocolMagicId
      -> GenesisAvvmBalances
      -> GenesisData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue -> JSString -> m UTCTime
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"startTime"
      m (GenesisNonAvvmBalances
   -> ProtocolParameters
   -> BlockCount
   -> ProtocolMagicId
   -> GenesisAvvmBalances
   -> GenesisData)
-> m GenesisNonAvvmBalances
-> m (ProtocolParameters
      -> BlockCount
      -> ProtocolMagicId
      -> GenesisAvvmBalances
      -> GenesisData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue -> JSString -> m GenesisNonAvvmBalances
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
obj JSString
"nonAvvmBalances"
      m (ProtocolParameters
   -> BlockCount
   -> ProtocolMagicId
   -> GenesisAvvmBalances
   -> GenesisData)
-> m ProtocolParameters
-> m (BlockCount
      -> ProtocolMagicId -> GenesisAvvmBalances -> GenesisData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue -> JSString -> m ProtocolParameters
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
      m (BlockCount
   -> ProtocolMagicId -> GenesisAvvmBalances -> GenesisData)
-> m BlockCount
-> m (ProtocolMagicId -> GenesisAvvmBalances -> GenesisData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word64 -> BlockCount
BlockCount (Word64 -> BlockCount) -> (Int54 -> Word64) -> Int54 -> BlockCount
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall b. (Integral Int54, Num b) => Int54 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int54 (Int54 -> BlockCount) -> m Int54 -> m BlockCount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> JSString -> m Int54
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
protocolConsts JSString
"k")
      m (ProtocolMagicId -> GenesisAvvmBalances -> GenesisData)
-> m ProtocolMagicId -> m (GenesisAvvmBalances -> GenesisData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word32 -> ProtocolMagicId
ProtocolMagicId (Word32 -> ProtocolMagicId) -> m Word32 -> m ProtocolMagicId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSValue -> JSString -> m Word32
forall (m :: * -> *) a.
(ReportSchemaErrors m, FromJSON m a) =>
JSValue -> JSString -> m a
fromJSField JSValue
protocolConsts JSString
"protocolMagic")
      m (GenesisAvvmBalances -> GenesisData)
-> m GenesisAvvmBalances -> m GenesisData
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSValue -> JSString -> m GenesisAvvmBalances
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
(Int -> GenesisDataError -> ShowS)
-> (GenesisDataError -> String)
-> ([GenesisDataError] -> ShowS)
-> Show GenesisDataError
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 ->
      Format Builder (Text -> Builder) -> Text -> Builder
forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Failed to parse GenesisData.\n Error: " Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stext) Text
err
    GenesisDataSchemaError SchemaError
err ->
      Format Builder (SchemaError -> Builder) -> SchemaError -> Builder
forall a. Format Builder a -> a
bprint (Format (SchemaError -> Builder) (SchemaError -> Builder)
"Incorrect schema for GenesisData.\n Error: " Format (SchemaError -> Builder) (SchemaError -> Builder)
-> Format Builder (SchemaError -> Builder)
-> Format Builder (SchemaError -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (SchemaError -> Builder)
forall a r. Buildable a => Format r (a -> r)
build) SchemaError
err
    GenesisDataIOError IOException
err ->
      Format Builder (Text -> Builder) -> Text -> Builder
forall a. Format Builder a -> a
bprint (Format (Text -> Builder) (Text -> Builder)
"Failed with " Format (Text -> Builder) (Text -> Builder)
-> Format Builder (Text -> Builder)
-> Format Builder (Text -> Builder)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format Builder (Text -> Builder)
forall r. Format r (Text -> r)
stext Format Builder (Text -> Builder)
-> Format Builder Builder -> Format Builder (Text -> Builder)
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")
        (IOException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show IOException
err)

-- | Parse @GenesisData@ from a JSON file and annotate with Canonical JSON hash
readGenesisData
  :: (MonadError GenesisDataError m, MonadIO m)
  => FilePath
  -> m (GenesisData, GenesisHash)
readGenesisData :: String -> m (GenesisData, GenesisHash)
readGenesisData String
fp = do
  ByteString
bytes           <- IO (Either IOException ByteString)
-> m (Either IOException ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
fp)
    m (Either IOException ByteString)
-> (Either IOException ByteString -> m ByteString) -> m ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Either IOException ByteString
-> (IOException -> GenesisDataError) -> m ByteString
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 Either String JSValue -> (String -> GenesisDataError) -> m JSValue
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Text -> GenesisDataError
GenesisDataParseError (Text -> GenesisDataError)
-> (String -> Text) -> String -> GenesisDataError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertText a b => a -> b
toS

  GenesisData
genesisData <- JSValue -> Either SchemaError GenesisData
forall (m :: * -> *) a. FromJSON m a => JSValue -> m a
fromJSON JSValue
genesisDataJSON Either SchemaError GenesisData
-> (SchemaError -> GenesisDataError) -> m GenesisData
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 (Hash Raw -> GenesisHash) -> Hash Raw -> GenesisHash
forall a b. (a -> b) -> a -> b
$ ByteString -> Hash Raw
hashRaw (JSValue -> ByteString
renderCanonicalJSON JSValue
genesisDataJSON)

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

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