{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- | Generation of genesis data for testing or development.
--
-- This includes the genesis block and all required private keys (root keys,
-- keys for the initial UTxO etc).
--
-- This can never be used for a production system since all stake holder keys
-- must be generated by each stake holder privately, whereas for testing it
-- is fine to generate all the keys in one place.
module Cardano.Chain.Genesis.Generate (
  GeneratedSecrets (..),
  gsSigningKeys,
  gsSigningKeysPoor,
  PoorSecret (..),
  generateGenesisData,
  generateGenesisDataWithEntropy,
  generateGenesisConfig,
  generateGenesisConfigWithEntropy,
  GenesisDataGenerationError (..),
)
where

import Cardano.Chain.Common (
  Address,
  Lovelace,
  LovelaceError,
  addLovelace,
  divLovelace,
  hashKey,
  makeVerKeyAddress,
  mkKnownLovelace,
  modLovelace,
  scaleLovelace,
  scaleLovelaceRational,
  subLovelace,
  sumLovelace,
 )
import Cardano.Chain.Common.NetworkMagic (makeNetworkMagic)
import qualified Cardano.Chain.Delegation.Certificate as Delegation
import Cardano.Chain.Genesis.AvvmBalances (GenesisAvvmBalances (..))
import Cardano.Chain.Genesis.Config (Config (..))
import Cardano.Chain.Genesis.Data (GenesisData (..))
import Cardano.Chain.Genesis.Delegation (
  GenesisDelegation (..),
  GenesisDelegationError,
  mkGenesisDelegation,
 )
import Cardano.Chain.Genesis.Hash (GenesisHash (..))
import Cardano.Chain.Genesis.Initializer (
  FakeAvvmOptions (..),
  GenesisInitializer (..),
  TestnetBalanceOptions (..),
 )
import Cardano.Chain.Genesis.KeyHashes (GenesisKeyHashes (..))
import Cardano.Chain.Genesis.NonAvvmBalances (GenesisNonAvvmBalances (..))
import Cardano.Chain.Genesis.Spec (GenesisSpec (..))
import Cardano.Chain.UTxO.UTxOConfiguration (defaultUTxOConfiguration)
import Cardano.Crypto as Crypto (
  RedeemSigningKey,
  SigningKey,
  getProtocolMagicId,
  getRequiresNetworkMagic,
  keyGen,
  noPassSafeSigner,
  redeemKeyGen,
  redeemToVerification,
  runSecureRandom,
  serializeCborHash,
  toCompactRedeemVerificationKey,
  toVerification,
 )
import Cardano.Prelude
import qualified Crypto.Random as Crypto (MonadRandom)
import Data.Coerce (coerce)
import qualified Data.Map.Strict as M
import qualified Data.Set as Set
import Data.Time (UTCTime)
import Formatting (bprint, build, int, stext)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))

-- | Poor node secret
newtype PoorSecret = PoorSecret {PoorSecret -> SigningKey
poorSecretToKey :: SigningKey}
  deriving (forall x. Rep PoorSecret x -> PoorSecret
forall x. PoorSecret -> Rep PoorSecret x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PoorSecret x -> PoorSecret
$cfrom :: forall x. PoorSecret -> Rep PoorSecret x
Generic, Context -> PoorSecret -> IO (Maybe ThunkInfo)
Proxy PoorSecret -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy PoorSecret -> String
$cshowTypeOf :: Proxy PoorSecret -> String
wNoThunks :: Context -> PoorSecret -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PoorSecret -> IO (Maybe ThunkInfo)
noThunks :: Context -> PoorSecret -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> PoorSecret -> IO (Maybe ThunkInfo)
NoThunks)

