content: {-# 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 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 { poorSecretToKey :: SigningKey }
    deriving (Generic, NoUnexpectedThunks)
  
  -- | Valuable secrets which can unlock genesis data.
  data GeneratedSecrets = GeneratedSecrets
      { gsDlgIssuersSecrets :: ![SigningKey]
      -- ^ Secret keys which issued heavyweight delegation certificates
      -- in genesis data. If genesis heavyweight delegation isn't used,
      -- this list is empty.
      , gsRichSecrets       :: ![SigningKey]
      -- ^ All secrets of rich nodes.
      , gsPoorSecrets       :: ![PoorSecret]
      -- ^ Keys for HD addresses of poor nodes.
      , gsFakeAvvmSecrets   :: ![RedeemSigningKey]
      -- ^ Fake avvm secrets.
      }
    deriving (Generic, NoUnexpectedThunks)
  
  gsSigningKeys :: GeneratedSecrets -> [SigningKey]
  gsSigningKeys gs = gsRichSecrets gs <> gsSigningKeysPoor gs
  
  gsSigningKeysPoor :: GeneratedSecrets -> [SigningKey]
  gsSigningKeysPoor = map poorSecretToKey . gsPoorSecrets
  
  data GenesisDataGenerationError
    = GenesisDataAddressBalanceMismatch Text Int Int
    | GenesisDataGenerationDelegationError GenesisDelegationError
    | GenesisDataGenerationDistributionMismatch Lovelace Lovelace
    | GenesisDataGenerationLovelaceError LovelaceError
    | GenesisDataGenerationPassPhraseMismatch
    | GenesisDataGenerationRedeemKeyGen
    deriving (Eq, Show)
  
  instance B.Buildable GenesisDataGenerationError where
    build = \case
      GenesisDataAddressBalanceMismatch distr addresses balances ->
        bprint ("GenesisData address balance mismatch, Distribution: "
               . stext
               . " Addresses list length: "
               . int
               . " Balances list length: "
               . int
               )
               distr
               addresses
               balances
      GenesisDataGenerationDelegationError genesisDelegError ->
        bprint ("GenesisDataGenerationDelegationError: "
               . build
               )
               genesisDelegError
      GenesisDataGenerationDistributionMismatch testBalance totalBalance ->
        bprint ("GenesisDataGenerationDistributionMismatch: Test balance: "
               . build
               . " Total balance: "
               . build
               )
               testBalance
               totalBalance
      GenesisDataGenerationLovelaceError lovelaceErr ->
        bprint ("GenesisDataGenerationLovelaceError: "
               . build
               )
               lovelaceErr
      GenesisDataGenerationPassPhraseMismatch ->
        bprint "GenesisDataGenerationPassPhraseMismatch"
      GenesisDataGenerationRedeemKeyGen ->
        bprint "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 startTime genesisSpec =
    -- Use a sensible choice of random entropy for key generation, which then
    -- requires that the whole thing is actually in IO.
    mapExceptT Crypto.runSecureRandom $
      generateGenesisDataWithEntropy startTime 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 startTime genesisSpec = do
  
    let
      pm  = gsProtocolMagic genesisSpec
      nm  = makeNetworkMagic pm
      gi  = gsInitializer genesisSpec
      fao = giFakeAvvmBalance gi
      tbo = giTestBalance gi
  
    -- Generate all the private keys
    generatedSecrets <- lift $ generateSecrets gi
    let
      dlgIssuersSecrets = gsDlgIssuersSecrets generatedSecrets
      richSecrets = gsRichSecrets generatedSecrets
      poorSecrets = gsPoorSecrets generatedSecrets
  
    -- Genesis Keys
    let
      genesisSecrets =
        if giUseHeavyDlg gi then dlgIssuersSecrets else richSecrets
  
      genesisKeyHashes :: GenesisKeyHashes
      genesisKeyHashes =
        GenesisKeyHashes
          .   Set.fromList
          $   hashKey
          .   toVerification
          <$> genesisSecrets
  
    -- Heavyweight delegation.
    -- genesisDlgList is empty if giUseHeavyDlg = False
    let
      genesisDlgList :: [Delegation.Certificate]
      genesisDlgList =
        (\(issuerSK, delegateSK) -> Delegation.signCertificate
            (getProtocolMagicId pm)
            (toVerification delegateSK)
            0
            (noPassSafeSigner issuerSK)
          )
          <$> zip dlgIssuersSecrets richSecrets
  
    genesisDlg <-
      mkGenesisDelegation
          (  M.elems (unGenesisDelegation $ gsHeavyDelegation genesisSpec)
          <> genesisDlgList
          )
        `wrapError` GenesisDataGenerationDelegationError
  
    -- Real AVVM Balances
    let
      applyAvvmBalanceFactor :: Map k Lovelace -> Map k Lovelace
      applyAvvmBalanceFactor =
        map (flip scaleLovelaceRational (giAvvmBalanceFactor gi))
  
      realAvvmMultiplied :: GenesisAvvmBalances
      realAvvmMultiplied = GenesisAvvmBalances
                         . applyAvvmBalanceFactor
                         . unGenesisAvvmBalances
                         . gsAvvmDistr
                         $ genesisSpec
  
    -- Fake AVVM Balances
    let
      fakeAvvmVerificationKeys =
        map (toCompactRedeemVerificationKey . redeemToVerification)
            (gsFakeAvvmSecrets generatedSecrets)
      fakeAvvmDistr = GenesisAvvmBalances . M.fromList $ map
        (, faoOneBalance fao)
        fakeAvvmVerificationKeys
  
    -- Non AVVM balances
    ---- Addresses
    let
      createAddressPoor
        :: MonadError GenesisDataGenerationError m => PoorSecret -> m Address
      createAddressPoor (PoorSecret secret) =
        pure $ makeVerKeyAddress nm (toVerification secret)
    let richAddresses = map (makeVerKeyAddress nm . toVerification) richSecrets
  
    poorAddresses        <- mapM createAddressPoor poorSecrets
  
    ---- Balances
    totalFakeAvvmBalance <-
      scaleLovelace (faoOneBalance fao) (faoCount fao)
        `wrapError` GenesisDataGenerationLovelaceError
  
    -- Compute total balance to generate
    avvmSum <-
      sumLovelace (unGenesisAvvmBalances realAvvmMultiplied)
        `wrapError` GenesisDataGenerationLovelaceError
    maxTnBalance <-
      subLovelace maxBound avvmSum `wrapError` GenesisDataGenerationLovelaceError
    let tnBalance = min maxTnBalance (tboTotalBalance tbo)
  
    let
      safeZip
        :: MonadError GenesisDataGenerationError m
        => Text
        -> [a]
        -> [b]
        -> m [(a, b)]
      safeZip s a b = if length a /= length b
        then throwError
          $ GenesisDataAddressBalanceMismatch s (length a) (length b)
        else pure $ zip a b
  
    nonAvvmBalance <-
      subLovelace tnBalance totalFakeAvvmBalance
        `wrapError` GenesisDataGenerationLovelaceError
  
    (richBals, poorBals) <- genTestnetDistribution tbo nonAvvmBalance
  
    richDistr <- safeZip "richDistr" richAddresses richBals
    poorDistr <- safeZip "poorDistr" poorAddresses poorBals
  
    let
      nonAvvmDistr = GenesisNonAvvmBalances . M.fromList $ richDistr ++ poorDistr
  
    let
      genesisData = GenesisData
        { gdGenesisKeyHashes = genesisKeyHashes
        , gdHeavyDelegation = genesisDlg
        , gdStartTime = startTime
        , gdNonAvvmBalances = nonAvvmDistr
        , gdProtocolParameters = gsProtocolParameters genesisSpec
        , gdK         = gsK genesisSpec
        , gdProtocolMagicId = getProtocolMagicId pm
        , gdAvvmDistr = fakeAvvmDistr <> realAvvmMultiplied
        }
  
    pure (genesisData, generatedSecrets)
  
  
  generateSecrets :: Crypto.MonadRandom m
                  => GenesisInitializer -> m GeneratedSecrets
  generateSecrets gi = do
  
    -- Generate fake AVVM secrets
    fakeAvvmSecrets <- replicateM (fromIntegral $ faoCount fao)
                                  (snd <$> redeemKeyGen)
  
    -- Generate secret keys
    dlgIssuersSecrets <- if giUseHeavyDlg gi
      then replicateRich (snd <$> keyGen)
      else pure []
  
    richSecrets <- replicateRich (snd <$> keyGen)
  
    poorSecrets <- replicateM (fromIntegral $ tboPoors tbo) genPoorSecret
  
    pure $ GeneratedSecrets
      { gsDlgIssuersSecrets = dlgIssuersSecrets
      , gsRichSecrets       = richSecrets
      , gsPoorSecrets       = poorSecrets
      , gsFakeAvvmSecrets   = fakeAvvmSecrets
      }
   where
    fao = giFakeAvvmBalance gi
    tbo = giTestBalance gi
  
    replicateRich :: Applicative m => m a -> m [a]
    replicateRich = replicateM (fromIntegral $ tboRichmen tbo)
  
    genPoorSecret :: Crypto.MonadRandom m => m PoorSecret
    genPoorSecret = PoorSecret . snd <$> 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 startTime genesisSpec =
    -- Use a sensible choice of random entropy for key generation, which then
    -- requires that the whole thing is actually in IO.
    mapExceptT Crypto.runSecureRandom $
      generateGenesisConfigWithEntropy startTime 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 startTime genesisSpec = do
      (genesisData, generatedSecrets) <-
        generateGenesisDataWithEntropy startTime genesisSpec
  
      let config = Config
            { configGenesisData       = genesisData
            , configGenesisHash       = genesisHash
            , configReqNetMagic       = getRequiresNetworkMagic
                                          (gsProtocolMagic genesisSpec)
            , configUTxOConfiguration = defaultUTxOConfiguration
            }
      return (config, 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 $ coerce $ serializeCborHash ("patak" :: Text)
  
  
  ----------------------------------------------------------------------------
  -- Internal helpers
  ----------------------------------------------------------------------------
  
  -- | Generates balance distribution for testnet
  genTestnetDistribution
    :: MonadError GenesisDataGenerationError m
    => TestnetBalanceOptions
    -> Lovelace
    -> m ([Lovelace], [Lovelace])
  genTestnetDistribution tbo testBalance = do
    (richBalances, poorBalances, totalBalance) <-
      (`wrapError` GenesisDataGenerationLovelaceError) $ do
        richmanBalance      <- divLovelace desiredRichBalance tboRichmen
  
        richmanBalanceExtra <- modLovelace desiredRichBalance tboRichmen
  
        richmanBalance'     <- if tboRichmen == 0
          then pure $ mkKnownLovelace @0
          else addLovelace
            richmanBalance
            (if richmanBalanceExtra > mkKnownLovelace @0
              then mkKnownLovelace @1
              else mkKnownLovelace @0
            )
  
        totalRichBalance    <- scaleLovelace richmanBalance' tboRichmen
  
        desiredPoorsBalance <- subLovelace testBalance totalRichBalance
  
        poorBalance         <- if tboPoors == 0
          then pure $ mkKnownLovelace @0
          else divLovelace desiredPoorsBalance tboPoors
  
        totalPoorBalance <- scaleLovelace poorBalance tboPoors
  
        totalBalance     <- addLovelace totalRichBalance totalPoorBalance
  
        pure
          ( replicate (fromIntegral tboRichmen) richmanBalance'
          , replicate (fromIntegral tboPoors)   poorBalance
          , totalBalance
          )
  
    if totalBalance <= testBalance
      then pure (richBalances, poorBalances)
      else throwError
        $ GenesisDataGenerationDistributionMismatch testBalance totalBalance
   where
    TestnetBalanceOptions { tboPoors, tboRichmen } = tbo
  
    desiredRichBalance = scaleLovelaceRational testBalance (tboRichmenShare tbo)
  