cardano-testnet | Add test submitting transaction with supplemental datums using cardano-api

cardano-node/src/Cardano/Node/Protocol/Shelley.hs

@@ -150,7 +150,7 @@ readLeaderCredentialsSingleton
                       shelleyKESFile = Just kesFile
                     } = do
     vrfSKey <-
-      firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsVrfKey) (File vrfFile))
+      firstExceptT FileError (newExceptT $ readFileTextEnvelope (File vrfFile))
 
     (opCert, kesSKey) <- opCertKesKeyCheck (File kesFile) (File opCertFile)
 
@@ -172,9 +172,9 @@ opCertKesKeyCheck
   -> ExceptT PraosLeaderCredentialsError IO (OperationalCertificate, SigningKey KesKey)
 opCertKesKeyCheck kesFile certFile = do
   opCert <-
-    firstExceptT FileError (newExceptT $ readFileTextEnvelope AsOperationalCertificate certFile)
+    firstExceptT FileError (newExceptT $ readFileTextEnvelope certFile)
   kesSKey <-
-    firstExceptT FileError (newExceptT $ readFileTextEnvelope (AsSigningKey AsKesKey) kesFile)
+    firstExceptT FileError (newExceptT $ readFileTextEnvelope kesFile)
   let opCertSpecifiedKesKeyhash = verificationKeyHash $ getHotKey opCert
       suppliedKesKeyHash = verificationKeyHash $ getVerificationKey kesSKey
   -- Specified KES key in operational certificate should match the one
@@ -201,9 +201,9 @@ readLeaderCredentialsBulk ProtocolFilepaths { shelleyBulkCredsFile = mfp } =
      -> ExceptT PraosLeaderCredentialsError IO (ShelleyLeaderCredentials StandardCrypto)
    parseShelleyCredentials ShelleyCredentials { scCert, scVrf, scKes } = do
      mkPraosLeaderCredentials
-       <$> parseEnvelope AsOperationalCertificate scCert
-       <*> parseEnvelope (AsSigningKey AsVrfKey) scVrf
-       <*> parseEnvelope (AsSigningKey AsKesKey) scKes
+       <$> parseEnvelope scCert
+       <*> parseEnvelope scVrf
+       <*> parseEnvelope scKes
 
    readBulkFile
      :: Maybe FilePath
@@ -246,12 +246,11 @@ mkPraosLeaderCredentials
 
 parseEnvelope ::
      HasTextEnvelope a
-  => AsType a
-  -> (TextEnvelope, String)
+  => (TextEnvelope, String)
   -> ExceptT PraosLeaderCredentialsError IO a
-parseEnvelope as (te, loc) =
+parseEnvelope (te, loc) =
   firstExceptT (FileError . Api.FileError loc) . hoistEither $
-    deserialiseFromTextEnvelope as te
+    deserialiseFromTextEnvelope te
 
 
 ------------------------------------------------------------------------------

cardano-testnet/cardano-testnet.cabal

@@ -185,7 +185,8 @@ test-suite cardano-testnet-test
 
   main-is:              cardano-testnet-test.hs
 
-  other-modules:        Cardano.Testnet.Test.Cli.Conway.StakeSnapshot
+  other-modules:        Cardano.Testnet.Test.Api.TxSupplementalDatum
+                        Cardano.Testnet.Test.Cli.Conway.StakeSnapshot
                         Cardano.Testnet.Test.Cli.KesPeriodInfo
                         Cardano.Testnet.Test.Cli.LeadershipSchedule
                         Cardano.Testnet.Test.Cli.Query

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

@@ -36,6 +36,7 @@ module Testnet.Components.Query
   , checkDRepsNumber
   , checkDRepState
   , assertNewEpochState
+  , getProtocolParams
   , getGovActionLifetime
   , getKeyDeposit
   , getDelegationState