-- | Valuable secrets which can unlock genesis data.
data GeneratedSecrets = GeneratedSecrets
  { GeneratedSecrets -> [SigningKey]
gsDlgIssuersSecrets :: ![SigningKey]
  -- ^ Secret keys which issued heavyweight delegation certificates
  -- in genesis data. If genesis heavyweight delegation isn't used,
  -- this list is empty.
  , GeneratedSecrets -> [SigningKey]
gsRichSecrets :: ![SigningKey]
  -- ^ All secrets of rich nodes.
  , GeneratedSecrets -> [PoorSecret]
gsPoorSecrets :: ![PoorSecret]
  -- ^ Keys for HD addresses of poor nodes.
  , GeneratedSecrets -> [RedeemSigningKey]
gsFakeAvvmSecrets :: ![RedeemSigningKey]
  -- ^ Fake avvm secrets.
  }
  deriving (forall x. Rep GeneratedSecrets x -> GeneratedSecrets
forall x. GeneratedSecrets -> Rep GeneratedSecrets x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep GeneratedSecrets x -> GeneratedSecrets
$cfrom :: forall x. GeneratedSecrets -> Rep GeneratedSecrets x
Generic, Context -> GeneratedSecrets -> IO (Maybe ThunkInfo)
Proxy GeneratedSecrets -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy GeneratedSecrets -> String
$cshowTypeOf :: Proxy GeneratedSecrets -> String
wNoThunks :: Context -> GeneratedSecrets -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> GeneratedSecrets -> IO (Maybe ThunkInfo)
noThunks :: Context -> GeneratedSecrets -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> GeneratedSecrets -> IO (Maybe ThunkInfo)
NoThunks)

gsSigningKeys :: GeneratedSecrets -> [SigningKey]
gsSigningKeys :: GeneratedSecrets -> [SigningKey]
gsSigningKeys GeneratedSecrets
gs = GeneratedSecrets -> [SigningKey]
gsRichSecrets GeneratedSecrets
gs forall a. Semigroup a => a -> a -> a
<> GeneratedSecrets -> [SigningKey]
gsSigningKeysPoor GeneratedSecrets
gs

gsSigningKeysPoor :: GeneratedSecrets -> [SigningKey]
gsSigningKeysPoor :: GeneratedSecrets -> [SigningKey]
gsSigningKeysPoor = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PoorSecret -> SigningKey
poorSecretToKey forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. GeneratedSecrets -> [PoorSecret]
gsPoorSecrets

data GenesisDataGenerationError
  = GenesisDataAddressBalanceMismatch Text Int Int
  | GenesisDataGenerationDelegationError GenesisDelegationError
  | GenesisDataGenerationDistributionMismatch Lovelace Lovelace
  | GenesisDataGenerationLovelaceError LovelaceError
  | GenesisDataGenerationPassPhraseMismatch
  | GenesisDataGenerationRedeemKeyGen
  deriving (GenesisDataGenerationError -> GenesisDataGenerationError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenesisDataGenerationError -> GenesisDataGenerationError -> Bool
$c/= :: GenesisDataGenerationError -> GenesisDataGenerationError -> Bool
== :: GenesisDataGenerationError -> GenesisDataGenerationError -> Bool
$c== :: GenesisDataGenerationError -> GenesisDataGenerationError -> Bool
Eq, Int -> GenesisDataGenerationError -> ShowS
[GenesisDataGenerationError] -> ShowS
GenesisDataGenerationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenesisDataGenerationError] -> ShowS
$cshowList :: [GenesisDataGenerationError] -> ShowS
show :: GenesisDataGenerationError -> String
$cshow :: GenesisDataGenerationError -> String
showsPrec :: Int -> GenesisDataGenerationError -> ShowS
$cshowsPrec :: Int -> GenesisDataGenerationError -> ShowS
Show)

instance B.Buildable GenesisDataGenerationError where
  build :: GenesisDataGenerationError -> Builder
build = \case
    GenesisDataAddressBalanceMismatch Text
distr Int
addresses Int
balances ->
      forall a. Format Builder a -> a
bprint
        ( Format
  (Text -> Int -> Int -> Builder) (Text -> Int -> Int -> Builder)
"GenesisData address balance mismatch, Distribution: "
            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 (Int -> Int -> Builder) (Int -> Int -> Builder)
" Addresses list length: "
            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. Integral a => Format r (a -> r)
int
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Int -> Builder) (Int -> Builder)
" Balances list length: "
            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. Integral a => Format r (a -> r)
int
        )
        Text
distr
        Int
addresses
        Int
balances
    GenesisDataGenerationDelegationError GenesisDelegationError
genesisDelegError ->
      forall a. Format Builder a -> a
