Merge pull request #644 from IntersectMBO/smelc/fix-treasury-subtrahend

create-testnet-data: fix that treasury could be unexpectedly negative
IntersectMBO · Mar 12, 2024 · 33599f2 · 33599f2
2 parents eafcf17 + 08c71fa
commit 33599f2
Show file tree

Hide file tree

Showing 3 changed files with 25 additions and 15 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/CreateTestnetData.hs
@@ -582,8 +582,7 @@ updateOutputTemplate
   mDelegatedSupply
   nUtxoAddrsDeleg utxoAddrsDeleg stuffedUtxoAddrs
   template@ShelleyGenesis{ sgProtocolParams } = do
-    nonDelegCoin <- getCoinForDistribution nonDelegCoinRaw
-    delegCoin <- getCoinForDistribution delegCoinRaw
+    when (delegCoinRaw > totalSupply) (throwError $ GenesisCmdDelegatedSupplyExceedsTotalSupply delegCoinRaw totalSupply)
     pure template
           { sgSystemStart
           , sgMaxLovelaceSupply = totalSupply
@@ -603,18 +602,18 @@ updateOutputTemplate
           , sgProtocolParams
           }
   where
-    getCoinForDistribution :: Integer -> m Natural
-    getCoinForDistribution inputCoin = do
-      let value = inputCoin - subtrahendForTreasury
-      when (value < 0) $ throwError $ GenesisCmdNegativeInitialFunds value
-      pure $ fromInteger value
+    nonDelegCoin = getCoinForDistribution nonDelegCoinRaw
+    delegCoin = getCoinForDistribution delegCoinRaw
+
+    getCoinForDistribution :: Integer -> Natural
+    getCoinForDistribution inputCoin =
+      -- If the initial funds are equal to the maximum funds, rewards cannot be created.
+      -- So subtrahend a part for the treasury:
+      fromInteger $ inputCoin - (inputCoin `quot` 10)
 
     nUtxoAddrsNonDeleg  = length utxoAddrsNonDeleg
     maximumLovelaceSupply :: Word64
     maximumLovelaceSupply = sgMaxLovelaceSupply template
-    -- If the initial funds are equal to the maximum funds, rewards cannot be created.
-    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:

diff --git a/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs b/cardano-cli/src/Cardano/CLI/Types/Errors/GenesisCmdError.hs
@@ -39,7 +39,7 @@ data GenesisCmdError
   | GenesisCmdStakePoolRelayFileError !FilePath !IOException
   | GenesisCmdStakePoolRelayJsonDecodeError !FilePath !String
   | GenesisCmdFileInputDecodeError !(FileError InputDecodeError)
-  | GenesisCmdNegativeInitialFunds !Integer -- ^ total supply underflow
+  | GenesisCmdDelegatedSupplyExceedsTotalSupply !Integer !Integer -- ^ First @Integer@ is the delegate supply, second @Integer@ is the total supply
   deriving Show
 
 instance Error GenesisCmdError where
@@ -101,5 +101,7 @@ 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."
+    GenesisCmdDelegatedSupplyExceedsTotalSupply delegated total ->
+      "Provided delegated supply is " <> pretty delegated <> ", which is greater than the specified total supply: " <> pretty total <> "." <>
+      "This is incorrect: the delegated supply should be less or equal to the total supply." <>
+      " Note that the total supply can either come from --total-supply or from the default template. Please fix what you use."
diff --git a/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs b/cardano-cli/test/cardano-cli-test/Test/Cli/CreateTestnetData.hs
@@ -8,6 +8,7 @@ module Test.Cli.CreateTestnetData where
 
 import           Control.Monad
 import           Data.Aeson (FromJSON, ToJSON)
+import           Data.List (isInfixOf)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
 import           Data.Text (Text)
@@ -49,6 +50,8 @@ hprop_create_testnet_data_create_nonegative_supply = do
           (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, ExitSuccess)
+        , (1_000_000_000_000, 1_000_000_000, ExitSuccess)
+        , (1_000_000_000, 1_000_000_001, ExitFailure 1)
         , (1_000_000_000, 1_100_000_001, ExitFailure 1)
         , (1_000_000_000, 2_000_000_000, ExitFailure 1)
         ] :: [(Int, Int, ExitCode)]
@@ -57,7 +60,7 @@ hprop_create_testnet_data_create_nonegative_supply = do
     moduleWorkspace "tmp" $ \tempDir -> do
       let outputDir = tempDir </> "out"
 
-      (exitCode, _, _) <- H.noteShowM $ execDetailCardanoCLI
+      (exitCode, _stdout, stderr) <- H.noteShowM $ execDetailCardanoCLI
         ["conway",  "genesis", "create-testnet-data"
         , "--testnet-magic", "42"
         , "--pools", "3"
@@ -72,7 +75,8 @@ hprop_create_testnet_data_create_nonegative_supply = do
       H.note_ "check that exit code is equal to the expected one"
       exitCode === expectedExitCode
 
-      when (exitCode == ExitSuccess) $ do
+      if exitCode == ExitSuccess
+      then do
         testGenesis@TestGenesis{maxLovelaceSupply, initialFunds} <- H.leftFailM . H.readJsonFile $ outputDir </> "genesis.json"
         H.note_ $ show testGenesis
 
@@ -86,6 +90,11 @@ hprop_create_testnet_data_create_nonegative_supply = do
         H.assertWith initialFunds $ \initialFunds' -> do
           let totalDistributed = sum . M.elems $ initialFunds'
           totalDistributed <= maxLovelaceSupply
+      else do
+        H.assertWith stderr (`contains` "delegated supply should be less or equal to the total supply")
+  where
+    contains s1 s2 = s2 `isInfixOf` s1
+
 
 data TestGenesis = TestGenesis
   { maxLovelaceSupply :: Int