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

import qualified Crypto.Random as Crypto (MonadRandom)
import qualified Data.Map.Strict as M
import qualified Data.Set as Set
import Data.Time (UTCTime)
import Data.Coerce (coerce)
import Formatting (build, bprint, int, stext)
import qualified Formatting.Buildable as B
import NoThunks.Class (NoThunks (..))

import Cardano.Chain.Common
  ( Address
  , Lovelace
  , LovelaceError
  , addLovelace
  , divLovelace
  , makeVerKeyAddress
  , mkKnownLovelace
  , hashKey
  , 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.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.NonAvvmBalances (GenesisNonAvvmBalances(..))
import Cardano.Chain.Genesis.Spec (GenesisSpec(..))
import Cardano.Chain.Genesis.Config (Config(..))
import Cardano.Chain.UTxO.UTxOConfiguration (defaultUTxOConfiguration)
import Cardano.Chain.Genesis.KeyHashes (GenesisKeyHashes(..))
import Cardano.Crypto as Crypto
  ( SigningKey
  , runSecureRandom
  , getProtocolMagicId
  , getRequiresNetworkMagic
  , keyGen
  , noPassSafeSigner
  , toVerification
  , RedeemSigningKey
  , redeemKeyGen
  , redeemToVerification
  , toCompactRedeemVerificationKey
  , serializeCborHash
  )


-- | Poor node secret
newtype PoorSecret = PoorSecret { PoorSecret -> SigningKey
poorSecretToKey :: SigningKey }
  deriving ((forall x. PoorSecret -> Rep PoorSecret x)
-> (forall x. Rep PoorSecret x -> PoorSecret) -> Generic PoorSecret
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
(Context -> PoorSecret -> IO (Maybe ThunkInfo))
-> (Context -> PoorSecret -> IO (Maybe ThunkInfo))
-> (Proxy PoorSecret -> String)
-> NoThunks PoorSecret
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. GeneratedSecrets -> Rep GeneratedSecrets x)
-> (forall x. Rep GeneratedSecrets x -> GeneratedSecrets)
-> Generic GeneratedSecrets
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
(Context -> GeneratedSecrets -> IO (Maybe ThunkInfo))
-> (Context -> GeneratedSecrets -> IO (Maybe ThunkInfo))
-> (Proxy GeneratedSecrets -> String)
-> NoThunks GeneratedSecrets
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 [SigningKey] -> [SigningKey] -> [SigningKey]
forall a. Semigroup a => a -> a -> a
<> GeneratedSecrets -> [SigningKey]
gsSigningKeysPoor GeneratedSecrets
gs

gsSigningKeysPoor :: GeneratedSecrets -> [SigningKey]
gsSigningKeysPoor :: GeneratedSecrets -> [SigningKey]
gsSigningKeysPoor = (PoorSecret -> SigningKey) -> [PoorSecret] -> [SigningKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map PoorSecret -> SigningKey
poorSecretToKey ([PoorSecret] -> [SigningKey])
-> (GeneratedSecrets -> [PoorSecret])
-> GeneratedSecrets
-> [SigningKey]
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
(GenesisDataGenerationError -> GenesisDataGenerationError -> Bool)
-> (GenesisDataGenerationError
    -> GenesisDataGenerationError -> Bool)
-> Eq GenesisDataGenerationError
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
(Int -> GenesisDataGenerationError -> ShowS)
-> (GenesisDataGenerationError -> String)
-> ([GenesisDataGenerationError] -> ShowS)
-> Show GenesisDataGenerationError
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 ->
      Format Builder (Text -> Int -> Int -> Builder)
-> Text -> Int -> Int -> Builder
forall a. Format Builder a -> a
bprint (Format
  (Text -> Int -> Int -> Builder) (Text -> Int -> Int -> Builder)
"GenesisData address balance mismatch, Distribution: "
             Format
  (Text -> Int -> Int -> Builder) (Text -> Int -> Int -> Builder)
-> Format Builder (Text -> Int -> Int -> Builder)
-> Format Builder (Text -> Int -> Int -> Builder)
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) (Text -> Int -> Int -> Builder)
forall r. Format r (Text -> r)
stext
             Format (Int -> Int -> Builder) (Text -> Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
-> Format Builder (Text -> Int -> Int -> Builder)
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: "
             Format (Int -> Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
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 -> Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int
             Format (Int -> Builder) (Int -> Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> Int -> Builder)
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: "
             Format (Int -> Builder) (Int -> Builder)
-> Format Builder (Int -> Builder)
-> Format Builder (Int -> 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 (Int -> Builder)
forall a r. Integral a => Format r (a -> r)
int
             )
             Text
distr
             Int
addresses
             Int
balances
    GenesisDataGenerationDelegationError GenesisDelegationError
genesisDelegError ->
      Format Builder (GenesisDelegationError -> Builder)
-> GenesisDelegationError -> Builder
forall a. Format Builder a -> a
bprint (Format
  (GenesisDelegationError -> Builder)
  (GenesisDelegationError -> Builder)
"GenesisDataGenerationDelegationError: "
             Format
  (GenesisDelegationError -> Builder)
  (GenesisDelegationError -> Builder)
-> Format Builder (GenesisDelegationError -> Builder)
-> Format Builder (GenesisDelegationError -> 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 (GenesisDelegationError -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
             )
             GenesisDelegationError
genesisDelegError
    GenesisDataGenerationDistributionMismatch Lovelace
testBalance Lovelace
totalBalance ->
      Format Builder (Lovelace -> Lovelace -> Builder)
-> Lovelace -> Lovelace -> Builder
forall a. Format Builder a -> a
bprint (Format
  (Lovelace -> Lovelace -> Builder) (Lovelace -> Lovelace -> Builder)
"GenesisDataGenerationDistributionMismatch: Test balance: "
             Format
  (Lovelace -> Lovelace -> Builder) (Lovelace -> Lovelace -> Builder)
-> Format Builder (Lovelace -> Lovelace -> Builder)
-> Format Builder (Lovelace -> Lovelace -> Builder)
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 -> Lovelace -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
             Format (Lovelace -> Builder) (Lovelace -> Lovelace -> Builder)
-> Format Builder (Lovelace -> Builder)
-> Format Builder (Lovelace -> Lovelace -> Builder)
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: "
             Format (Lovelace -> Builder) (Lovelace -> Builder)
-> Format Builder (Lovelace -> Builder)
-> Format Builder (Lovelace -> 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 (Lovelace -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
             )
             Lovelace
testBalance
             Lovelace
totalBalance
    GenesisDataGenerationLovelaceError LovelaceError
lovelaceErr ->
      Format Builder (LovelaceError -> Builder)
-> LovelaceError -> Builder
forall a. Format Builder a -> a
bprint (Format (LovelaceError -> Builder) (LovelaceError -> Builder)
"GenesisDataGenerationLovelaceError: "
             Format (LovelaceError -> Builder) (LovelaceError -> Builder)
-> Format Builder (LovelaceError -> Builder)
-> Format Builder (LovelaceError -> 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 (LovelaceError -> Builder)
forall a r. Buildable a => Format r (a -> r)
build
             )
             LovelaceError
lovelaceErr
    GenesisDataGenerationError
GenesisDataGenerationPassPhraseMismatch ->
      Format Builder Builder -> Builder
forall a. Format Builder a -> a
bprint Format Builder Builder
"GenesisDataGenerationPassPhraseMismatch"
    GenesisDataGenerationError
GenesisDataGenerationRedeemKeyGen ->
      Format Builder Builder -> Builder
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.
  (SecureRandom
   (Either GenesisDataGenerationError (GenesisData, GeneratedSecrets))
 -> IO
      (Either
         GenesisDataGenerationError (GenesisData, GeneratedSecrets)))
-> ExceptT
     GenesisDataGenerationError
     SecureRandom
     (GenesisData, GeneratedSecrets)
-> ExceptT
     GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT SecureRandom
  (Either GenesisDataGenerationError (GenesisData, GeneratedSecrets))
-> IO
     (Either GenesisDataGenerationError (GenesisData, GeneratedSecrets))
forall a. SecureRandom a -> IO a
Crypto.runSecureRandom (ExceptT
   GenesisDataGenerationError
   SecureRandom
   (GenesisData, GeneratedSecrets)
 -> ExceptT
      GenesisDataGenerationError IO (GenesisData, GeneratedSecrets))
-> ExceptT
     GenesisDataGenerationError
     SecureRandom
     (GenesisData, GeneratedSecrets)
-> ExceptT
     GenesisDataGenerationError IO (GenesisData, GeneratedSecrets)
forall a b. (a -> b) -> a -> b
$
    UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError
     SecureRandom
     (GenesisData, GeneratedSecrets)
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 :: 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  = ProtocolMagic -> NetworkMagic
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 <- m GeneratedSecrets
-> ExceptT GenesisDataGenerationError m GeneratedSecrets
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m GeneratedSecrets
 -> ExceptT GenesisDataGenerationError m GeneratedSecrets)
-> m GeneratedSecrets
-> ExceptT GenesisDataGenerationError m GeneratedSecrets
forall a b. (a -> b) -> a -> b
$ GenesisInitializer -> m GeneratedSecrets
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
        (Set KeyHash -> GenesisKeyHashes)
-> ([KeyHash] -> Set KeyHash) -> [KeyHash] -> GenesisKeyHashes
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
.   [KeyHash] -> Set KeyHash
forall a. Ord a => [a] -> Set a
Set.fromList
        ([KeyHash] -> GenesisKeyHashes) -> [KeyHash] -> GenesisKeyHashes
forall a b. (a -> b) -> a -> b
$   VerificationKey -> KeyHash
hashKey
        (VerificationKey -> KeyHash)
-> (SigningKey -> VerificationKey) -> SigningKey -> KeyHash
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 -> KeyHash) -> [SigningKey] -> [KeyHash]
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
          (ProtocolMagic -> ProtocolMagicId
forall a. AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId ProtocolMagic
pm)
          (SigningKey -> VerificationKey
toVerification SigningKey
delegateSK)
          EpochNumber
0
          (SigningKey -> SafeSigner
noPassSafeSigner SigningKey
issuerSK)
        )
        ((SigningKey, SigningKey) -> Certificate)
-> [(SigningKey, SigningKey)] -> [Certificate]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SigningKey] -> [SigningKey] -> [(SigningKey, SigningKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SigningKey]
dlgIssuersSecrets [SigningKey]
richSecrets

  GenesisDelegation
genesisDlg <-
    [Certificate] -> Either GenesisDelegationError GenesisDelegation
forall (m :: * -> *).
MonadError GenesisDelegationError m =>
[Certificate] -> m GenesisDelegation
mkGenesisDelegation
        (  Map KeyHash Certificate -> [Certificate]
forall k a. Map k a -> [a]
M.elems (GenesisDelegation -> Map KeyHash Certificate
unGenesisDelegation (GenesisDelegation -> Map KeyHash Certificate)
-> GenesisDelegation -> Map KeyHash Certificate
forall a b. (a -> b) -> a -> b
$ GenesisSpec -> GenesisDelegation
gsHeavyDelegation GenesisSpec
genesisSpec)
        [Certificate] -> [Certificate] -> [Certificate]
forall a. Semigroup a => a -> a -> a
<> [Certificate]
genesisDlgList
        )
      Either GenesisDelegationError GenesisDelegation
-> (GenesisDelegationError -> GenesisDataGenerationError)
-> ExceptT GenesisDataGenerationError m GenesisDelegation
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 :: Map k Lovelace -> Map k Lovelace
applyAvvmBalanceFactor =
      (Lovelace -> Lovelace) -> Map k Lovelace -> Map k Lovelace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ((Lovelace -> Rational -> Lovelace)
-> Rational -> Lovelace -> Lovelace
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
                       (Map CompactRedeemVerificationKey Lovelace -> GenesisAvvmBalances)
-> (GenesisSpec -> Map CompactRedeemVerificationKey Lovelace)
-> GenesisSpec
-> GenesisAvvmBalances
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Map CompactRedeemVerificationKey Lovelace
-> Map CompactRedeemVerificationKey Lovelace
forall k. Map k Lovelace -> Map k Lovelace
applyAvvmBalanceFactor
                       (Map CompactRedeemVerificationKey Lovelace
 -> Map CompactRedeemVerificationKey Lovelace)
-> (GenesisSpec -> Map CompactRedeemVerificationKey Lovelace)
-> GenesisSpec
-> Map CompactRedeemVerificationKey Lovelace
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
                       (GenesisAvvmBalances -> Map CompactRedeemVerificationKey Lovelace)
-> (GenesisSpec -> GenesisAvvmBalances)
-> GenesisSpec
-> Map CompactRedeemVerificationKey Lovelace
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
                       (GenesisSpec -> GenesisAvvmBalances)
-> GenesisSpec -> GenesisAvvmBalances
forall a b. (a -> b) -> a -> b
$ GenesisSpec
genesisSpec

  -- Fake AVVM Balances
  let
    fakeAvvmVerificationKeys :: [CompactRedeemVerificationKey]
fakeAvvmVerificationKeys =
      (RedeemSigningKey -> CompactRedeemVerificationKey)
-> [RedeemSigningKey] -> [CompactRedeemVerificationKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (RedeemVerificationKey -> CompactRedeemVerificationKey
toCompactRedeemVerificationKey (RedeemVerificationKey -> CompactRedeemVerificationKey)
-> (RedeemSigningKey -> RedeemVerificationKey)
-> RedeemSigningKey
-> CompactRedeemVerificationKey
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 (Map CompactRedeemVerificationKey Lovelace -> GenesisAvvmBalances)
-> ([(CompactRedeemVerificationKey, Lovelace)]
    -> Map CompactRedeemVerificationKey Lovelace)
-> [(CompactRedeemVerificationKey, Lovelace)]
-> GenesisAvvmBalances
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [(CompactRedeemVerificationKey, Lovelace)]
-> Map CompactRedeemVerificationKey Lovelace
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(CompactRedeemVerificationKey, Lovelace)] -> GenesisAvvmBalances)
-> [(CompactRedeemVerificationKey, Lovelace)]
-> GenesisAvvmBalances
forall a b. (a -> b) -> a -> b
$ (CompactRedeemVerificationKey
 -> (CompactRedeemVerificationKey, Lovelace))
-> [CompactRedeemVerificationKey]
-> [(CompactRedeemVerificationKey, Lovelace)]
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 :: PoorSecret -> m Address
createAddressPoor (PoorSecret SigningKey
secret) =
      Address -> m Address
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Address -> m Address) -> Address -> m Address
forall a b. (a -> b) -> a -> b
$ NetworkMagic -> VerificationKey -> Address
makeVerKeyAddress NetworkMagic
nm (SigningKey -> VerificationKey
toVerification SigningKey
secret)
  let richAddresses :: [Address]
richAddresses = (SigningKey -> Address) -> [SigningKey] -> [Address]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (NetworkMagic -> VerificationKey -> Address
makeVerKeyAddress NetworkMagic
nm (VerificationKey -> Address)
-> (SigningKey -> VerificationKey) -> SigningKey -> Address
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        <- (PoorSecret -> ExceptT GenesisDataGenerationError m Address)
-> [PoorSecret] -> ExceptT GenesisDataGenerationError m [Address]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PoorSecret -> ExceptT GenesisDataGenerationError m Address
forall (m :: * -> *).
MonadError GenesisDataGenerationError m =>
PoorSecret -> m Address
createAddressPoor [PoorSecret]
poorSecrets

  ---- Balances
  Lovelace
totalFakeAvvmBalance <-
    Lovelace -> Word -> Either LovelaceError Lovelace
forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
scaleLovelace (FakeAvvmOptions -> Lovelace
faoOneBalance FakeAvvmOptions
fao) (FakeAvvmOptions -> Word
faoCount FakeAvvmOptions
fao)
      Either LovelaceError Lovelace
-> (LovelaceError -> GenesisDataGenerationError)
-> ExceptT GenesisDataGenerationError m Lovelace
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 <-
    Map CompactRedeemVerificationKey Lovelace
-> Either LovelaceError Lovelace
forall (t :: * -> *).
(Foldable t, Functor t) =>
t Lovelace -> Either LovelaceError Lovelace
sumLovelace (GenesisAvvmBalances -> Map CompactRedeemVerificationKey Lovelace
unGenesisAvvmBalances GenesisAvvmBalances
realAvvmMultiplied)
      Either LovelaceError Lovelace
-> (LovelaceError -> GenesisDataGenerationError)
-> ExceptT GenesisDataGenerationError m Lovelace
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 Lovelace
forall a. Bounded a => a
maxBound Lovelace
avvmSum Either LovelaceError Lovelace
-> (LovelaceError -> GenesisDataGenerationError)
-> ExceptT GenesisDataGenerationError m Lovelace
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` LovelaceError -> GenesisDataGenerationError
GenesisDataGenerationLovelaceError
  let tnBalance :: Lovelace
tnBalance = Lovelace -> Lovelace -> Lovelace
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 :: Text -> [a] -> [b] -> m [(a, b)]
safeZip Text
s [a]
a [b]
b = if [a] -> Int
forall a. HasLength a => a -> Int
length [a]
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [b] -> Int
forall a. HasLength a => a -> Int
length [b]
b
      then GenesisDataGenerationError -> m [(a, b)]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (GenesisDataGenerationError -> m [(a, b)])
-> GenesisDataGenerationError -> m [(a, b)]
forall a b. (a -> b) -> a -> b
$ Text -> Int -> Int -> GenesisDataGenerationError
GenesisDataAddressBalanceMismatch Text
s ([a] -> Int
forall a. HasLength a => a -> Int
length [a]
a) ([b] -> Int
forall a. HasLength a => a -> Int
length [b]
b)
      else [(a, b)] -> m [(a, b)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(a, b)] -> m [(a, b)]) -> [(a, b)] -> m [(a, b)]
forall a b. (a -> b) -> 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
      Either LovelaceError Lovelace
-> (LovelaceError -> GenesisDataGenerationError)
-> ExceptT GenesisDataGenerationError m Lovelace
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` LovelaceError -> GenesisDataGenerationError
GenesisDataGenerationLovelaceError

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

  [(Address, Lovelace)]
richDistr <- Text
-> [Address]
-> [Lovelace]
-> ExceptT GenesisDataGenerationError m [(Address, Lovelace)]
forall (m :: * -> *) a b.
MonadError GenesisDataGenerationError m =>
Text -> [a] -> [b] -> m [(a, b)]
safeZip Text
"richDistr" [Address]
richAddresses [Lovelace]
richBals
  [(Address, Lovelace)]
poorDistr <- Text
-> [Address]
-> [Lovelace]
-> ExceptT GenesisDataGenerationError m [(Address, Lovelace)]
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 (Map Address Lovelace -> GenesisNonAvvmBalances)
-> ([(Address, Lovelace)] -> Map Address Lovelace)
-> [(Address, Lovelace)]
-> GenesisNonAvvmBalances
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [(Address, Lovelace)] -> Map Address Lovelace
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Address, Lovelace)] -> GenesisNonAvvmBalances)
-> [(Address, Lovelace)] -> GenesisNonAvvmBalances
forall a b. (a -> b) -> a -> b
$ [(Address, Lovelace)]
richDistr [(Address, Lovelace)]
-> [(Address, Lovelace)] -> [(Address, Lovelace)]
forall a. [a] -> [a] -> [a]
++ [(Address, Lovelace)]
poorDistr

  let
    genesisData :: GenesisData
genesisData = GenesisData :: GenesisKeyHashes
-> GenesisDelegation
-> UTCTime
-> GenesisNonAvvmBalances
-> ProtocolParameters
-> BlockCount
-> ProtocolMagicId
-> GenesisAvvmBalances
-> 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 = ProtocolMagic -> ProtocolMagicId
forall a. AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId ProtocolMagic
pm
      , gdAvvmDistr :: GenesisAvvmBalances
gdAvvmDistr = GenesisAvvmBalances
fakeAvvmDistr GenesisAvvmBalances -> GenesisAvvmBalances -> GenesisAvvmBalances
forall a. Semigroup a => a -> a -> a
<> GenesisAvvmBalances
realAvvmMultiplied
      }

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


generateSecrets :: Crypto.MonadRandom m
                => GenesisInitializer -> m GeneratedSecrets
generateSecrets :: GenesisInitializer -> m GeneratedSecrets
generateSecrets GenesisInitializer
gi = do

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

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

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

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

  GeneratedSecrets -> m GeneratedSecrets
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GeneratedSecrets -> m GeneratedSecrets)
-> GeneratedSecrets -> m GeneratedSecrets
forall a b. (a -> b) -> a -> b
$ GeneratedSecrets :: [SigningKey]
-> [SigningKey]
-> [PoorSecret]
-> [RedeemSigningKey]
-> GeneratedSecrets
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 :: m a -> m [a]
replicateRich = Int -> m a -> m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ TestnetBalanceOptions -> Word
tboRichmen TestnetBalanceOptions
tbo)

  genPoorSecret :: Crypto.MonadRandom m => m PoorSecret
  genPoorSecret :: m PoorSecret
genPoorSecret = SigningKey -> PoorSecret
PoorSecret (SigningKey -> PoorSecret)
-> ((VerificationKey, SigningKey) -> SigningKey)
-> (VerificationKey, SigningKey)
-> PoorSecret
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (VerificationKey, SigningKey) -> SigningKey
forall a b. (a, b) -> b
snd ((VerificationKey, SigningKey) -> PoorSecret)
-> m (VerificationKey, SigningKey) -> m PoorSecret
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (VerificationKey, SigningKey)
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.
  (SecureRandom
   (Either GenesisDataGenerationError (Config, GeneratedSecrets))
 -> IO
      (Either GenesisDataGenerationError (Config, GeneratedSecrets)))
-> ExceptT
     GenesisDataGenerationError SecureRandom (Config, GeneratedSecrets)
-> ExceptT GenesisDataGenerationError IO (Config, GeneratedSecrets)
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT SecureRandom
  (Either GenesisDataGenerationError (Config, GeneratedSecrets))
-> IO
     (Either GenesisDataGenerationError (Config, GeneratedSecrets))
forall a. SecureRandom a -> IO a
Crypto.runSecureRandom (ExceptT
   GenesisDataGenerationError SecureRandom (Config, GeneratedSecrets)
 -> ExceptT
      GenesisDataGenerationError IO (Config, GeneratedSecrets))
-> ExceptT
     GenesisDataGenerationError SecureRandom (Config, GeneratedSecrets)
-> ExceptT GenesisDataGenerationError IO (Config, GeneratedSecrets)
forall a b. (a -> b) -> a -> b
$
    UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError SecureRandom (Config, GeneratedSecrets)
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 :: UTCTime
-> GenesisSpec
-> ExceptT GenesisDataGenerationError m (Config, GeneratedSecrets)
generateGenesisConfigWithEntropy UTCTime
startTime GenesisSpec
genesisSpec = do
    (GenesisData
genesisData, GeneratedSecrets
generatedSecrets) <-
      UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError m (GenesisData, GeneratedSecrets)
forall (m :: * -> *).
MonadRandom m =>
UTCTime
-> GenesisSpec
-> ExceptT
     GenesisDataGenerationError m (GenesisData, GeneratedSecrets)
generateGenesisDataWithEntropy UTCTime
startTime GenesisSpec
genesisSpec

    let config :: Config
config = Config :: GenesisData
-> GenesisHash
-> RequiresNetworkMagic
-> UTxOConfiguration
-> Config
Config
          { configGenesisData :: GenesisData
configGenesisData       = GenesisData
genesisData
          , configGenesisHash :: GenesisHash
configGenesisHash       = GenesisHash
genesisHash
          , configReqNetMagic :: RequiresNetworkMagic
configReqNetMagic       = ProtocolMagic -> RequiresNetworkMagic
forall a. AProtocolMagic a -> RequiresNetworkMagic
getRequiresNetworkMagic
                                        (GenesisSpec -> ProtocolMagic
gsProtocolMagic GenesisSpec
genesisSpec)
          , configUTxOConfiguration :: UTxOConfiguration
configUTxOConfiguration = UTxOConfiguration
defaultUTxOConfiguration
          }
    (Config, GeneratedSecrets)
-> ExceptT GenesisDataGenerationError m (Config, GeneratedSecrets)
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 (Hash Raw -> GenesisHash) -> Hash Raw -> GenesisHash
forall a b. (a -> b) -> a -> b
$ Hash Text -> Hash Raw
coerce (Hash Text -> Hash Raw) -> Hash Text -> Hash Raw
forall a b. (a -> b) -> a -> b
$ Text -> Hash Text
forall a. ToCBOR 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 :: TestnetBalanceOptions -> Lovelace -> m ([Lovelace], [Lovelace])
genTestnetDistribution TestnetBalanceOptions
tbo Lovelace
testBalance = do
  ([Lovelace]
richBalances, [Lovelace]
poorBalances, Lovelace
totalBalance) <-
    (Either LovelaceError ([Lovelace], [Lovelace], Lovelace)
-> (LovelaceError -> GenesisDataGenerationError)
-> m ([Lovelace], [Lovelace], Lovelace)
forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` LovelaceError -> GenesisDataGenerationError
GenesisDataGenerationLovelaceError) (Either LovelaceError ([Lovelace], [Lovelace], Lovelace)
 -> m ([Lovelace], [Lovelace], Lovelace))
-> Either LovelaceError ([Lovelace], [Lovelace], Lovelace)
-> m ([Lovelace], [Lovelace], Lovelace)
forall a b. (a -> b) -> a -> b
$ do
      Lovelace
richmanBalance      <- Lovelace -> Word -> Either LovelaceError Lovelace
forall b.
Integral b =>
Lovelace -> b -> Either LovelaceError Lovelace
divLovelace Lovelace
desiredRichBalance Word
tboRichmen

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

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

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

      Lovelace
totalPoorBalance <- Lovelace -> Word -> Either LovelaceError Lovelace
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

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

  if Lovelace
totalBalance Lovelace -> Lovelace -> Bool
forall a. Ord a => a -> a -> Bool
<= Lovelace
testBalance
    then ([Lovelace], [Lovelace]) -> m ([Lovelace], [Lovelace])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Lovelace]
richBalances, [Lovelace]
poorBalances)
    else GenesisDataGenerationError -> m ([Lovelace], [Lovelace])
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
      (GenesisDataGenerationError -> m ([Lovelace], [Lovelace]))
-> GenesisDataGenerationError -> m ([Lovelace], [Lovelace])
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)