bprint
        ( Format
  (GenesisDelegationError -> Builder)
  (GenesisDelegationError -> Builder)
"GenesisDataGenerationDelegationError: "
            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
        )
        GenesisDelegationError
genesisDelegError
    GenesisDataGenerationDistributionMismatch Lovelace
testBalance Lovelace
totalBalance ->
      forall a. Format Builder a -> a
bprint
        ( Format
  (Lovelace -> Lovelace -> Builder) (Lovelace -> Lovelace -> Builder)
"GenesisDataGenerationDistributionMismatch: Test balance: "
            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
            forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (Lovelace -> Builder) (Lovelace -> Builder)
" Total balance: "
            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
        )
        Lovelace
testBalance
        Lovelace
totalBalance
    GenesisDataGenerationLovelaceError LovelaceError
lovelaceErr ->
      forall a. Format Builder a -> a
bprint
        ( Format (LovelaceError -> Builder) (LovelaceError -> Builder)
"GenesisDataGenerationLovelaceError: "
            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
        )
        LovelaceError
lovelaceErr
    GenesisDataGenerationError
GenesisDataGenerationPassPhraseMismatch ->
      forall a. Format Builder a -> a
bprint Format Builder Builder
"GenesisDataGenerationPassPhraseMismatch"
    GenesisDataGenerationError
GenesisDataGenerationRedeemKeyGen ->
      forall a. Format Builder a -> a
bprint Format Builder Builder
"GenesisDataGenerationRedeemKeyGen"

-- | Generate a genesis 'GenesisData' and 'GeneratedSecrets' from a
-- 'GenesisSpec'. This is used only for tests blockhains. For a real blockcain
-- you must use the external key generation tool so that each stakeholder can
-- generate their keys privately.
generateGenesisData ::
  UTCTime ->
  GenesisSpec ->
  ExceptT GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
generateGenesisData :: UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
generateGenesisData UTCTime
startTime GenesisSpec
genesisSpec =
  -- Use a sensible choice of random entropy for key generation, which then
  -- requires that the whole thing is actually in IO.
  forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT forall a. SecureRandom a -> IO a
Crypto.runSecureRandom
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadRandom m =>
UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError m (GenesisData, GeneratedSecrets)
generateGenesisDataWithEntropy UTCTime
startTime GenesisSpec
genesisSpec

-- | A version of 'generateGenesisData' parametrised over 'Crypto.MonadRandom'.
-- For testing purposes this allows using a completely pure deterministic
-- entropy source, rather than a cryptographically secure entropy source.
generateGenesisDataWithEntropy ::
  Crypto.MonadRandom m =>
  UTCTime ->
  GenesisSpec ->
  ExceptT GenesisDataGenerationError m (GenesisData, GeneratedSecrets)
generateGenesisDataWithEntropy :: forall (m :: * -> *).
MonadRandom m =>
UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError m (GenesisData, GeneratedSecrets)
generateGenesisDataWithEntropy UTCTime
startTime GenesisSpec
genesisSpec = do
  let pm :: ProtocolMagic
pm = GenesisSpec -> ProtocolMagic
gsProtocolMagic GenesisSpec
genesisSpec
      nm :: NetworkMagic
nm = forall a. AProtocolMagic a -> NetworkMagic
makeNetworkMagic ProtocolMagic
pm
      gi :: GenesisInitializer
gi = GenesisSpec -> GenesisInitializer
gsInitializer GenesisSpec
genesisSpec
      fao :: FakeAvvmOptions
fao = GenesisInitializer -> FakeAvvmOptions
giFakeAvvmBalance GenesisInitializer
gi
      tbo :: TestnetBalanceOptions
tbo = GenesisInitializer -> TestnetBalanceOptions
giTestBalance GenesisInitializer
gi

  -- Generate all the private keys
  GeneratedSecrets
generatedSecrets <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadRandom m =>
GenesisInitializer -> m GeneratedSecrets
generateSecrets GenesisInitializer
gi
  let dlgIssuersSecrets :: [SigningKey]
dlgIssuersSecrets = GeneratedSecrets -> [SigningKey]
gsDlgIssuersSecrets GeneratedSecrets
generatedSecrets
      richSecrets :: [SigningKey]
