cardano-testnet: Test treasury donation

cardano-testnet/cardano-testnet.cabal

@@ -197,10 +197,10 @@ test-suite cardano-testnet-test
                         Cardano.Testnet.Test.Gov.ProposeNewConstitution
                         Cardano.Testnet.Test.Gov.ProposeNewConstitutionSPO
                         Cardano.Testnet.Test.Gov.GovActionTimeout
+                        Cardano.Testnet.Test.Gov.TreasuryDonation
                         Cardano.Testnet.Test.Gov.TreasuryGrowth
                         Cardano.Testnet.Test.Gov.TreasuryWithdrawal
                         Cardano.Testnet.Test.Misc
-                        Cardano.Testnet.Test.Gov.DRepActivity
                         Cardano.Testnet.Test.Gov.PredefinedAbstainDRep
                         Cardano.Testnet.Test.Node.Shutdown
                         Cardano.Testnet.Test.SanityCheck

cardano-testnet/src/Testnet/Components/Query.hs

@@ -20,6 +20,7 @@ module Testnet.Components.Query
   , getMinGovActionDeposit
   , getGovState
   , getCurrentEpochNo
+  , getTreasuryValue
 
   , TestnetWaitPeriod (..)
   , waitForEpochs
@@ -466,6 +467,18 @@ getGovState epochStateView ceo = withFrozenCallStack $ do
   Refl <- H.leftFail $ assertErasEqual sbe sbe'
   pure $ conwayEraOnwardsConstraints ceo $ newEpochState ^. L.newEpochStateGovStateL
 
+-- | Obtain the current value of the treasury from the node
+getTreasuryValue
+  :: HasCallStack
+  => MonadAssertion m
+  => MonadIO m
+  => MonadTest m
+  => EpochStateView
+  -> m L.Coin -- ^ The current value of the treasury
+getTreasuryValue epochStateView = withFrozenCallStack $ do
+  AnyNewEpochState _ newEpochState <- getEpochState epochStateView
+  pure $ newEpochState ^. L.nesEpochStateL . L.epochStateTreasuryL
+
 -- | Obtain minimum deposit amount for governance action from node
 getMinGovActionDeposit
   :: HasCallStack

cardano-testnet/src/Testnet/Process/Run.hs

@@ -97,7 +97,7 @@ execCliAny
   :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)
   => ExecConfig
   -> [String]
-  -> m (ExitCode, String, String) -- ^ The exit code of the call, stdoud, stderr.
+  -> m (ExitCode, String, String) -- ^ The exit code of the call, stdout, stderr.
 execCliAny execConfig = GHC.withFrozenCallStack $ H.execFlexAny' execConfig "cardano-cli" "CARDANO_CLI"
 
 -- | Run create-script-context, returning the stdout.

cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/ProposeNewConstitutionSPO.hs

@@ -41,7 +41,7 @@ import qualified Hedgehog.Extras as H
 
 -- | Test that SPO cannot vote on a new constitution
 -- Execute me with:
--- @cabal test cardano-testnet-test --test-options '-p "/ProposeNewConstitutionSPO/"'@
+-- @cabal test cardano-testnet-test --test-options '-p "/Propose New Constitution SPO/"'@
 hprop_ledger_events_propose_new_constitution_spo :: Property
 hprop_ledger_events_propose_new_constitution_spo = integrationWorkspace "propose-new-constitution-spo" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do
   conf@Conf { tempAbsPath=tempAbsPath@(TmpAbsolutePath work) }

cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryDonation.hs