@@ -44,7 +45,8 @@ module Testnet.Components.Query
 
 import           Cardano.Api as Api
 import           Cardano.Api.Ledger (Credential, DRepState, EpochInterval (..), KeyRole (DRepRole))
-import           Cardano.Api.Shelley (ShelleyLedgerEra)
+import           Cardano.Api.Shelley (LedgerProtocolParameters (..), ShelleyLedgerEra,
+                   fromShelleyTxIn, fromShelleyTxOut)
 import qualified Cardano.Api.Ledger as L
 
 import           Cardano.Crypto.Hash (hashToStringAsHex)
@@ -558,6 +560,15 @@ assertNewEpochState epochStateView sbe maxWait lens expected = withFrozenCallSta
         Refl <- H.leftFail $ assertErasEqual sbe actualEra
         pure $ newEpochState ^. lens
 
+-- | Return current protocol parameters from the governance state
+getProtocolParams :: (H.MonadAssertion m, MonadTest m, MonadIO m)
+  => EpochStateView
+  -> ConwayEraOnwards era
+  -> m (LedgerProtocolParameters era)
+getProtocolParams epochStateView ceo = conwayEraOnwardsConstraints ceo $ do
+   govState :: ConwayGovState era <- getGovState epochStateView ceo
+   pure . LedgerProtocolParameters $ govState ^. L.cgsCurPParamsL
+
 
 -- | Obtains the @govActionLifetime@ from the protocol parameters.
 -- The @govActionLifetime@ or governance action maximum lifetime in epochs is

cardano-testnet/src/Testnet/Types.hs

@@ -21,6 +21,7 @@ module Testnet.Types
   , testnetSprockets
   , TestnetNode(..)
   , nodeSocketPath
+  , node0ConnectionInfo
   , isTestnetNodeSpo
   , SpoNodeKeys(..)
   , Delegator(..)
@@ -62,7 +63,6 @@ import           Data.List (intercalate)
 import           Data.Maybe
 import           Data.MonoTraversable (Element, MonoFunctor (..))
 import           Data.Text (Text)
-import           Data.Time.Clock (UTCTime)
 import           GHC.Exts (IsString (..))
 import           GHC.Generics (Generic)
 import qualified GHC.IO.Handle as IO
@@ -73,7 +73,9 @@ import qualified System.Process as IO
 
 import           Testnet.Start.Types
 
+import           Hedgehog (MonadTest)
 import qualified Hedgehog as H
+import qualified Hedgehog.Extras as H
 import qualified Hedgehog.Extras.Stock as H
 import           Hedgehog.Extras.Stock.IO.Network.Sprocket (Sprocket (..))
 