richSecrets = GeneratedSecrets -> [SigningKey]
gsRichSecrets GeneratedSecrets
generatedSecrets
      poorSecrets :: [PoorSecret]
poorSecrets = GeneratedSecrets -> [PoorSecret]
gsPoorSecrets GeneratedSecrets
generatedSecrets

  -- Genesis Keys
  let genesisSecrets :: [SigningKey]
genesisSecrets =
        if GenesisInitializer -> Bool
giUseHeavyDlg GenesisInitializer
gi then [SigningKey]
dlgIssuersSecrets else [SigningKey]
richSecrets

      genesisKeyHashes :: GenesisKeyHashes
      genesisKeyHashes :: GenesisKeyHashes
genesisKeyHashes =
        Set KeyHash -> GenesisKeyHashes
GenesisKeyHashes
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Ord a => [a] -> Set a
Set.fromList
          forall a b. (a -> b) -> a -> b
$ VerificationKey -> KeyHash
hashKey
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SigningKey -> VerificationKey
toVerification
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SigningKey]
genesisSecrets

  -- Heavyweight delegation.
  -- genesisDlgList is empty if giUseHeavyDlg = False
  let genesisDlgList :: [Delegation.Certificate]
      genesisDlgList :: [Certificate]
genesisDlgList =
        ( \(SigningKey
issuerSK, SigningKey
delegateSK) ->
            ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
Delegation.signCertificate
              (forall a. AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId ProtocolMagic
pm)
              (SigningKey -> VerificationKey
toVerification SigningKey
delegateSK)
              EpochNumber
0
              (SigningKey -> SafeSigner
noPassSafeSigner SigningKey
issuerSK)
        )
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. [a] -> [b] -> [(a, b)]
zip [SigningKey]
dlgIssuersSecrets [SigningKey]
richSecrets

  GenesisDelegation
genesisDlg <-
    forall (m :: * -> *).
MonadError GenesisDelegationError m =>
[Certificate] -> m GenesisDelegation
mkGenesisDelegation
      ( forall k a. Map k a -> [a]
M.elems (GenesisDelegation -> Map KeyHash Certificate
unGenesisDelegation forall a b. (a -> b) -> a -> b
$ GenesisSpec -> GenesisDelegation
gsHeavyDelegation GenesisSpec
genesisSpec)
          forall a. Semigroup a => a -> a -> a
<> [Certificate]
genesisDlgList
      )
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` GenesisDelegationError -> GenesisDataGenerationError
GenesisDataGenerationDelegationError

  -- Real AVVM Balances
  let applyAvvmBalanceFactor :: Map k Lovelace -> Map k Lovelace
      applyAvvmBalanceFactor :: forall k. Map k Lovelace -> Map k Lovelace
applyAvvmBalanceFactor =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip Lovelace -> Rational -> Lovelace
scaleLovelaceRational (GenesisInitializer -> Rational
giAvvmBalanceFactor GenesisInitializer
gi))

      realAvvmMultiplied :: GenesisAvvmBalances
      realAvvmMultiplied :: GenesisAvvmBalances
realAvvmMultiplied =
        Map CompactRedeemVerificationKey Lovelace -> GenesisAvvmBalances
GenesisAvvmBalances
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k. Map k Lovelace -> Map k Lovelace
applyAvvmBalanceFactor
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. GenesisAvvmBalances -> Map CompactRedeemVerificationKey Lovelace
unGenesisAvvmBalances
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. GenesisSpec -> GenesisAvvmBalances
gsAvvmDistr
          forall a b. (a -> b) -> a -> b
$ GenesisSpec
genesisSpec

  -- Fake AVVM Balances
  let fakeAvvmVerificationKeys :: [CompactRedeemVerificationKey]
fakeAvvmVerificationKeys =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map
          (RedeemVerificationKey -> CompactRedeemVerificationKey
toCompactRedeemVerificationKey forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. RedeemSigningKey -> RedeemVerificationKey
redeemToVerification)
          (GeneratedSecrets -> [RedeemSigningKey]
gsFakeAvvmSecrets GeneratedSecrets
generatedSecrets)
      fakeAvvmDistr :: GenesisAvvmBalances
fakeAvvmDistr =
        Map CompactRedeemVerificationKey Lovelace -> GenesisAvvmBalances
GenesisAvvmBalances
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
          forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map
            (,FakeAvvmOptions -> Lovelace
faoOneBalance FakeAvvmOptions
fao)
            [CompactRedeemVerificationKey]
fakeAvvmVerificationKeys

  -- Non AVVM balances
  ---- Addresses
  let createAddressPoor ::
        MonadError GenesisDataGenerationError m => PoorSecret -> m Address
      createAddressPoor :: forall (m :: * -> *).
MonadError GenesisDataGenerationError m =>
PoorSecret -> m Address
createAddressPoor (PoorSecret SigningKey
secret) =
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NetworkMagic -> VerificationKey -> Address
makeVerKeyAddress NetworkMagic
nm (SigningKey -> VerificationKey
toVerification SigningKey
secret)
  let richAddresses :: [Address]
richAddresses = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (NetworkMagic -> VerificationKey -> Address
makeVerKeyAddress NetworkMagic
nm forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. SigningKey -> VerificationKey
toVerification) [SigningKey]
richSecrets

  [Address]
poorAddresses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *).
MonadError GenesisDataGenerationError m =>
PoorSecret -> m Address
createAddressPoor [PoorSecret]
poorSecrets

  ---- Balances
  Lovelace
totalFakeAvvmBalance <-
    forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
scaleLovelace (FakeAvvmOptions -> Lovelace
faoOneBalance FakeAvvmOptions
fao) (FakeAvvmOptions -> Word
faoCount FakeAvvmOptions
fao)
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` LovelaceError -> GenesisDataGenerationError
GenesisDataGenerationLovelaceError

  -- Compute total balance to generate
  Lovelace
