From a70fab8edbd2a0b69e1b5cf97c0a4476ea9fe7a4 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 9 Feb 2024 19:06:33 +0100 Subject: [PATCH] Add returning an error on invalid initial supply value --- .../CLI/EraBased/Run/CreateTestnetData.hs | 65 ++++++++++--------- .../CLI/Types/Errors/GenesisCmdError.hs | 3 + .../Test/Cli/CreateTestnetData.hs | 35 +++++----- 3 files changed, 57 insertions(+), 46 deletions(-) diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs index cbffe5f057..3de6cf2f0b 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs @@ -204,10 +204,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) } @@ -303,10 +303,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' @@ -572,37 +572,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 + nonDelegatedFunds <- distribute (nonDelegCoin - subtractForTreasury) nUtxoAddrsNonDeleg utxoAddrsNonDeleg + delegatedFunds <- distribute (delegCoin - subtractForTreasury) nUtxoAddrsDeleg utxoAddrsDeleg + 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 - ] + nonDelegatedFunds + ++ delegatedFunds + ++ mkStuffedUtxo stuffedUtxoAddrs + ] , sgStaking = ShelleyGenesisStaking { sgsPools = ListMap pools @@ -624,10 +625,12 @@ updateOutputTemplate 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 $ Lovelace <$> (coinPerAddr + remainder:repeat coinPerAddr) + distribute :: Integer -> Int -> [AddressInEra ShelleyEra] -> m [(AddressInEra ShelleyEra, Lovelace)] + distribute funds nAddrs addrs + | funds < 0 = throwError GenesisCmdNegativeInitialFunds + | otherwise = pure . zip addrs $ Lovelace <$> (coinPerAddr + remainder:repeat coinPerAddr) where coinPerAddr, remainder :: Integer - (coinPerAddr, remainder) = max 0 funds `divMod` fromIntegral nAddrs + (coinPerAddr, remainder) = funds `divMod` fromIntegral nAddrs mkStuffedUtxo :: [AddressInEra ShelleyEra] -> [(AddressInEra ShelleyEra, Lovelace)] mkStuffedUtxo xs = (, Lovelace minUtxoVal) <$> xs @@ -729,4 +732,4 @@ readInitialFundAddresses utxoKeys nw = do , let vkh = verificationKeyHash (castVerificationKey vkey) addr = makeShelleyAddressInEra ShelleyBasedEraShelley nw (PaymentCredentialByKey vkh) NoStakeAddress - ] \ No newline at end of file + ] diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs index d59fd086fd..ee98ed88d2 100644 --- a/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs +++ b/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs @@ -39,6 +39,7 @@ data GenesisCmdError | GenesisCmdStakePoolRelayFileError !FilePath !IOException | GenesisCmdStakePoolRelayJsonDecodeError !FilePath !String | GenesisCmdFileInputDecodeError !(FileError InputDecodeError) + | GenesisCmdNegativeInitialFunds deriving Show instance Error GenesisCmdError where @@ -97,3 +98,5 @@ instance Error GenesisCmdError where " Error: " <> pretty e GenesisCmdFileInputDecodeError ide -> "Error occured while decoding a file: " <> pshow ide + GenesisCmdNegativeInitialFunds -> + "Provided delegated supply value results in negative initial funds. Decrease delegated amount." diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs index 94b688ced0..3c5a14ca6d 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs @@ -15,12 +15,13 @@ 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 (MonadTest, Property, success) +import Hedgehog (MonadTest, Property, success, (===)) import qualified Hedgehog as H import Hedgehog.Extras (moduleWorkspace, propertyOnce) import qualified Hedgehog.Extras as H @@ -47,17 +48,17 @@ 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) - (2_000_000_000, 1_000_000_000) - , (1_000_000_000, 1_000_000_000) - , (1_000_000_000, 2_000_000_000) - ] :: [(Int, Int)] + [ -- (total supply, delegated supply, exit code) + (2_000_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) -> + propertyOnce $ forM_ supplyValues $ \(totalSupply, delegatedSupply, expectedExitCode) -> moduleWorkspace "tmp" $ \tempDir -> do let outputDir = tempDir "out" - H.noteM_ $ execCardanoCLI + (exitCode, stdout, stderr) <- H.noteShowM $ execDetailCardanoCLI ["conway", "genesis", "create-testnet-data" , "--testnet-magic", "42" , "--pools", "3" @@ -69,15 +70,19 @@ hprop_create_testnet_data_create_nonegative_supply = do , "--out-dir", outputDir ] - testGenesis@TestGenesis{maxLovelaceSupply, initialFunds} <- H.leftFailM . readJsonFile $ outputDir "genesis.json" - H.note_ $ show testGenesis + H.note_ $ "Expected exit code: " <> show expectedExitCode <> ", received: " <> show exitCode + H.note_ $ unlines ["stdout:", stdout, "stderr:", stderr] + exitCode === expectedExitCode - H.note_ "check that max lovelace supply is positive" - H.assertWith maxLovelaceSupply (>= 0) + when (exitCode == ExitSuccess) $ do + testGenesis@TestGenesis{maxLovelaceSupply, initialFunds} <- H.leftFailM . readJsonFile $ outputDir "genesis.json" + H.note_ $ show testGenesis - H.note_ "check that all initial funds are positive" - H.assertWith initialFunds $ all (>= 0) . M.elems + 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 data TestGenesis = TestGenesis { maxLovelaceSupply :: Int