Add returning an error on invalid initial supply value

IntersectMBO · Feb 9, 2024 · a70fab8 · a70fab8
1 parent d68dae3
commit a70fab8
Show file tree

Hide file tree

Showing 3 changed files with 57 additions and 46 deletions.
diff --git 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
-           ]
+           ]
diff --git 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
@@ -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