avvmSum <-
    forall (t :: * -> *).
(Foldable t, Functor t) =>
t Lovelace -> Either LovelaceError Lovelace
sumLovelace (GenesisAvvmBalances -> Map CompactRedeemVerificationKey Lovelace
unGenesisAvvmBalances GenesisAvvmBalances
realAvvmMultiplied)
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` LovelaceError -> GenesisDataGenerationError
GenesisDataGenerationLovelaceError
  Lovelace
maxTnBalance <-
    Lovelace -> Lovelace -> Either LovelaceError Lovelace
subLovelace forall a. Bounded a => a
maxBound Lovelace
avvmSum forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` LovelaceError -> GenesisDataGenerationError
GenesisDataGenerationLovelaceError
  let tnBalance :: Lovelace
tnBalance = forall a. Ord a => a -> a -> a
min Lovelace
maxTnBalance (TestnetBalanceOptions -> Lovelace
tboTotalBalance TestnetBalanceOptions
tbo)

  let safeZip ::
        MonadError GenesisDataGenerationError m =>
        Text ->
        [a] ->
        [b] ->
        m [(a, b)]
      safeZip :: forall (m :: * -> *) a b.
MonadError GenesisDataGenerationError m =>
Text -> [a] -> [b] -> m [(a, b)]
safeZip Text
s [a]
a [b]
b =
        if forall a. HasLength a => a -> Int
length [a]
a forall a. Eq a => a -> a -> Bool
/= forall a. HasLength a => a -> Int
length [b]
b
          then
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
              forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> GenesisDataGenerationError
GenesisDataAddressBalanceMismatch Text
s (forall a. HasLength a => a -> Int
length [a]
a) (forall a. HasLength a => a -> Int
length [b]
b)
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [a]
a [b]
b

  Lovelace
nonAvvmBalance <-
    Lovelace -> Lovelace -> Either LovelaceError Lovelace