@@ -0,0 +1,156 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Testnet.Test.Gov.TreasuryDonation
+  ( hprop_ledger_events_treasury_donation
+  ) where
+
+import           Cardano.Api
+import           Cardano.Api.Ledger
+
+import qualified Cardano.Ledger.Coin as L
+import           Cardano.Testnet
+
+import           Prelude
+
+import           Control.Monad.Catch (MonadCatch)
+import           Control.Monad (unless, void)
+import qualified Data.Text as Text
+import           GHC.Stack (HasCallStack)
+import           System.Exit
+import           System.FilePath ((</>))
+
+import           Testnet.Components.Query
+import           Testnet.Process.Run (execCli', execCliAny, mkExecConfig)
+import           Testnet.Property.Util (integrationWorkspace)
+import           Testnet.Types
+
+import           Hedgehog
+import qualified Hedgehog as H
+import qualified Hedgehog.Extras as H
+
+-- | Test that donating to the treasury indeed increases the treasury
+-- Execute me with:
+-- @DISABLE_RETRIES=1 cabal test cardano-testnet-test --test-options '-p "/Treasury Donation/"'@
+hprop_ledger_events_treasury_donation :: Property
+hprop_ledger_events_treasury_donation = integrationWorkspace "treasury-donation" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do
+  conf@Conf { tempAbsPath=tempAbsPath@(TmpAbsolutePath work) }
+    <- mkConf tempAbsBasePath'
+  let tempBaseAbsPath = makeTmpBaseAbsPath tempAbsPath
+
+  let ceo = ConwayEraOnwardsConway
+      sbe = conwayEraOnwardsToShelleyBasedEra ceo
+      era = toCardanoEra sbe
+      cEra = AnyCardanoEra era
+      fastTestnetOptions = cardanoDefaultTestnetOptions
+        { cardanoEpochLength = 100
+        , cardanoSlotLength = 0.1
+        , cardanoNodeEra = cEra
+        }
+
+  TestnetRuntime
+    { testnetMagic
+    , poolNodes
+    , wallets=wallet0:_
+    , configurationFile
+    }
+    <- cardanoTestnetDefault fastTestnetOptions conf
+
+  PoolNode{poolRuntime} <- H.headM poolNodes
+  poolSprocket1 <- H.noteShow $ nodeSprocket poolRuntime
+  execConfig <- mkExecConfig tempBaseAbsPath poolSprocket1 testnetMagic
+  let socketPath = nodeSocketPath poolRuntime
+
+  epochStateView <- getEpochStateView configurationFile socketPath
+
+  H.note_ $ "Sprocket: " <> show poolSprocket1
+  H.note_ $ "Abs path: " <> tempAbsBasePath'
+  H.note_ $ "Socketpath: " <> unFile socketPath
+  H.note_ $ "Foldblocks config file: " <> unFile configurationFile
+
+  L.Coin currentTreasury <- getTreasuryValue epochStateView
+  H.note_ $ "currentTreasury: " <> show currentTreasury
+  currentTreasury H.=== 0 -- Treasury should initially be 0
+
+  let doOneDonation = doTreasuryDonation sbe execConfig work epochStateView wallet0
+
+  doOneDonation 0 Nothing 500
+  doOneDonation 1 Nothing 500_013
+  doOneDonation 2 Nothing (-497) -- Test donation that should fail because donation is negative
+  doOneDonation 3 (Just 1_234) (-497) -- Test donation that should fail because current treasury value is wrong
+
+doTreasuryDonation :: ()
+  => (HasCallStack, MonadCatch m, MonadTest m, MonadIO m, H.MonadAssertion m)
+  => ShelleyBasedEra era
+  -> H.ExecConfig
+  -> FilePath -- ^ Where temporary files can be stored
+  -> EpochStateView
+  -> PaymentKeyInfo-- ^ The key paying the fee
+  -> Int -- ^ The number of the call, used to create unique temporary file names. Starts at 0.
+  -> Maybe Int -- ^ The current treasury value to use. If unspecified, it will obtained from the node.
+  -> Int -- ^ The amount to donate
+  -> m ()
+doTreasuryDonation sbe execConfig work epochStateView wallet0 idx currentTreasury' treasuryDonation = do
+  currentTreasury <- 
+    case currentTreasury' of
+      Nothing -> do
+        v <- unCoin <$> getTreasuryValue epochStateView
+        H.note_ $ "currentTreasury: " <> show v
+        return v
+      Just x -> pure $ toInteger x
+
+  txBodyFp <- H.note $ work </> "treasury-donation-" <> show idx <> ".body"
+  txViewFp <- H.note $ work </> "treasury-donation-" <> show idx <> ".body.view.json"
+  signedTxFp <- H.note $ work </> "treasury-donation-" <> show idx <> ".signed"
+
+  txIn0 <- findLargestUtxoForPaymentKey epochStateView sbe wallet0
+
+  (exitCode, stdout, stderr) <- execCliAny execConfig
+    [ "conway", "transaction", "build"
+    , "--tx-in", Text.unpack $ renderTxIn txIn0
+    , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet0
+    , "--treasury-donation", show treasuryDonation
+    , "--out-file", txBodyFp
+    ]
+  H.note_ $ "exitCode: " <> show exitCode
+  unless (null stdout) (H.note_ stdout)
+  unless (null stderr) (H.note_ stderr)
+
+  case exitCode of
+    ExitFailure _ -> do
+      H.assertWith (currentTreasury, treasuryDonation) $ \(ct, td) ->
+        -- If we failed, either the specified treasury was negative,
+        -- or the donation was negative.
+        ct < 0 || td < 0
+      return ()
+    ExitSuccess -> do
+      H.assertWith (currentTreasury, treasuryDonation) $ \(ct, td) ->
+        -- If we succeeded, both the specified treasury and donation were
+        -- greater or equal to zero.
+        ct >= 0 && td >= 0
+      H.noteM_ $ execCli' execConfig
+        [ "conway", "transaction", "view" , "--tx-file", txBodyFp
+        , "--output-json", "--out-file", txViewFp]
+
+      H.noteM_ $ execCli' execConfig
+        [ "conway", "transaction", "sign"
+        , "--tx-body-file", txBodyFp
+        , "--signing-key-file", signingKeyFp $ paymentKeyInfoPair wallet0
+        , "--out-file", signedTxFp
+        ]
+
+      H.noteM_ $ execCli' execConfig
+        [ "conway", "transaction", "view" , "--tx-file", signedTxFp ]
+
+      H.noteM_ $ execCli' execConfig
+        [ "conway", "transaction", "submit" , "--tx-file", signedTxFp ]
+
+      void $ waitForEpochs epochStateView (EpochInterval 3)
+
+      L.Coin finalTreasury <- getTreasuryValue epochStateView
+      H.note_ $ "finalTreasury: " <> show finalTreasury
+      finalTreasury H.=== (currentTreasury + toInteger treasuryDonation)

cardano-testnet/test/cardano-testnet-test/cardano-testnet-test.hs

@@ -21,6 +21,7 @@ import qualified Cardano.Testnet.Test.Gov.NoConfidence as Gov
 import qualified Cardano.Testnet.Test.Gov.PParamChangeFailsSPO as Gov
 import qualified Cardano.Testnet.Test.Gov.ProposeNewConstitution as Gov
 import qualified Cardano.Testnet.Test.Gov.ProposeNewConstitutionSPO as Gov
+import qualified Cardano.Testnet.Test.Gov.TreasuryDonation as Gov
 import qualified Cardano.Testnet.Test.Gov.TreasuryGrowth as Gov
 import qualified Cardano.Testnet.Test.Gov.TreasuryWithdrawal as Gov
 import qualified Cardano.Testnet.Test.Node.Shutdown
@@ -61,6 +62,7 @@ tests = do
                 , ignoreOnMacAndWindows "Propose And Ratify New Constitution" Gov.hprop_ledger_events_propose_new_constitution
                 , ignoreOnWindows "Propose New Constitution SPO" Gov.hprop_ledger_events_propose_new_constitution_spo
                 , ignoreOnWindows "Gov Action Timeout" Gov.hprop_check_gov_action_timeout
+                , ignoreOnWindows "Treasury Donation" Gov.hprop_ledger_events_treasury_donation
                 , ignoreOnWindows "Treasury Withdrawal" Gov.hprop_ledger_events_treasury_withdrawal
                 , ignoreOnWindows "PParam change fails for SPO" Gov.hprop_check_pparam_fails_spo
                 -- FIXME Those tests are flaky