Merge pull request #5920 from IntersectMBO/ensure-query-test-complete…

…ness

Ensure query test completeness

cardano-testnet/cardano-testnet.cabal

@@ -82,6 +82,7 @@ library
                       , tasty ^>= 1.5
                       , tasty-expected-failure
                       , tasty-hedgehog
+                      , template-haskell
                       , temporary
                       , text
                       , time
@@ -110,12 +111,14 @@ library
                         Testnet.Start.Byron
                         Testnet.Start.Types
                         Testnet.SubmitApi
+                        Testnet.TestQueryCmds
                         Testnet.Types
 
   other-modules:        Parsers.Cardano
                         Parsers.Help
                         Parsers.Version
                         Testnet.Start.Cardano
+                        Testnet.TestEnumGenerator
                         Paths_cardano_testnet
 
   autogen-modules:      Paths_cardano_testnet

cardano-testnet/src/Testnet/Process/Cli/Transaction.hs

@@ -1,26 +1,34 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Testnet.Process.Cli.Transaction
-  ( signTx
+  ( mkSimpleSpendOutputsOnlyTx
+  , mkSpendOutputsOnlyTx
+  , signTx
   , submitTx
   , failToSubmitTx
   , retrieveTransactionId
   , SignedTx
   , TxBody
+  , TxOutAddress(..)
   , VoteFile
   ) where
 
 import           Cardano.Api hiding (Certificate, TxBody)
+import           Cardano.Api.Ledger (Coin (unCoin))
 
 import           Prelude
 
 import           Control.Monad (void)
 import           Control.Monad.Catch (MonadCatch)
 import           Data.List (isInfixOf)
+import qualified Data.Text as T
+import           Data.Typeable (Typeable)
 import           GHC.IO.Exception (ExitCode (..))
 import           GHC.Stack
 import           System.FilePath ((</>))
 
+import           Testnet.Components.Query (EpochStateView, findLargestUtxoForPaymentKey)
 import           Testnet.Process.Run (execCli')
 import           Testnet.Start.Types (anyEraToString)
 import           Testnet.Types
@@ -35,6 +43,95 @@ data TxBody
 
 data SignedTx
 
+data ReferenceScriptJSON
+
+data TxOutAddress = PubKeyAddress PaymentKeyInfo
+                  | ReferenceScriptAddress (File ReferenceScriptJSON In)
+                  -- ^ The output will be created at the script address
+                  -- and the output will include the reference script.
+
+-- | Calls @cardano-cli@ to build a simple ADA transfer transaction to
+-- the specified outputs of the specified amount of ADA. In the case of
+-- a reference script address, the output will be created at the
+-- corresponding script address, and the output will contain the reference
+-- script.
+--
+-- Returns the generated @File TxBody In@ file path to the created unsigned
+-- transaction file.
+mkSpendOutputsOnlyTx
+  :: HasCallStack
+  => Typeable era
+  => H.MonadAssertion m
+  => MonadTest m
+  => MonadCatch m
+  => MonadIO m
+  => H.ExecConfig -- ^ Specifies the CLI execution configuration.
+  -> EpochStateView -- ^ Current epoch state view for transaction building. It can be obtained
+                    -- using the 'getEpochStateView' function.
+  -> ShelleyBasedEra era -- ^ Witness for the current Cardano era.
+  -> FilePath -- ^ Base directory path where the unsigned transaction file will be stored.
+  -> String -- ^ Prefix for the output unsigned transaction file name. The extension will be @.txbody@.
+  -> PaymentKeyInfo -- ^ Payment key pair used for paying the transaction.
+  -> [(TxOutAddress, Coin)] -- ^ List of pairs of transaction output addresses and amounts.
+  -> m (File TxBody In)
+mkSpendOutputsOnlyTx execConfig epochStateView sbe work prefix srcWallet txOutputs = do
+
+  txIn <- findLargestUtxoForPaymentKey epochStateView sbe srcWallet
+  fixedTxOuts :: [String] <- computeTxOuts
+  void $ execCli' execConfig $ mconcat
+    [ [ anyEraToString cEra, "transaction", "build"
+      , "--change-address", srcAddress
+      , "--tx-in", T.unpack $ renderTxIn txIn
+      ]
+    , fixedTxOuts
+    , [ "--out-file", unFile txBody
+      ]
+    ]
+  return txBody
+  where
+    era = toCardanoEra sbe
+    cEra = AnyCardanoEra era
+    txBody = File (work </> prefix <> ".txbody")
+    srcAddress = T.unpack $ paymentKeyInfoAddr srcWallet
+    computeTxOuts = concat <$> sequence
+      [ case txOut of
+          PubKeyAddress dstWallet ->
+            return ["--tx-out", T.unpack (paymentKeyInfoAddr dstWallet) <> "+" ++ show (unCoin amount) ]
+          ReferenceScriptAddress (File referenceScriptJSON) -> do
+            scriptAddress <- execCli' execConfig [ anyEraToString cEra, "address", "build"
+                                                 , "--payment-script-file", referenceScriptJSON
+                                                 ]
+            return [ "--tx-out", scriptAddress <> "+" ++ show (unCoin amount)
+                   , "--tx-out-reference-script-file", referenceScriptJSON
+                   ]
+      | (txOut, amount) <- txOutputs
+      ]
+
+-- | Calls @cardano-cli@ to build a simple ADA transfer transaction to
+-- transfer to the specified recipient the specified amount of ADA.
+--
+-- Returns the generated @File TxBody In@ file path to the created unsigned
+-- transaction file.
+mkSimpleSpendOutputsOnlyTx
+  :: HasCallStack
+  => Typeable era
+  => H.MonadAssertion m
+  => MonadTest m
+  => MonadCatch m
+  => MonadIO m
+  => H.ExecConfig -- ^ Specifies the CLI execution configuration.
+  -> EpochStateView -- ^ Current epoch state view for transaction building. It can be obtained
+                    -- using the 'getEpochStateView' function.
+  -> ShelleyBasedEra era -- ^ Witness for the current Cardano era.
+  -> FilePath -- ^ Base directory path where the unsigned transaction file will be stored.
+  -> String -- ^ Prefix for the output unsigned transaction file name. The extension will be @.txbody@.
+  -> PaymentKeyInfo -- ^ Payment key pair used for paying the transaction.
+  -> PaymentKeyInfo -- ^ Payment key of the recipient of the transaction.
+  -> Coin -- ^ Amount of ADA to transfer (in Lovelace).
+  -> m (File TxBody In)
+mkSimpleSpendOutputsOnlyTx execConfig epochStateView sbe work prefix srcWallet dstWallet amount =
+  mkSpendOutputsOnlyTx execConfig epochStateView sbe work prefix srcWallet [(PubKeyAddress dstWallet, amount)]
+
 -- | Calls @cardano-cli@ to signs a transaction body using the specified key pairs.
 --
 -- This function takes five parameters:

cardano-testnet/src/Testnet/TestEnumGenerator.hs

@@ -0,0 +1,44 @@
+module Testnet.TestEnumGenerator
+  ( genTestType
+  , genAllConstructorsList
+  ) where
+
+import           Language.Haskell.TH (Body (NormalB), Con (..), Dec (DataD, ValD),
+                   Exp (ConE, ListE), Info (TyConI), Name, Pat (VarP), Q, mkName, nameBase, reify)
+
+-- | Create a datatype with the same constructors as the given type, but with a "Test" prefix and no arguments.
+-- For example, if the input type is 'Maybe', the output type will be 'TestMaybe', with constructors 'TestNothing'
+-- and 'TestJust', but 'TestJust' will have no arguments.
+genTestType :: Name -> Q [Dec]
+genTestType typeName = do
+  TyConI (DataD _ _ _ _ constructors _) <- reify typeName
+  let newConstructors = map (makeSimpleConstructor . addTestPrefix) $ concatMap getConstructorName constructors
+  return [DataD [] (addTestPrefix typeName) [] Nothing newConstructors []]
+ where
+  addTestPrefix :: Name -> Name
+  addTestPrefix name = mkName $ "Test" ++ nameBase name
+
+  makeSimpleConstructor :: Name -> Con
+  makeSimpleConstructor n = NormalC n []
+
+-- | Generate a declaration with a list of all constructors of a type. For example, if the input type is 'Maybe',
+-- the output will be 'allMaybeConstructors = [Nothing, Just]'. Obviously, this will only work if all constructors
+-- have types that can be unified, like is the case with nullary constructors like the ones generated by 'genNewType'.
+genAllConstructorsList :: Name -> Q [Dec]
+genAllConstructorsList typeName = do
+  constructorList <- getAllConstructors typeName
+  return [ValD (VarP $ mkName $ "all" ++ nameBase typeName ++ "Constructors") (NormalB constructorList) []]
+ where
+  getAllConstructors :: Name -> Q Exp
+  getAllConstructors typeName' = do
+    TyConI (DataD _ _ _ _ constructors _) <- reify typeName'
+    return $ ListE $ map ConE $ concatMap getConstructorName constructors
+
+-- | Obtain the name or names from a constructor
+getConstructorName :: Con -> [Name]
+getConstructorName (NormalC na _) = [na]
+getConstructorName (RecC na _) = [na]
+getConstructorName (InfixC _ na _) = [na]
+getConstructorName (ForallC _ _ con) = getConstructorName con
+getConstructorName (GadtC nas _ _) = nas
+getConstructorName (RecGadtC nas _ _) = nas

cardano-testnet/src/Testnet/TestQueryCmds.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+
+module Testnet.TestQueryCmds
+  ( TestQueryCmds(..)
+  , forallQueryCommands
+  ) where
+
+import           Cardano.CLI.EraBased.Commands.Query (QueryCmds (..))
+
+import           Testnet.TestEnumGenerator (genAllConstructorsList, genTestType)
+
+-- | A datatype with the same constructors as 'QueryCmds', but with a "Test" prefix and no arguments.
+-- The generated type is called 'TestQueryCmds'.
+$(genTestType ''QueryCmds)
+
+-- | A list of all constructors of 'TestQueryCmds', which are nullary.
+-- The generated list is called 'allTestQueryCmdsConstructors'.
+$(genAllConstructorsList ''TestQueryCmds)
+
+-- | Maps a function over all constructors of 'TestQueryCmds' and sequences the results over a monad.
+forallQueryCommands :: Monad m => (TestQueryCmds -> m a) -> m ()
+forallQueryCommands f = mapM_ f allTestQueryCmdsConstructors