subLovelace Lovelace
tnBalance Lovelace
totalFakeAvvmBalance
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` LovelaceError -> GenesisDataGenerationError
GenesisDataGenerationLovelaceError

  ([Lovelace]
richBals, [Lovelace]
poorBals) <- forall (m :: * -> *).
MonadError GenesisDataGenerationError m =>
TestnetBalanceOptions -> Lovelace -> m ([Lovelace], [Lovelace])
genTestnetDistribution TestnetBalanceOptions
tbo Lovelace
nonAvvmBalance

  [(Address, Lovelace)]
richDistr <- forall (m :: * -> *) a b.
MonadError GenesisDataGenerationError m =>
Text -> [a] -> [b] -> m [(a, b)]
safeZip Text
"richDistr" [Address]
richAddresses [Lovelace]
richBals
  [(Address, Lovelace)]
poorDistr <- forall (m :: * -> *) a b.
MonadError GenesisDataGenerationError m =>
Text -> [a] -> [b] -> m [(a, b)]
safeZip Text
"poorDistr" [Address]
poorAddresses [Lovelace]
poorBals

  let nonAvvmDistr :: GenesisNonAvvmBalances
nonAvvmDistr = Map Address Lovelace -> GenesisNonAvvmBalances
GenesisNonAvvmBalances forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ [(Address, Lovelace)]
richDistr forall a. [a] -> [a] -> [a]
++ [(Address, Lovelace)]
poorDistr

  let genesisData :: GenesisData
genesisData =
        GenesisData
          { gdGenesisKeyHashes :: GenesisKeyHashes
gdGenesisKeyHashes = GenesisKeyHashes
genesisKeyHashes
          , gdHeavyDelegation :: GenesisDelegation
gdHeavyDelegation = GenesisDelegation
genesisDlg
          , gdStartTime :: UTCTime
gdStartTime = UTCTime
startTime
          , gdNonAvvmBalances :: GenesisNonAvvmBalances
gdNonAvvmBalances = GenesisNonAvvmBalances
nonAvvmDistr
          , gdProtocolParameters :: ProtocolParameters
gdProtocolParameters = GenesisSpec -> ProtocolParameters
gsProtocolParameters GenesisSpec
genesisSpec
          , gdK :: BlockCount
gdK = GenesisSpec -> BlockCount
gsK GenesisSpec
genesisSpec
          , gdProtocolMagicId :: ProtocolMagicId
gdProtocolMagicId = forall a. AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId ProtocolMagic
pm
          , gdAvvmDistr :: GenesisAvvmBalances
gdAvvmDistr = GenesisAvvmBalances
fakeAvvmDistr forall a. Semigroup a => a -> a -> a
<> GenesisAvvmBalances
realAvvmMultiplied
          }

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

generateSecrets ::
  Crypto.MonadRandom m =>
  GenesisInitializer ->
  m GeneratedSecrets
generateSecrets :: forall (m :: * -> *).
MonadRandom m =>
GenesisInitializer -> m GeneratedSecrets
generateSecrets GenesisInitializer
gi = do
  -- Generate fake AVVM secrets
  [RedeemSigningKey]
fakeAvvmSecrets <-
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM
      (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ FakeAvvmOptions -> Word
faoCount FakeAvvmOptions
fao)
      (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
m (RedeemVerificationKey, RedeemSigningKey)
redeemKeyGen)

  -- Generate secret keys
  [SigningKey]
dlgIssuersSecrets <-
    if GenesisInitializer -> Bool
giUseHeavyDlg GenesisInitializer
gi
      then forall (m :: * -> *) a. Applicative m => m a -> m [a]
replicateRich (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
m (VerificationKey, SigningKey)
keyGen)
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  [SigningKey]
richSecrets <- forall (m :: * -> *) a. Applicative m => m a -> m [a]
replicateRich (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
m (VerificationKey, SigningKey)
keyGen)

  [PoorSecret]
poorSecrets <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TestnetBalanceOptions -> Word
tboPoors TestnetBalanceOptions
tbo) forall (m :: * -> *). MonadRandom m => m PoorSecret
genPoorSecret

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ GeneratedSecrets
      { gsDlgIssuersSecrets :: [SigningKey]
gsDlgIssuersSecrets = [SigningKey]
dlgIssuersSecrets
      , gsRichSecrets :: [SigningKey]
gsRichSecrets = [SigningKey]
richSecrets
      , gsPoorSecrets :: [PoorSecret]
gsPoorSecrets = [PoorSecret]
poorSecrets
      , gsFakeAvvmSecrets :: [RedeemSigningKey]
gsFakeAvvmSecrets = [RedeemSigningKey]
fakeAvvmSecrets
      }
  where
    fao :: FakeAvvmOptions
fao = GenesisInitializer -> FakeAvvmOptions
giFakeAvvmBalance GenesisInitializer
gi
    tbo :: TestnetBalanceOptions
tbo = GenesisInitializer -> TestnetBalanceOptions
giTestBalance GenesisInitializer
gi

    replicateRich :: Applicative m => m a -> m [a]
    replicateRich :: forall (m :: * -> *) a. Applicative m => m a -> m [a]
replicateRich = forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ TestnetBalanceOptions -> Word
tboRichmen TestnetBalanceOptions
tbo)

    genPoorSecret :: Crypto.MonadRandom m => m PoorSecret
    genPoorSecret :: forall (m :: * -> *). MonadRandom m => m PoorSecret
genPoorSecret = SigningKey -> PoorSecret
PoorSecret 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. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
m (VerificationKey, SigningKey)
keyGen

----------------------------------------------------------------------------
-- Generating a Genesis Config
----------------------------------------------------------------------------

-- | Generate a genesis 'Config' from a 'GenesisSpec'. This is used only for
-- tests. For the real node we always generate an external JSON genesis file.
generateGenesisConfig ::
  UTCTime ->
  GenesisSpec ->
  ExceptT GenesisDataGenerationError IO (Config, GeneratedSecrets)
generateGenesisConfig :: UTCTime
-> GenesisSpec
-> ExceptT GenesisDataGenerationError IO (Config, GeneratedSecrets)
generateGenesisConfig UTCTime
startTime GenesisSpec
genesisSpec =
  -- Use a sensible choice of random entropy for key generation, which then
  -- requires that the whole thing is actually in IO.
  forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT forall a. SecureRandom a -> IO a
Crypto.runSecureRandom
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadRandom m =>
UTCTime
-> GenesisSpec
-> ExceptT GenesisDataGenerationError m (Config, GeneratedSecrets)
generateGenesisConfigWithEntropy UTCTime
startTime GenesisSpec
genesisSpec

-- | A version of 'generateGenesisConfig' parametrised over 'Crypto.MonadRandom'.
-- For testing purposes this allows using a completely pure deterministic
-- entropy source, rather than a cryptographically secure entropy source.
generateGenesisConfigWithEntropy ::
  Crypto.MonadRandom m =>
  UTCTime ->
  GenesisSpec ->
  ExceptT GenesisDataGenerationError m (Config, GeneratedSecrets)
generateGenesisConfigWithEntropy :: forall (m :: * -> *).
MonadRandom m =>
UTCTime
-> GenesisSpec
-> ExceptT GenesisDataGenerationError m (Config, GeneratedSecrets)
generateGenesisConfigWithEntropy UTCTime
startTime GenesisSpec
genesisSpec = do
  (GenesisData
genesisData, GeneratedSecrets
generatedSecrets) <-
    forall (m :: * -> *).
MonadRandom m =>
UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError m (GenesisData, GeneratedSecrets)
generateGenesisDataWithEntropy UTCTime
startTime GenesisSpec
genesisSpec

  let config :: Config
config =
        Config
          { configGenesisData :: GenesisData
configGenesisData = GenesisData
genesisData
          , configGenesisHash :: GenesisHash
configGenesisHash = GenesisHash
genesisHash
          , configReqNetMagic :: RequiresNetworkMagic
configReqNetMagic =
              forall a. AProtocolMagic a -> RequiresNetworkMagic
getRequiresNetworkMagic
                (GenesisSpec -> ProtocolMagic
gsProtocolMagic GenesisSpec
genesisSpec)
          , configUTxOConfiguration :: UTxOConfiguration
configUTxOConfiguration = UTxOConfiguration
defaultUTxOConfiguration
          }
  forall (m :: * -> *) a. Monad m => a -> m a
return (Config
config, GeneratedSecrets
generatedSecrets)
  where
    -- Anything will do for the genesis hash. A hash of "patak" was used before,
    -- and so it remains. Here lies the last of the Serokell code. RIP.
    genesisHash :: GenesisHash
genesisHash = Hash Raw -> GenesisHash
GenesisHash forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall a. EncCBOR a => a -> Hash a
serializeCborHash (Text
"patak" :: Text)

----------------------------------------------------------------------------
-- Internal helpers
----------------------------------------------------------------------------

-- | Generates balance distribution for testnet
genTestnetDistribution ::
  MonadError GenesisDataGenerationError m =>
  TestnetBalanceOptions ->
  Lovelace ->
  m ([Lovelace], [Lovelace])
genTestnetDistribution :: forall (m :: * -> *).
MonadError GenesisDataGenerationError m =>
TestnetBalanceOptions -> Lovelace -> m ([Lovelace], [Lovelace])
genTestnetDistribution TestnetBalanceOptions
tbo Lovelace
testBalance = do
  ([Lovelace]
richBalances, [Lovelace]
poorBalances, Lovelace
totalBalance) <-
    (forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` LovelaceError -> GenesisDataGenerationError
