{-# 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. 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
  { -- | Secret keys which issued heavyweight delegation certificates
    -- in genesis data. If genesis heavyweight delegation isn't used,
    -- this list is empty.
    GeneratedSecrets -> [SigningKey]
gsDlgIssuersSecrets :: ![SigningKey],
    -- | All secrets of rich nodes.
    GeneratedSecrets -> [SigningKey]
gsRichSecrets :: ![SigningKey],
    -- | Keys for HD addresses of poor nodes.
    GeneratedSecrets -> [PoorSecret]
gsPoorSecrets :: ![PoorSecret],
    -- | Fake avvm secrets.
    GeneratedSecrets -> [RedeemSigningKey]
gsFakeAvvmSecrets :: ![RedeemSigningKey]
  }
  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)