Wait for UTxO from faucet to appear before posting

hydra-cardano-api/src/Cardano/Api/UTxO.hs

@@ -21,7 +21,7 @@ type Era = BabbageEra
 type UTxO = UTxO' (TxOut CtxUTxO Era)
 
 -- | Newtype with phantom types mostly required to work around the poor interface
--- of 'Ledger.UTXO'and provide 'Monoid' and 'Foldable' instances to make utxo
+-- of 'Ledger.UTXO' and provide 'Monoid' and 'Foldable' instances to make utxo
 -- manipulation bareable.
 newtype UTxO' out = UTxO
   { toMap :: Map TxIn out
@@ -38,6 +38,10 @@ newtype UTxO' out = UTxO
 instance Traversable UTxO' where
   traverse fn (UTxO m) = UTxO <$> traverse fn m
 
+-- | Checks some `UTxO` is contained in some other `UTxO`.
+contains :: Eq out => UTxO' out -> UTxO' out -> Bool
+contains (UTxO m) (UTxO m') = m' `Map.isSubmapOf` m
+
 -- | Create a 'UTxO' from a list of 'TxIn' and 'out' pairs.
 fromPairs :: [(TxIn, out)] -> UTxO' out
 fromPairs = UTxO . Map.fromList

hydra-cluster/src/CardanoClient.hs

@@ -88,7 +88,6 @@ sign signingKey body =
     [makeShelleyKeyWitness body (WitnessPaymentKey signingKey)]
     body
 
--- TODO: This should return a 'UTxO' (from Hydra.Ledger.Cardano)
 waitForPayment ::
   NetworkId ->
   FilePath ->

hydra-cluster/test/Test/DirectChainSpec.hs

@@ -7,6 +7,7 @@ module Test.DirectChainSpec where
 import Hydra.Prelude
 import Test.Hydra.Prelude
 
+import Cardano.Api.UTxO (contains)
 import CardanoClient (
   QueryPoint (QueryTip),
   buildAddress,
@@ -20,6 +21,7 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as B8
 import Hydra.Cardano.Api (
   ChainPoint (..),
+  UTxO,
   lovelaceToValue,
   txOutValue,
   unsafeDeserialiseFromRawBytesBase16,
@@ -102,14 +104,15 @@ spec = around showLogsOnFailure $ do
         withIOManager $ \iocp -> do
           seedFromFaucet_ node aliceCardanoVk 100_000_000 Fuel
           hydraScriptsTxId <- publishHydraScriptsAs node Faucet
-          withDirectChain (contramap (FromDirectChain "alice") tracer) defaultNetworkId iocp nodeSocket aliceKeys alice cardanoKeys Nothing hydraScriptsTxId (putMVar alicesCallback) $ \Chain{postTx} -> do
+          withDirectChain (contramap (FromDirectChain "alice") tracer) defaultNetworkId iocp nodeSocket aliceKeys alice cardanoKeys Nothing hydraScriptsTxId (putMVar alicesCallback) $ \Chain{postTx, getUTxO} -> do
             withDirectChain nullTracer defaultNetworkId iocp nodeSocket bobKeys bob cardanoKeys Nothing hydraScriptsTxId (putMVar bobsCallback) $ \_ -> do
               postTx $ InitTx $ HeadParameters cperiod [alice, bob, carol]
               alicesCallback `observesInTime` OnInitTx cperiod [alice, bob, carol]
               bobsCallback `observesInTime` OnInitTx cperiod [alice, bob, carol]
 
               let aliceCommitment = 66_000_000
               aliceUTxO <- seedFromFaucet node aliceCardanoVk aliceCommitment Normal
+              waitUntilHasUTxO getUTxO aliceUTxO
               postTx $ CommitTx alice aliceUTxO
 
               alicesCallback `observesInTime` OnCommitTx alice aliceUTxO
@@ -156,7 +159,7 @@ spec = around showLogsOnFailure $ do
         withIOManager $ \iocp -> do
           seedFromFaucet_ node aliceCardanoVk 100_000_000 Fuel
           hydraScriptsTxId <- publishHydraScriptsAs node Faucet
-          withDirectChain (contramap (FromDirectChain "alice") tracer) defaultNetworkId iocp nodeSocket aliceKeys alice cardanoKeys Nothing hydraScriptsTxId (putMVar alicesCallback) $ \Chain{postTx} -> do
+          withDirectChain (contramap (FromDirectChain "alice") tracer) defaultNetworkId iocp nodeSocket aliceKeys alice cardanoKeys Nothing hydraScriptsTxId (putMVar alicesCallback) $ \Chain{postTx, getUTxO} -> do
             postTx $ InitTx $ HeadParameters cperiod [alice]
             alicesCallback `observesInTime` OnInitTx cperiod [alice]
 
@@ -172,6 +175,7 @@ spec = around showLogsOnFailure $ do
                 _ -> False
 
             aliceUTxO <- seedFromFaucet node aliceCardanoVk 1_000_000 Normal
+            waitUntilHasUTxO getUTxO aliceUTxO
             postTx $ CommitTx alice aliceUTxO
             alicesCallback `observesInTime` OnCommitTx alice aliceUTxO
 
@@ -200,11 +204,12 @@ spec = around showLogsOnFailure $ do
         withIOManager $ \iocp -> do
           seedFromFaucet_ node aliceCardanoVk 100_000_000 Fuel
           hydraScriptsTxId <- publishHydraScriptsAs node Faucet
-          withDirectChain (contramap (FromDirectChain "alice") tracer) defaultNetworkId iocp nodeSocket aliceKeys alice cardanoKeys Nothing hydraScriptsTxId (putMVar alicesCallback) $ \Chain{postTx} -> do
+          withDirectChain (contramap (FromDirectChain "alice") tracer) defaultNetworkId iocp nodeSocket aliceKeys alice cardanoKeys Nothing hydraScriptsTxId (putMVar alicesCallback) $ \Chain{postTx, getUTxO} -> do
             postTx $ InitTx $ HeadParameters cperiod [alice]
             alicesCallback `observesInTime` OnInitTx cperiod [alice]
 
             someUTxO <- seedFromFaucet node aliceCardanoVk 1_000_000 Normal
+            waitUntilHasUTxO getUTxO someUTxO
             postTx $ CommitTx alice someUTxO
             alicesCallback `observesInTime` OnCommitTx alice someUTxO
 
@@ -304,6 +309,15 @@ spec = around showLogsOnFailure $ do
                     (removeTrailingNewline (encodeUtf8 hydraScriptsTxIdStr))
         failAfter 5 $ void $ queryScriptRegistry networkId nodeSocket hydraScriptsTxId
 
+waitUntilHasUTxO :: IO UTxO -> UTxO -> IO ()
+waitUntilHasUTxO getUTxO utxo = go
+ where
+  go = do
+    knownUTxO <- getUTxO
+    unless (knownUTxO `contains` utxo) $ do
+      threadDelay 1
+      go
+
 data TestClusterLog
   = FromNode NodeLog
   | FromDirectChain Text DirectChainLog

hydra-node/src/Hydra/Chain.hs

@@ -125,7 +125,7 @@ instance IsTx tx => Arbitrary (PostTxError tx) where
   arbitrary = genericArbitrary
 
 -- | Handle to interface with the main chain network
-newtype Chain tx m = Chain
+data Chain tx m = Chain
   { -- | Construct and send a transaction to the main chain corresponding to the
     -- given 'OnChainTx' event. This function is not expected to block, so it is
     -- only responsible for submitting, but it should validate the created
@@ -134,6 +134,12 @@ newtype Chain tx m = Chain
     --
     -- Does at least throw 'PostTxError'.
     postTx :: MonadThrow m => PostChainTx tx -> m ()
+  , -- | Query the internal state of the `Chain` component for the `UTxO tx` it knows.
+    --
+    -- The main purpose of this function is to provide a way for `Chain` clients
+    -- to observe (part of) the internal state of the component in order to be
+    -- able to take decisions on whether or not it's safe to post a transaction.
+    getUTxO :: m (UTxOType tx)
   }
 
 data ChainEvent tx

hydra-node/src/Hydra/Chain/Direct/Handlers.hs

@@ -11,12 +11,14 @@ module Hydra.Chain.Direct.Handlers where
 
 import Hydra.Prelude
 
+import Cardano.Api.UTxO (fromPairs)
 import Cardano.Ledger.Babbage.Tx (ValidatedTx)
 import Cardano.Ledger.Crypto (StandardCrypto)
 import Cardano.Ledger.Era (SupportsSegWit (fromTxSeq))
 import qualified Cardano.Ledger.Shelley.API as Ledger
 import Control.Monad (foldM)
 import Control.Monad.Class.MonadSTM (readTVarIO, throwSTM, writeTVar)
+import qualified Data.Map as Map
 import Data.Sequence.Strict (StrictSeq)
 import Hydra.Cardano.Api (
   ChainPoint (..),
@@ -26,6 +28,7 @@ import Hydra.Cardano.Api (
   fromConsensusPointHF,
   fromLedgerTx,
   fromLedgerTxIn,
+  fromLedgerTxOut,
   fromLedgerUTxO,
   toLedgerTx,
   toLedgerUTxO,
@@ -91,7 +94,7 @@ mkChain ::
   TVar m ChainStateAt ->
   SubmitTx m ->
   Chain Tx m
-mkChain tracer queryTimeHandle wallet headState submitTx =
+mkChain tracer queryTimeHandle wallet@TinyWallet{getUTxO} headState submitTx =
   Chain
     { postTx = \tx -> do
         traceWith tracer $ ToPost{toPost = tx}
@@ -112,7 +115,10 @@ mkChain tracer queryTimeHandle wallet headState submitTx =
                 >>= finalizeTx tx wallet headState . toLedgerTx
             )
         submitTx vtx
+    , getUTxO = fromPairs . fmap toLedger . Map.assocs <$> atomically getUTxO
     }
+ where
+  toLedger (txIn, txOut) = (fromLedgerTxIn txIn, fromLedgerTxOut txOut)
 
 -- | Balance and sign the given partial transaction.
 finalizeTx ::