GenesisDataGenerationLovelaceError) forall a b. (a -> b) -> a -> b
$ do
      Lovelace
richmanBalance <- forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
divLovelace Lovelace
desiredRichBalance Word
tboRichmen

      Lovelace
richmanBalanceExtra <- forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
modLovelace Lovelace
desiredRichBalance Word
tboRichmen

      Lovelace
richmanBalance' <-
        if Word
tboRichmen forall a. Eq a => a -> a -> Bool
== Word
0
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). (KnownNat n, n <= 45000000000000000) => Lovelace
mkKnownLovelace @0
          else
            Lovelace -> Lovelace -> Either LovelaceError Lovelace
addLovelace
              Lovelace
richmanBalance
              ( if Lovelace
richmanBalanceExtra forall a. Ord a => a -> a -> Bool
> forall (n :: Nat). (KnownNat n, n <= 45000000000000000) => Lovelace
mkKnownLovelace @0
                  then forall (n :: Nat). (KnownNat n, n <= 45000000000000000) => Lovelace
mkKnownLovelace @1
                  else forall (n :: Nat). (KnownNat n, n <= 45000000000000000) => Lovelace
mkKnownLovelace @0
              )

      Lovelace
totalRichBalance <- forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
scaleLovelace Lovelace
richmanBalance' Word
tboRichmen

      Lovelace
