submitTx test

Author: carbolymer

cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Query.hs

@@ -177,6 +177,6 @@ hprop_rpc_query_pparams = integrationRetryWorkspace 2 "rpc-query-pparams" $ \tem
   -- Test readUtxos response
   --------------------------
 
-  H.noteShowPretty $ utxos
-  H.noteShowPretty $ utxosResponse
+  _ <- H.noteShowPretty $ utxos
+  _ <- H.noteShowPretty $ utxosResponse
   H.failure

cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Rpc/Transaction.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Cardano.Testnet.Test.Rpc.Transaction
   ( hprop_rpc_transaction
@@ -13,41 +15,54 @@ where
 
 import           Cardano.Api
 import qualified Cardano.Api.Ledger as L
+import qualified Cardano.Api.Parser.Text as P
 
 import           Cardano.CLI.Type.Output (QueryTipLocalStateOutput (..))
 import qualified Cardano.Ledger.Api as L
 import qualified Cardano.Ledger.Binary.Version as L
 import qualified Cardano.Ledger.Conway.Core as L
 import qualified Cardano.Ledger.Conway.PParams as L
 import qualified Cardano.Ledger.Plutus as L
+import           Cardano.Rpc.Client (Proto)
 import qualified Cardano.Rpc.Client as Rpc
 import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Query as UtxoRpc
+import qualified Cardano.Rpc.Proto.Api.UtxoRpc.Submit as UtxoRpc
 import           Cardano.Rpc.Server.Internal.UtxoRpc.Query ()
+import           Cardano.Rpc.Server.Internal.UtxoRpc.Type
 import           Cardano.Testnet
 
 import           Prelude
 
+import           Control.Monad
+import           Control.Monad.Fix
 import qualified Data.ByteString.Short as SBS
 import           Data.Default.Class
 import qualified Data.Map.Strict as M
+import           Data.Maybe
+import qualified Data.Text.Encoding as T
+import           GHC.Stack
 import           Lens.Micro
 
 import           Testnet.Components.Query
 import           Testnet.Process.Run
 import           Testnet.Property.Util (integrationRetryWorkspace)
 import           Testnet.Start.Types
+import           Testnet.Types
 
 import           Hedgehog
 import qualified Hedgehog as H
 import qualified Hedgehog.Extras.Test.Base as H
 import qualified Hedgehog.Extras.Test.TestWatchdog as H
 
+import           RIO (threadDelay)
+
 hprop_rpc_transaction :: Property
 hprop_rpc_transaction = integrationRetryWorkspace 2 "rpc-tx" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do
   conf@Conf{tempAbsPath} <- mkConf tempAbsBasePath'
   let tempAbsPath' = unTmpAbsPath tempAbsPath
 
-  let ceo = ConwayEraOnwardsConway
+  let (ceo, eraProxy) =
+        (conwayBasedEra, asType) :: era ~ ConwayEra => (ConwayEraOnwards era, AsType era)
       sbe = convert ceo
       eraName = eraToString sbe
       options = def{cardanoNodeEra = AnyShelleyBasedEra sbe, cardanoEnableRpc = True}
@@ -56,29 +71,106 @@ hprop_rpc_transaction = integrationRetryWorkspace 2 "rpc-tx" $ \tempAbsBasePath'
     { testnetMagic
     , configurationFile
     , testnetNodes = node0@TestnetNode{nodeSprocket} : _
+    , wallets = wallet0@(PaymentKeyInfo _ addrTxt0) : (PaymentKeyInfo _ addrTxt1) : _
     } <-
     createAndRunTestnet options def conf
 
   execConfig <- mkExecConfig tempAbsPath' nodeSprocket testnetMagic
   epochStateView <- getEpochStateView configurationFile (nodeSocketPath node0)
-  pparams <- unLedgerProtocolParameters <$> getProtocolParams epochStateView ceo
-  -- H.noteShowPretty_ pparams
-  utxos <- findAllUtxos epochStateView sbe
-  H.noteShowPretty_ utxos
+
   rpcSocket <- H.note . unFile $ nodeRpcSocketPath node0
 
+  -- prepare tx inputs and output address
+  H.noteShow_ addrTxt0
+  addr0 <- H.nothingFail $ deserialiseAddress (AsAddressInEra eraProxy) addrTxt0
+
+  H.noteShow_ addrTxt1
+  addr1 <- H.nothingFail $ deserialiseAddress (AsAddressInEra eraProxy) addrTxt1
+
+  -- read key witnesses
+  wit0 :: ShelleyWitnessSigningKey <-
+    H.leftFailM . H.evalIO $
+      readFileTextEnvelopeAnyOf
+        [FromSomeType asType WitnessGenesisUTxOKey]
+        (signingKey $ paymentKeyInfoPair wallet0)
+
   --------------
   -- RPC queries
   --------------
   let rpcServer = Rpc.ServerUnix rpcSocket
   (pparamsResponse, utxosResponse) <- H.noteShowM . H.evalIO . Rpc.withConnection def rpcServer $ \conn -> do
     pparams' <- do
-      let req = Rpc.defMessage
+      let req = def
       Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readParams")) req
 
     utxos' <- do
-      let req = Rpc.defMessage
+      let req = def & #addresses . #items .~ [T.encodeUtf8 addrTxt0]
       Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readUtxos")) req
     pure (pparams', utxos')
 
-  H.failure
+  pparams <- H.leftFail $ utxoRpcPParamsToProtocolParams (convert ceo) $ pparamsResponse ^. #values . #cardano
+
+  txOut0 : _ <- H.noteShow $ utxosResponse ^. #items
+  txIn0 <- txoRefToTxIn $ txOut0 ^. #txoRef
+
+  let outputCoin = txOut0 ^. #cardano . #coin . to fromIntegral
+      amount = 200_000_000
+      fee = 500
+      change = outputCoin - amount - fee
+      txOut = TxOut addr1 (lovelaceToTxOutValue sbe $ L.Coin amount) TxOutDatumNone ReferenceScriptNone
+      changeTxOut = TxOut addr0 (lovelaceToTxOutValue sbe $ L.Coin change) TxOutDatumNone ReferenceScriptNone
+      content =
+        defaultTxBodyContent sbe
+          & setTxIns [(txIn0, pure $ KeyWitness KeyWitnessForSpending)]
+          & setTxFee (TxFeeExplicit sbe 500)
+          & setTxOuts [txOut, changeTxOut]
+          & setTxProtocolParams (pure . pure $ LedgerProtocolParameters pparams)
+
+  txBody <- H.leftFail $ createTransactionBody sbe content
+
+  let signedTx = signShelleyTransaction sbe txBody [wit0]
+  txId <- H.noteShow . getTxId $ getTxBody signedTx
+
+  H.noteShowPretty_ utxosResponse
+
+  (utxos, submitResponse) <- H.noteShowM . H.evalIO . Rpc.withConnection def rpcServer $ \conn -> do
+    submitResponse <-
+      Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.SubmitService "submitTx")) $
+        def & #tx .~ [def & #raw .~ serialiseToCBOR signedTx]
+
+    fix $ \loop -> do
+      resp <- Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readParams")) def
+
+      let previousBlockNo = pparamsResponse ^. #ledgerTip . #height
+          currentBlockNo = resp ^. #ledgerTip . #height
+      -- wait for 2 blocks
+      when (previousBlockNo + 1 >= currentBlockNo) $ do
+        threadDelay 500_000
+        loop
+
+    utxos <-
+      Rpc.nonStreaming conn (Rpc.rpc @(Rpc.Protobuf UtxoRpc.QueryService "readUtxos")) $
+        def & #addresses . #items .~ [T.encodeUtf8 addrTxt1]
+    pure (utxos, submitResponse)
+
+  submittedTxIds <- forM (submitResponse ^. #results) $ \res -> do
+            let mErr = res ^. #maybe'errorMessage
+                mTxId = res ^. #maybe'ref
+            case (mErr, mTxId) of
+              (Just err, Nothing) -> H.noteShow_ err >> H.failure
+              (Nothing, Just txId) ->
+                H.leftFail $ deserialiseFromRawBytes AsTxId txId
+              _ -> do
+                H.note_ $ "Protocol error: " <> show res
+                H.failure
+
+  [txId] === submittedTxIds
+
+  2 === length (utxos ^. #items)
+  let utxo0:_ = utxos ^. #items
+  fromIntegral amount === utxo0 ^. #cardano . #coin
+
+txoRefToTxIn :: (HasCallStack, MonadTest m) => Proto UtxoRpc.TxoRef -> m TxIn
+txoRefToTxIn r = withFrozenCallStack $ do
+  txId' <- H.leftFail $ deserialiseFromRawBytes AsTxId $ r ^. #hash
+  pure $ TxIn txId' (TxIx . fromIntegral $ r ^. #index)