Skip to content

Commit

Permalink
Merge pull request #599 from IntersectMBO/mgalazyn/fix/make-create-te…
Browse files Browse the repository at this point in the history 
…stnet-data-produce-only-nonegative-supply

Fix create-testnet-data creating negative supply
  • Loading branch information
@carbolymer
carbolymer authored Feb 13, 2024
2 parents 9715586 + 1dfee0b commit 0e393cb
Show file tree
Hide file tree
Showing 3 changed files with 134 additions and 45 deletions.
90 changes: 51 additions & 39 deletions cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -82,6 +82,7 @@ import qualified Data.Text as Text
import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)
import Data.Word (Word64)
import GHC.Generics (Generic)
import GHC.Num (Natural)
import Lens.Micro ((^.))
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
Expand Down Expand Up @@ -204,10 +205,10 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs
Nothing ->
-- No template given: a default file is created
pure shelleyGenesisDefaults
-- Read NetworkId either from file or from the flag. Flag overrides template file.

-- Read NetworkId either from file or from the flag. Flag overrides template file.
let actualNetworkId =
case networkId of
case networkId of
Just networkFromFlag -> networkFromFlag
Nothing -> fromNetworkMagic (NetworkMagic $ sgNetworkMagic shelleyGenesisInit)
shelleyGenesis = shelleyGenesisInit { sgNetworkMagic = unNetworkMagic (toNetworkMagic actualNetworkId) }
Expand Down Expand Up @@ -303,10 +304,10 @@ runGenesisCreateTestNetDataCmd Cmd.GenesisCreateTestNetDataCmdArgs
let stake = second Ledger.ppId . mkDelegationMapEntry <$> delegations
stakePools = [ (Ledger.ppId poolParams', poolParams') | poolParams' <- snd . mkDelegationMapEntry <$> delegations ]
delegAddrs = dInitialUtxoAddr <$> delegations
!shelleyGenesis' =
updateOutputTemplate
start genDlgs totalSupply nonDelegAddrs stakePools stake
delegatedSupply (length delegations) delegAddrs stuffedUtxoAddrs shelleyGenesis
!shelleyGenesis' <-
updateOutputTemplate
start genDlgs totalSupply nonDelegAddrs stakePools stake delegatedSupply (length delegations)
delegAddrs stuffedUtxoAddrs shelleyGenesis

-- Write genesis.json file to output
liftIO $ LBS.writeFile (outputDir </> "genesis.json") $ Aeson.encode shelleyGenesis'
Expand Down Expand Up @@ -572,37 +573,38 @@ computeInsecureDelegation g0 nw pool = do


updateOutputTemplate
:: SystemStart -- ^ System start time
-> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) -- ^ Genesis delegation (not stake-based)
-> Maybe Lovelace -- ^ Total amount of lovelace
-> [AddressInEra ShelleyEra] -- ^ UTxO addresses that are not delegating
-> [(Ledger.KeyHash 'Ledger.StakePool StandardCrypto, Ledger.PoolParams StandardCrypto)] -- ^ Pool map
-> [(Ledger.KeyHash 'Ledger.Staking StandardCrypto, Ledger.KeyHash 'Ledger.StakePool StandardCrypto)] -- ^ Delegaton map
-> Maybe Lovelace -- ^ Amount of lovelace to delegate
-> Int -- ^ Number of UTxO address for delegation
-> [AddressInEra ShelleyEra] -- ^ UTxO address for delegation
-> [AddressInEra ShelleyEra] -- ^ Stuffed UTxO addresses
-> ShelleyGenesis StandardCrypto -- ^ Template from which to build a genesis
-> ShelleyGenesis StandardCrypto -- ^ Updated genesis
:: forall m. MonadError GenesisCmdError m
=> SystemStart -- ^ System start time
-> Map (Hash GenesisKey) (Hash GenesisDelegateKey, Hash VrfKey) -- ^ Genesis delegation (not stake-based)
-> Maybe Lovelace -- ^ Total amount of lovelace
-> [AddressInEra ShelleyEra] -- ^ UTxO addresses that are not delegating
-> [(Ledger.KeyHash 'Ledger.StakePool StandardCrypto, Ledger.PoolParams StandardCrypto)] -- ^ Pool map
-> [(Ledger.KeyHash 'Ledger.Staking StandardCrypto, Ledger.KeyHash 'Ledger.StakePool StandardCrypto)] -- ^ Delegaton map
-> Maybe Lovelace -- ^ Amount of lovelace to delegate
-> Int -- ^ Number of UTxO address for delegation
-> [AddressInEra ShelleyEra] -- ^ UTxO address for delegation
-> [AddressInEra ShelleyEra] -- ^ Stuffed UTxO addresses
-> ShelleyGenesis StandardCrypto -- ^ Template from which to build a genesis
-> m (ShelleyGenesis StandardCrypto) -- ^ Updated genesis
updateOutputTemplate
(SystemStart sgSystemStart)
genDelegMap mTotalSupply utxoAddrsNonDeleg pools stake
mDelegatedSupply
nUtxoAddrsDeleg utxoAddrsDeleg stuffedUtxoAddrs
template@ShelleyGenesis{ sgProtocolParams } =
template
template@ShelleyGenesis{ sgProtocolParams } = do
nonDelegCoin <- getCoinForDistribution nonDelegCoinRaw
delegCoin <- getCoinForDistribution delegCoinRaw
pure template
{ sgSystemStart
, sgMaxLovelaceSupply = totalSupply
, sgGenDelegs = shelleyDelKeys
, sgInitialFunds = ListMap.fromList
[ (toShelleyAddr addr, toShelleyLovelace v)
| (addr, v) <-
distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg
++
distribute (delegCoin - subtractForTreasury) nUtxoAddrsDeleg utxoAddrsDeleg
++
mkStuffedUtxo stuffedUtxoAddrs
]
distribute nonDelegCoin nUtxoAddrsNonDeleg utxoAddrsNonDeleg
++ distribute delegCoin nUtxoAddrsDeleg utxoAddrsDeleg
++ mkStuffedUtxo stuffedUtxoAddrs
]
, sgStaking =
ShelleyGenesisStaking
{ sgsPools = ListMap pools
Expand All @@ -611,22 +613,32 @@ updateOutputTemplate
, sgProtocolParams
}
where
getCoinForDistribution :: Integer -> m Natural
getCoinForDistribution inputCoin = do
let value = inputCoin - subtrahendForTreasury
if value < 0
then throwError $ GenesisCmdNegativeInitialFunds value
else pure $ fromInteger value

nUtxoAddrsNonDeleg = length utxoAddrsNonDeleg
maximumLovelaceSupply :: Word64
maximumLovelaceSupply = sgMaxLovelaceSupply template
-- If the initial funds are equal to the maximum funds, rewards cannot be created.
subtractForTreasury :: Integer
subtractForTreasury = nonDelegCoin `quot` 10
totalSupply :: Word64
subtrahendForTreasury :: Integer
subtrahendForTreasury = nonDelegCoinRaw `quot` 10

totalSupply :: Integral a => a
-- if --total-supply is not specified, supply comes from the template passed to this function:
totalSupply = maybe maximumLovelaceSupply unLovelace mTotalSupply
delegCoin, nonDelegCoin :: Integer
delegCoin = case mDelegatedSupply of Nothing -> 0; Just amountDeleg -> fromIntegral totalSupply - unLovelace amountDeleg
nonDelegCoin = fromIntegral totalSupply - delegCoin

distribute :: Integer -> Int -> [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)]
distribute funds nAddrs addrs = zip addrs (fmap Lovelace (coinPerAddr + remainder:repeat coinPerAddr))
where coinPerAddr, remainder :: Integer
totalSupply = fromIntegral $ maybe maximumLovelaceSupply unLovelace mTotalSupply

delegCoinRaw, nonDelegCoinRaw :: Integer
delegCoinRaw = case mDelegatedSupply of Nothing -> 0; Just (Lovelace amountDeleg) -> totalSupply - amountDeleg
nonDelegCoinRaw = totalSupply - delegCoinRaw

distribute :: Natural -> Int -> [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)]
distribute funds nAddrs addrs =
zip addrs $ Lovelace . toInteger <$> (coinPerAddr + remainder:repeat coinPerAddr)
where coinPerAddr, remainder :: Natural
(coinPerAddr, remainder) = funds `divMod` fromIntegral nAddrs

mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)]
Expand Down Expand Up @@ -729,4 +741,4 @@ readInitialFundAddresses utxoKeys nw = do
, let vkh = verificationKeyHash (castVerificationKey vkey)
addr = makeShelleyAddressInEra ShelleyBasedEraShelley nw (PaymentCredentialByKey vkh)
NoStakeAddress
]
]
3 changes: 3 additions & 0 deletions cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -39,6 +39,7 @@ data GenesisCmdError
| GenesisCmdStakePoolRelayFileError !FilePath !IOException
| GenesisCmdStakePoolRelayJsonDecodeError !FilePath !String
| GenesisCmdFileInputDecodeError !(FileError InputDecodeError)
| GenesisCmdNegativeInitialFunds !Integer -- ^ total supply underflow
deriving Show