desiredPoorsBalance <- Lovelace -> Lovelace -> Either LovelaceError Lovelace
subLovelace Lovelace
testBalance Lovelace
totalRichBalance

      Lovelace
poorBalance <-
        if Word
tboPoors forall a. Eq a => a -> a -> Bool
== Word
0
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (n :: Nat). (KnownNat n, n <= 45000000000000000) => Lovelace
mkKnownLovelace @0
          else forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
divLovelace Lovelace
desiredPoorsBalance Word
tboPoors

      Lovelace
totalPoorBalance <- forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
scaleLovelace Lovelace
poorBalance Word
tboPoors

      Lovelace
totalBalance <- Lovelace -> Lovelace -> Either LovelaceError Lovelace
addLovelace Lovelace
totalRichBalance Lovelace
totalPoorBalance

      forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( forall a. Int -> a -> [a]
replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tboRichmen) Lovelace
richmanBalance'
        , forall a. Int -> a -> [a]
replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tboPoors) Lovelace
poorBalance
        , Lovelace
totalBalance
        )

  if Lovelace
totalBalance forall a. Ord a => a -> a -> Bool
<= Lovelace
testBalance
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Lovelace]
richBalances, [Lovelace]
poorBalances)
    else
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        forall a b. (a -> b) -> a -> b
$ Lovelace -> Lovelace -> GenesisDataGenerationError
GenesisDataGenerationDistributionMismatch Lovelace
testBalance Lovelace
totalBalance
  where
    TestnetBalanceOptions {Word
tboPoors :: Word
tboPoors :: TestnetBalanceOptions -> Word
tboPoors, Word
tboRichmen :: Word
tboRichmen :: TestnetBalanceOptions -> Word
tboRichmen} = TestnetBalanceOptions
tbo

    desiredRichBalance :: Lovelace
desiredRichBalance = Lovelace -> Rational -> Lovelace
scaleLovelaceRational Lovelace
testBalance (TestnetBalanceOptions -> Rational
tboRichmenShare TestnetBalanceOptions
tbo)