cardano-testnet: Test treasury donation

cardano-testnet/cardano-testnet.cabal

@@ -195,6 +195,7 @@ test-suite cardano-testnet-test
                         Cardano.Testnet.Test.Gov.NoConfidence
                         Cardano.Testnet.Test.Gov.ProposeNewConstitution
                         Cardano.Testnet.Test.Gov.ProposeNewConstitutionSPO
+                        Cardano.Testnet.Test.Gov.TreasuryDonation
                         Cardano.Testnet.Test.Gov.TreasuryGrowth
                         Cardano.Testnet.Test.Gov.TreasuryWithdrawal
                         Cardano.Testnet.Test.Misc

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

@@ -20,6 +20,7 @@ module Testnet.Components.Query
   , getMinGovActionDeposit
   , getGovState
   , getCurrentEpochNo
+  , getTreasuryValue
 
   , TestnetWaitPeriod (..)
   , waitForEpochs
@@ -464,6 +465,17 @@ getGovState epochStateView ceo = withFrozenCallStack $ do
   Refl <- H.leftFail $ assertErasEqual sbe sbe'
   pure $ conwayEraOnwardsConstraints ceo $ newEpochState ^. L.newEpochStateGovStateL
 
+getTreasuryValue
+  :: HasCallStack
+  => MonadAssertion m
+  => MonadIO m
+  => MonadTest m
+  => EpochStateView
+  -> m L.Coin -- ^ TODO
+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/test/cardano-testnet-test/Cardano/Testnet/Test/Gov/TreasuryDonation.hs

@@ -0,0 +1,142 @@
+{-# 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 (void, when)
+import qualified Data.Text as Text
+import           GHC.Stack (HasCallStack)
+import           System.FilePath ((</>))
+
+import           Testnet.Components.Query
+import           Testnet.Components.TestWatchdog
+import           Testnet.Process.Run (execCli', 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:
+-- @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' -> 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
+
+  let doOneDonation = doTreasuryDonation sbe execConfig work epochStateView wallet0
+
+  doOneDonation 0 500
+  doOneDonation 1 500_013
+
+doTreasuryDonation :: ()
+  => HasCallStack
+  => MonadCatch m
+  => MonadTest m
+  => MonadIO m
+  => H.MonadAssertion m
+  -- => MonadCatch m
+  => ShelleyBasedEra era
+  -> H.ExecConfig
+  -> FilePath -- ^ Where temporary files can be stored
+  -> EpochStateView
+  -> PaymentKeyInfo
+  -> Int -- ^ The number of the call, used to create unique temporary file names. Starts at 0.
+  -> Int -- ^ The amount to donate
+  -> m ()
+doTreasuryDonation sbe execConfig work epochStateView wallet0 idx treasuryDonation = do
+  L.Coin currentTreasury <- getTreasuryValue epochStateView
+  H.note_ $ "currentTreasury: " <> show currentTreasury
+
+  -- If it's the first donation, the current treasury must be zero:
+  when (idx == 0) (currentTreasury H.=== 0)
+
+  txBodyFp <- H.note $ work </> "treasury-donation-" <> show idx <> ".body"
+  signedTxFp <- H.note $ work </> "treasury-donation-" <> show idx <> ".signed"
+
+  txIn0 <- findLargestUtxoForPaymentKey epochStateView sbe wallet0
+
+  H.noteM_ $ execCli' execConfig
+    [ "conway", "transaction", "build"
+    , "--tx-in", Text.unpack $ renderTxIn txIn0
+    , "--change-address", Text.unpack $ paymentKeyInfoAddr wallet0
+    , "--current-treasury-value", show currentTreasury
+    , "--treasury-donation", show treasuryDonation
+    , "--out-file", txBodyFp
+    ]
+
+  H.noteM_ $ execCli' execConfig
+    [ "conway", "transaction", "view"
+    , "--tx-file", txBodyFp
+    ]
+
+  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 5)
+
+  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

@@ -19,6 +19,7 @@ import qualified Cardano.Testnet.Test.Gov.DRepRetirement as Gov
 import qualified Cardano.Testnet.Test.Gov.NoConfidence 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
@@ -59,6 +60,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 "Treasury Withdrawal" Gov.hprop_ledger_events_treasury_withdrawal
+                , ignoreOnWindows "Treasury Donation" Gov.hprop_ledger_events_treasury_donation
                 -- FIXME Those tests are flaky
                 -- , ignoreOnWindows "InfoAction" LedgerEvents.hprop_ledger_events_info_action
                 ]