@@ -115,7 +117,7 @@ data SKey k
 data TestnetRuntime = TestnetRuntime
   { configurationFile :: !(NodeConfigFile In)
   , shelleyGenesisFile :: !FilePath
-  , testnetMagic :: !Int
+  , testnetMagic :: !Int -- TODO change to Word32
   , testnetNodes :: ![TestnetNode]
   , wallets :: ![PaymentKeyInfo]
   , delegators :: ![Delegator]
@@ -148,6 +150,18 @@ isTestnetNodeSpo = isJust . poolKeys
 nodeSocketPath :: TestnetNode -> SocketPath
 nodeSocketPath = File . H.sprocketSystemName . nodeSprocket
 
+-- | Connection data for the first node in the testnet
+node0ConnectionInfo :: MonadTest m => TestnetRuntime -> m LocalNodeConnectInfo
+node0ConnectionInfo TestnetRuntime{testnetMagic, testnetNodes} = do
+  case testnetNodes of
+    [] -> H.note_ "There are no nodes in the testnet" >> H.failure
+    node0:_ -> do
+        pure LocalNodeConnectInfo
+              { localNodeSocketPath= nodeSocketPath node0
+              , localNodeNetworkId=Testnet (NetworkMagic $ fromIntegral testnetMagic)
+              , localConsensusModeParams=CardanoModeParams $ EpochSlots 21600}
+
+
 data SpoNodeKeys = SpoNodeKeys
   { poolNodeKeysCold :: KeyPair StakePoolKey
   , poolNodeKeysVrf :: KeyPair VrfKey
@@ -187,14 +201,14 @@ getStartTime
   => HasCallStack
   => FilePath
   -> TestnetRuntime
-  -> m UTCTime
+  -> m SystemStart
 getStartTime tempRootPath TestnetRuntime{configurationFile} = withFrozenCallStack $ H.evalEither <=< H.evalIO . runExceptT $ do
   byronGenesisFile <-
     decodeNodeConfiguration configurationFile >>= \case
       NodeProtocolConfigurationCardano NodeByronProtocolConfiguration{npcByronGenesisFile} _ _ _ _ _ ->
         pure $ unGenesisFile npcByronGenesisFile
   let byronGenesisFilePath = tempRootPath </> byronGenesisFile
-  G.gdStartTime . G.configGenesisData <$> decodeGenesisFile byronGenesisFilePath
+  SystemStart . G.gdStartTime . G.configGenesisData <$> decodeGenesisFile byronGenesisFilePath
   where
     decodeNodeConfiguration :: File NodeConfig In -> ExceptT String IO NodeProtocolConfiguration
     decodeNodeConfiguration (File file) = do

cardano-testnet/test/cardano-testnet-test/Cardano/Testnet/Test/Api/TxSupplementalDatum.hs

@@ -0,0 +1,233 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Testnet.Test.Api.TxSupplementalDatum
+  ( hprop_tx_supp_datum
+  )
+where
+
+import           Cardano.Api
+import qualified Cardano.Api.Ledger as L
+import qualified Cardano.Api.Network as Net
+import qualified Cardano.Api.Network as Net.Tx
+import           Cardano.Api.Shelley
+
+import           Cardano.Testnet
+
+import           Prelude
+
+import           Control.Monad
+import           Data.Bifunctor (second)
+import           Data.Default.Class
+import qualified Data.Map.Strict as M
+import           Data.Proxy
+import           Data.Set (Set)
+import           GHC.Exts (IsList (..))
+import           GHC.Stack
+import           Lens.Micro
+
+import           Testnet.Components.Query
+import           Testnet.Property.Util (integrationRetryWorkspace)
+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
+
+hprop_tx_supp_datum :: Property
+hprop_tx_supp_datum = integrationRetryWorkspace 2 "api-tx-supp-dat" $ \tempAbsBasePath' -> H.runWithDefaultWatchdog_ $ do
+  conf@Conf{tempAbsPath} <- mkConf tempAbsBasePath'
+  let tempAbsPath' = unTmpAbsPath tempAbsPath
+
+  let ceo = ConwayEraOnwardsConway
+      beo = convert ceo
+      sbe = convert ceo
+      eraProxy = proxyToAsType Proxy
+      options = def{cardanoNodeEra = AnyShelleyBasedEra sbe}
+
+  tr@TestnetRuntime
+    { configurationFile
+    , testnetNodes = node0 : _
+    , wallets = wallet0@(PaymentKeyInfo _ addrTxt0) : wallet1 : _
+    } <-
+    cardanoTestnetDefault options def conf
+
+  systemStart <- H.noteShowM $ getStartTime tempAbsPath' tr
+  epochStateView <- getEpochStateView configurationFile (nodeSocketPath node0)
+  connectionInfo <- node0ConnectionInfo tr
+  pparams <- getProtocolParams epochStateView ceo
+
+  -- prepare tx inputs and output address
+  H.noteShow_ addrTxt0
+  addr0 <- H.nothingFail $ deserialiseAddress (AsAddressInEra eraProxy) addrTxt0
+
+  let (PaymentKeyInfo _ addrTxt1) = wallet1
+  H.noteShow_ addrTxt1
+  addr1 <- H.nothingFail $ deserialiseAddress (AsAddressInEra eraProxy) addrTxt1
+
+  -- read key witnesses
+  [wit0, wit1] :: [ShelleyWitnessSigningKey] <-
+    forM [wallet0, wallet1] $ \wallet ->
+      H.leftFailM . H.evalIO $
+        readFileTextEnvelopeAnyOf
+          [FromSomeType (proxyToAsType Proxy) WitnessGenesisUTxOKey]
+          (signingKey $ paymentKeyInfoPair wallet)
+
+  -- query node for era history
+  epochInfo <-
+    (H.leftFail <=< H.leftFailM) . H.evalIO $
+      executeLocalStateQueryExpr connectionInfo Net.VolatileTip $
+        fmap toLedgerEpochInfo <$> queryEraHistory
+
+  let scriptData1 = unsafeHashableScriptData $ ScriptDataBytes "CAFEBABE"
+      scriptData2 = unsafeHashableScriptData $ ScriptDataBytes "DEADBEEF"
+      scriptData3 = unsafeHashableScriptData $ ScriptDataBytes "FEEDCOFFEE"
+  -- 4e548d257ab5309e4d029426a502e5609f7b0dbd1ac61f696f8373bd2b147e23
+  H.noteShow_ $ hashScriptDataBytes scriptData1
+  -- 24f56ef6459a29416df2e89d8df944e29591220283f198d39f7873917b8fa7c1
+  H.noteShow_ $ hashScriptDataBytes scriptData2
+  -- 5e47eaf4f0a604fcc939076f74ce7ed59d1503738973522e4d9cb99db703dcb8
+  H.noteShow_ $ hashScriptDataBytes scriptData3
+  let txDatum1 =
+        TxOutDatumHash
+          (convert beo)
+          (hashScriptDataBytes scriptData1)
+      txDatum2 = TxOutDatumInline beo scriptData2
+      txDatum3 = TxOutSupplementalDatum (convert beo) scriptData3
+
+  -- Build a first transaction with txout supplemental data
+  tx1Utxo <- do
+    txIn <- findLargestUtxoForPaymentKey epochStateView sbe wallet0
+
+    -- prepare txout
+    let txOutValue = lovelaceToTxOutValue sbe 100_000_000
+        txOuts =
+          [ TxOut addr1 txOutValue txDatum1 ReferenceScriptNone
+          , TxOut addr1 txOutValue txDatum2 ReferenceScriptNone
+          , TxOut addr1 txOutValue txDatum3 ReferenceScriptNone
+          ]
+
+        -- build a transaction
+        content =
+          defaultTxBodyContent sbe
+            & setTxIns [(txIn, pure $ KeyWitness KeyWitnessForSpending)]
+            & setTxOuts txOuts
+            & setTxProtocolParams (pure $ pure pparams)
+
+    utxo <- UTxO <$> findAllUtxos epochStateView sbe
+
+    BalancedTxBody _ txBody@(ShelleyTxBody _ lbody _ (TxBodyScriptData _ (L.TxDats' datums) _) _ _) _ fee <-
+      H.leftFail $
+        makeTransactionBodyAutoBalance
+          sbe
+          systemStart
+          epochInfo
+          pparams
+          mempty
+          mempty
+          mempty
+          utxo
+          content
+          addr0
+          Nothing -- keys override
+    H.noteShow_ fee
+
+    H.noteShowPretty_ lbody
+
+    let bodyScriptData = fromList . map fromAlonzoData $ M.elems datums :: Set HashableScriptData
+    -- TODO: only inline datum gets included here, but should be all of them
+    -- TODO what's the actual purpose of TxSupplementalDatum - can we remove it?
+    -- TODO adding all datums breaks script integrity hash, might have to manually compute it?
+    -- https://github.com/tweag/cooked-validators/blob/9cb80810d982c9eccd3f7710a996d20f944a95ec/src/Cooked/MockChain/GenerateTx/Body.hs#L127
+    --
+    -- TODO getDataHashBabbageTxOut excludes inline datums - WHY IT HAPPENS ONLY HERE BUT NOT WHEN CALLING CLI?
+
+    -- TODO add scriptData1 when datum can be provided to transaction building
+    -- [ scriptData2
+    --   , scriptData3
+    --   ]
+    --   === bodyScriptData
+
+    let tx = signShelleyTransaction sbe txBody [wit0]
+    txId <- H.noteShow . getTxId $ getTxBody tx
+
+    H.noteShowPretty_ tx
+
+    submitTx sbe connectionInfo tx
+
+    -- wait till transaction gets included in the block
+    _ <- waitForBlocks epochStateView 1
+
+    -- test if it's in UTxO set
+    utxo1 <- findAllUtxos epochStateView sbe
+    txUtxo <- H.noteShowPretty $ M.filterWithKey (\(TxIn txId' _) _ -> txId == txId') utxo1
+    (length txOuts + 1) === length txUtxo
+
+    let chainTxOuts =
+          reverse
+            . drop 1
+            . reverse
+            . map snd
+            . toList
+            $ M.filterWithKey (\(TxIn txId' _) _ -> txId == txId') utxo1
+
+    (toCtxUTxOTxOut <$> txOuts) === chainTxOuts
+
+    pure txUtxo
+
+  do
+    [(txIn1, _)] <- pure $ filter (\(_, TxOut _ _ datum _) -> datum == txDatum1) $ toList tx1Utxo
+    -- H.noteShowPretty_ tx1Utxo
+    [(txIn2, _)] <- pure $ filter (\(_, TxOut _ _ datum _) -> datum == txDatum2) $ toList tx1Utxo
+
+    let scriptData4 = unsafeHashableScriptData $ ScriptDataBytes "C0FFEE"
+        txDatum = TxOutDatumInline beo scriptData4
+        txOutValue = lovelaceToTxOutValue sbe 99_999_500
+        txOut = TxOut addr0 txOutValue txDatum ReferenceScriptNone
+
+    let content =
+          defaultTxBodyContent sbe
+            & setTxIns [(txIn1, pure $ KeyWitness KeyWitnessForSpending)]
+            & setTxInsReference (TxInsReference beo [txIn2])
+            & setTxFee (TxFeeExplicit sbe 500)
+            & setTxOuts [txOut]
+
+    txBody@(ShelleyTxBody _ _ _ (TxBodyScriptData _ (L.TxDats' datums) _) _ _) <-
+      H.leftFail $ createTransactionBody sbe content
+    let bodyScriptData = fromList . map fromAlonzoData $ M.elems datums :: Set HashableScriptData
+    [scriptData1, scriptData2, scriptData3] === bodyScriptData
+
+    let tx = signShelleyTransaction sbe txBody [wit1]
+    -- H.noteShowPretty_ tx
+    txId <- H.noteShow . getTxId $ getTxBody tx
+
+    submitTx sbe connectionInfo tx
+
+    -- wait till transaction gets included in the block
+    _ <- waitForBlocks epochStateView 1
+
+    -- test if it's in UTxO set
+    utxo1 <- findAllUtxos epochStateView sbe
+    let txUtxo = M.filterWithKey (\(TxIn txId' _) _ -> txId == txId') utxo1
+    [toCtxUTxOTxOut txOut] === M.elems txUtxo
+
+  H.failure
+
+submitTx
+  :: MonadTest m
+  => MonadIO m
+  => HasCallStack
+  => ShelleyBasedEra era
+  -> LocalNodeConnectInfo
+  -> Tx era
+  -> m ()
+submitTx sbe connectionInfo tx =
+  withFrozenCallStack $
+    H.evalIO (submitTxToNodeLocal connectionInfo (TxInMode sbe tx)) >>= \case
+      Net.Tx.SubmitFail reason -> H.noteShowPretty_ reason >> H.failure
+      Net.Tx.SubmitSuccess -> H.success