instance Error GenesisCmdError where
Expand Down Expand Up @@ -97,3 +98,5 @@ instance Error GenesisCmdError where
" Error: " <> pretty e
GenesisCmdFileInputDecodeError ide ->
"Error occured while decoding a file: " <> pshow ide
GenesisCmdNegativeInitialFunds underflow ->
"Provided delegated supply value results in negative initial funds. Decrease delegated amount by " <> pretty ((-1) * underflow) <> " or increase total supply by it."
86 changes: 80 additions & 6 deletions cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs
View file
Original file line number Diff line number Diff line change
@@ -1,12 +1,28 @@
module Test.Cli.CreateTestnetData where

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cli.CreateTestnetData where

import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as LBS
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import GHC.Generics
import GHC.IO.Exception (ExitCode (..))
import GHC.Stack
import System.FilePath

import Test.Cardano.CLI.Util (execCardanoCLI)
import Test.Cardano.CLI.Util (execCardanoCLI, execDetailCardanoCLI)

import Hedgehog (Property)
import Hedgehog (MonadTest, Property, success, (===))
import qualified Hedgehog as H
import Hedgehog.Extras (moduleWorkspace, propertyOnce)
import qualified Hedgehog.Extras as H

Expand All @@ -19,11 +35,69 @@ hprop_create_testnet_data_minimal =

