diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs index 712581cd76..11bf455a6a 100644 --- a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs +++ b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs @@ -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 (()) @@ -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) } @@ -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' @@ -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 @@ -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)] @@ -729,4 +741,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..56e5bd9b6e 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 !Integer -- ^ total supply underflow 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 underflow -> + "Provided delegated supply value results in negative initial funds. Decrease delegated amount by " <> pretty ((-1) * underflow) <> " or increase total supply by it." 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 669ee97879..089ee1c05e 100644 --- a/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs +++ b/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs @@ -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 @@ -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