let outputDir = tempDir </> "out"

-- We test that the command doesn't crash, because otherwise
-- execCardanoCLI would fail.
H.noteM_ $ execCardanoCLI
["conway", "genesis", "create-testnet-data"
, "--testnet-magic", "42"
, "--out-dir", outputDir
]
success

-- We test that the command doesn't crash, because otherwise
-- execCardanoCLI would fail.
hprop_create_testnet_data_create_nonegative_supply :: Property
hprop_create_testnet_data_create_nonegative_supply = do
-- FIXME rewrite this as a property test
let supplyValues =
[ -- (total supply, delegated supply, exit code)
(2_000_000_000, 1_000_000_000, ExitSuccess)
, (1_100_000_000, 1_000_000_000, ExitSuccess)
, (1_000_000_000, 1_000_000_000, ExitFailure 1)
, (1_000_000_000, 2_000_000_000, ExitFailure 1)
] :: [(Int, Int, ExitCode)]

propertyOnce $ forM_ supplyValues $ \(totalSupply, delegatedSupply, expectedExitCode) ->
moduleWorkspace "tmp" $ \tempDir -> do
let outputDir = tempDir </> "out"

(exitCode, _, _) <- H.noteShowM $ execDetailCardanoCLI
["conway", "genesis", "create-testnet-data"
, "--testnet-magic", "42"
, "--pools", "3"
, "--total-supply", show totalSupply
, "--delegated-supply", show delegatedSupply
, "--stake-delegators", "3"
, "--utxo-keys", "3"
, "--drep-keys", "3"
, "--out-dir", outputDir
]

H.note_ "check that exit code is equal to the expected one"
exitCode === expectedExitCode

when (exitCode == ExitSuccess) $ do
testGenesis@TestGenesis{maxLovelaceSupply, initialFunds} <- H.leftFailM . readJsonFile $ outputDir </> "genesis.json"
H.note_ $ show testGenesis

H.note_ "check that max lovelace supply is set equal to --total-supply flag value"
maxLovelaceSupply === totalSupply

H.note_ "check that all initial funds are positive"
H.assertWith initialFunds $ all (>= 0) . M.elems

H.note_ "check that initial funds are not bigger than max lovelace supply"
H.assertWith initialFunds $ \initialFunds' -> do
let totalDistributed = sum . M.elems $ initialFunds'
totalDistributed <= maxLovelaceSupply

data TestGenesis = TestGenesis
{ maxLovelaceSupply :: Int
, initialFunds :: Map Text Int
} deriving (Show, Generic, ToJSON, FromJSON)


-- compabitility shim for hedgehog-extras until https://github.com/input-output-hk/hedgehog-extras/pull/60
-- gets integrated - remove afterwards
readJsonFile :: forall a m. (MonadTest m, MonadIO m, FromJSON a, HasCallStack) => FilePath -> m (Either String a)
readJsonFile filePath = withFrozenCallStack $ do
void . H.annotate $ "Reading JSON file: " <> filePath
H.evalIO $ A.eitherDecode <$> LBS.readFile filePath

0 comments on commit 0e393cb

Please sign in to comment.