Merge pull request #626 from input-output-hk/ensemble/include-direct-…

…chain-component-in-model-based-tests Include direct chain component in model based tests
input-output-hk · Dec 2, 2022 · 88e1804 · 88e1804
2 parents aff3f3b + 7612d4a
commit 88e1804
Show file tree

Hide file tree

Showing 12 changed files with 522 additions and 199 deletions.
diff --git a/hydra-node/exe/hydra-node/Main.hs b/hydra-node/exe/hydra-node/Main.hs
@@ -6,13 +6,11 @@ import Hydra.Prelude
 
 import Hydra.API.Server (withAPIServer)
 import Hydra.Cardano.Api (serialiseToRawBytesHex)
-import Hydra.Chain (ChainCallback, ChainEvent (..))
 import Hydra.Chain.Direct (initialChainState, loadChainContext, withDirectChain)
 import Hydra.Chain.Direct.ScriptRegistry (publishHydraScripts)
 import Hydra.Chain.Direct.State (ChainStateAt (..))
 import Hydra.Chain.Direct.Util (readKeyPair)
 import Hydra.HeadLogic (Environment (..), Event (..), HeadState (..), defaultTTL, getChainState)
-import Hydra.Ledger.Cardano (Tx)
 import qualified Hydra.Ledger.Cardano as Ledger
 import Hydra.Ledger.Cardano.Configuration (
   newGlobals,
@@ -30,7 +28,7 @@ import Hydra.Network.Ouroboros (withOuroborosNetwork)
 import Hydra.Node (
   EventQueue (..),
   HydraNode (..),
-  NodeState (..),
+  chainCallback,
   createEventQueue,
   createNodeState,
   initEnvironment,
@@ -90,24 +88,6 @@ main = do
                 runHydraNode (contramap Node tracer) $
                   HydraNode{eq, hn, nodeState, oc = chain, server, ledger, env, persistence}
 
-  chainCallback :: NodeState Tx IO -> EventQueue IO (Event Tx) -> ChainCallback Tx IO
-  chainCallback NodeState{modifyHeadState} eq cont = do
-    -- Provide chain state to continuation and update it when we get a newState
-    -- NOTE: Although we do handle the chain state explictly in the 'HeadLogic',
-    -- this is required as multiple transactions may be observed and the chain
-    -- state shall accumulate the state changes coming with those observations.
-    mEvent <- atomically . modifyHeadState $ \hs ->
-      case cont $ getChainState hs of
-        Nothing ->
-          (Nothing, hs)
-        Just ev@Observation{newChainState} ->
-          (Just ev, hs{chainState = newChainState})
-        Just ev ->
-          (Just ev, hs)
-    case mEvent of
-      Nothing -> pure ()
-      Just chainEvent -> putEvent eq $ OnChainEvent{chainEvent}
-
   publish opts = do
     (_, sk) <- readKeyPair (publishSigningKey opts)
     let PublishOptions{publishNetworkId = networkId, publishNodeSocket = nodeSocket} = opts

diff --git a/hydra-node/hydra-node.cabal b/hydra-node/hydra-node.cabal
@@ -283,6 +283,8 @@ test-suite tests
     Hydra.Logging.MonitoringSpec
     Hydra.LoggingSpec
     Hydra.Model
+    Hydra.Model.MockChain
+    Hydra.Model.Payment
     Hydra.ModelSpec
     Hydra.Network.HeartbeatSpec
     Hydra.NetworkSpec
@@ -362,5 +364,5 @@ test-suite tests
     , websockets
     , yaml
 
-  build-tool-depends: hspec-discover:hspec-discover -any
+  build-tool-depends: hspec-discover:hspec-discover
   ghc-options:        -threaded -rtsopts
diff --git a/hydra-node/src/Hydra/Chain/Direct/Handlers.hs b/hydra-node/src/Hydra/Chain/Direct/Handlers.hs
@@ -27,7 +27,6 @@ import Hydra.Cardano.Api (
   chainPointToSlotNo,
   fromConsensusPointInMode,
   fromLedgerTx,
-  fromLedgerTxIn,
   getTxBody,
   getTxId,
   toLedgerTx,
@@ -62,7 +61,6 @@ import Hydra.Chain.Direct.Wallet (
   ErrCoverFee (..),
   TinyWallet (..),
   TinyWalletLog,
-  getFuelUTxO,
  )
 import Hydra.Logging (Tracer, traceWith)
 import Ouroboros.Consensus.Cardano.Block (HardForkBlock (BlockBabbage))
@@ -249,8 +247,8 @@ fromPostChainTx timeHandle wallet ctx cst@ChainStateAt{chainState} tx = do
   pointInTime <- throwLeft currentPointInTime
   case (tx, chainState) of
     (InitTx params, Idle) ->
-      getFuelUTxO wallet >>= \case
-        Just (fromLedgerTxIn -> seedInput, _) -> do
+      getSeedInput wallet >>= \case
+        Just seedInput ->
           pure $ initialize ctx params seedInput
         Nothing ->
           throwIO (NoSeedInput @Tx)

diff --git a/hydra-node/src/Hydra/Chain/Direct/Wallet.hs b/hydra-node/src/Hydra/Chain/Direct/Wallet.hs
@@ -65,6 +65,7 @@ import Hydra.Cardano.Api (
   verificationKeyHash,
  )
 import qualified Hydra.Cardano.Api as Api
+import Hydra.Cardano.Api.TxIn (fromLedgerTxIn)
 import Hydra.Chain.CardanoClient (QueryPoint (..))
 import Hydra.Chain.Direct.Util (Block, markerDatum)
 import qualified Hydra.Chain.Direct.Util as Util
@@ -88,6 +89,10 @@ type TxOut = Ledger.TxOut LedgerEra
 data TinyWallet m = TinyWallet
   { -- | Return all known UTxO addressed to this wallet.
     getUTxO :: STM m (Map TxIn TxOut)
+  , -- | Returns the /seed input/
+    -- This is the special input needed by `Direct` chain component to initialise
+    -- a head
+    getSeedInput :: STM m (Maybe Api.TxIn)
   , sign :: ValidatedTx LedgerEra -> ValidatedTx LedgerEra
   , coverFee ::
       Map TxIn TxOut ->
@@ -112,11 +117,6 @@ data WalletInfoOnChain = WalletInfoOnChain
 
 type ChainQuery m = QueryPoint -> Api.Address ShelleyAddr -> m WalletInfoOnChain
 
--- | Get a single, marked as "fuel" UTxO.
-getFuelUTxO :: MonadSTM m => TinyWallet m -> STM m (Maybe (TxIn, TxOut))
-getFuelUTxO TinyWallet{getUTxO} =
-  findFuelUTxO <$> getUTxO
-
 watchUTxOUntil :: (Map TxIn TxOut -> Bool) -> TinyWallet IO -> IO (Map TxIn TxOut)
 watchUTxOUntil predicate TinyWallet{getUTxO} = atomically $ do
   u <- getUTxO
@@ -137,9 +137,11 @@ newTinyWallet ::
   IO (TinyWallet IO)
 newTinyWallet tracer networkId (vk, sk) queryWalletInfo queryEpochInfo = do
   walletInfoVar <- newTVarIO =<< initialize
+  let getUTxO = readTVar walletInfoVar <&> walletUTxO
   pure
     TinyWallet
-      { getUTxO = readTVar walletInfoVar <&> walletUTxO
+      { getUTxO
+      , getSeedInput = (fmap (fromLedgerTxIn . fst) . findFuelUTxO) <$> getUTxO
       , sign = Util.signWith sk
       , coverFee = \lookupUTxO partialTx -> do
           -- XXX: We should query pparams here. If not, we likely will have

diff --git a/hydra-node/src/Hydra/Node.hs b/hydra-node/src/Hydra/Node.hs
@@ -25,7 +25,10 @@ import Hydra.Prelude
 
 import Control.Monad.Class.MonadAsync (async)
 import Control.Monad.Class.MonadSTM (
+  MonadLabelledSTM,
   isEmptyTQueue,
+  labelTQueueIO,
+  labelTVarIO,
   modifyTVar',
   newTQueue,
   newTVarIO,
@@ -35,7 +38,7 @@ import Control.Monad.Class.MonadSTM (
  )
 import Hydra.API.Server (Server, sendOutput)
 import Hydra.Cardano.Api (AsType (AsSigningKey, AsVerificationKey))
-import Hydra.Chain (Chain (..), ChainStateType, IsChainState, PostTxError)
+import Hydra.Chain (Chain (..), ChainCallback, ChainEvent (..), ChainStateType, IsChainState, PostTxError)
 import Hydra.Chain.Direct.Util (readFileTextEnvelopeThrow)
 import Hydra.Crypto (AsType (AsHydraKey))
 import Hydra.HeadLogic (
@@ -46,6 +49,7 @@ import Hydra.HeadLogic (
   Outcome (..),
   defaultTTL,
   emitSnapshot,
+  getChainState,
  )
 import qualified Hydra.HeadLogic as Logic
 import Hydra.Ledger (IsTx, Ledger)
@@ -202,10 +206,18 @@ data EventQueue m e = EventQueue
   , isEmpty :: m Bool
   }
 
-createEventQueue :: (MonadSTM m, MonadDelay m, MonadAsync m) => m (EventQueue m e)
+createEventQueue ::
+  ( MonadSTM m
+  , MonadDelay m
+  , MonadAsync m
+  , MonadLabelledSTM m
+  ) =>
+  m (EventQueue m e)
 createEventQueue = do
   numThreads <- newTVarIO (0 :: Integer)
+  labelTVarIO numThreads "num-threads"
   q <- atomically newTQueue
+  labelTQueueIO q "event-queue"
   pure
     EventQueue
       { putEvent =
@@ -235,11 +247,34 @@ data NodeState tx m = NodeState
   }
 
 -- | Initialize a new 'NodeState'.
-createNodeState :: MonadSTM m => HeadState tx -> m (NodeState tx m)
+createNodeState :: (MonadSTM m, MonadLabelledSTM m) => HeadState tx -> m (NodeState tx m)
 createNodeState initialState = do
   tv <- newTVarIO initialState
+  labelTVarIO tv "node-state"
   pure
     NodeState
       { modifyHeadState = stateTVar tv
       , queryHeadState = readTVar tv
       }
+
+chainCallback ::
+  MonadSTM m =>
+  NodeState tx m ->
+  EventQueue m (Event tx) ->
+  ChainCallback tx m
+chainCallback NodeState{modifyHeadState} eq cont = do
+  -- Provide chain state to continuation and update it when we get a newState
+  -- NOTE: Although we do handle the chain state explictly in the 'HeadLogic',
+  -- this is required as multiple transactions may be observed and the chain
+  -- state shall accumulate the state changes coming with those observations.
+  mEvent <- atomically . modifyHeadState $ \hs ->
+    case cont $ getChainState hs of
+      Nothing ->
+        (Nothing, hs)
+      Just ev@Observation{newChainState} ->
+        (Just ev, hs{chainState = newChainState})
+      Just ev ->
+        (Just ev, hs)
+  case mEvent of
+    Nothing -> pure ()
+    Just chainEvent -> putEvent eq $ OnChainEvent{chainEvent}
diff --git a/hydra-node/test/Hydra/BehaviorSpec.hs b/hydra-node/test/Hydra/BehaviorSpec.hs
@@ -8,6 +8,8 @@ import Test.Hydra.Prelude hiding (shouldBe, shouldNotBe, shouldReturn, shouldSat
 
 import Control.Monad.Class.MonadAsync (Async, MonadAsync (async), cancel, forConcurrently_)
 import Control.Monad.Class.MonadSTM (
+  MonadLabelledSTM,
+  labelTVarIO,
   modifyTVar,
   modifyTVar',
   newTQueue,
@@ -19,6 +21,7 @@ import Control.Monad.Class.MonadSTM (
  )
 import Control.Monad.Class.MonadTimer (timeout)
 import Control.Monad.IOSim (IOSim, runSimTrace, selectTraceEventsDynamic)
+import qualified Data.List as List
 import GHC.Records (getField)
 import Hydra.API.ClientInput
 import Hydra.API.Server (Server (..))
@@ -49,10 +52,12 @@ import Hydra.HeadLogic (
 import Hydra.Ledger (Ledger, ValidationError (ValidationError))
 import Hydra.Ledger.Simple (SimpleChainState (..), SimpleTx (..), aValidTx, simpleLedger, utxoRef, utxoRefs)
 import Hydra.Network (Network (..))
+import Hydra.Network.Message (Message)
 import Hydra.Node (
   EventQueue (putEvent),
   HydraNode (..),
   HydraNodeLog (..),
+  NodeState,
   createEventQueue,
   createNodeState,
   runHydraNode,
@@ -566,7 +571,7 @@ simulatedChainAndNetwork initialChainState = do
           pure $
             node
               { oc = Chain{postTx = \_cs -> postTx nodes history chainStateVar}
-              , hn = Network{broadcast = broadcast node nodes}
+              , hn = createMockNetwork node nodes
               }
       , tickThread
       , rollbackAndForward = rollbackAndForward nodes history chainStateVar
@@ -616,13 +621,18 @@ simulatedChainAndNetwork initialChainState = do
     forM_ toReplay $ \ev ->
       recordAndYieldEvent nodes history ev
 
-  broadcast node nodes msg = do
+handleChainEvent :: HydraNode tx m -> ChainEvent tx -> m ()
+handleChainEvent HydraNode{eq} = putEvent eq . OnChainEvent
+
+createMockNetwork :: MonadSTM m => HydraNode tx m -> TVar m [HydraNode tx m] -> Network m (Message tx)
+createMockNetwork node nodes =
+  Network{broadcast}
+ where
+  broadcast msg = do
     allNodes <- readTVarIO nodes
     let otherNodes = filter (\n -> getNodeId n /= getNodeId node) allNodes
     mapM_ (`handleMessage` msg) otherNodes
 
-  handleChainEvent HydraNode{eq} = putEvent eq . OnChainEvent
-
   handleMessage HydraNode{eq} = putEvent eq . NetworkEvent defaultTTL
 
   getNodeId = getField @"party" . env
@@ -674,8 +684,8 @@ withHydraNode ::
 withHydraNode signingKey otherParties connectToChain action = do
   outputs <- atomically newTQueue
   outputHistory <- newTVarIO mempty
-  let chainState = SimpleChainState{slot = ChainSlot 0}
-  node <- createHydraNode simpleLedger chainState signingKey otherParties outputs outputHistory connectToChain
+  nodeState <- createNodeState $ IdleState{chainState = SimpleChainState{slot = ChainSlot 0}}
+  node <- createHydraNode simpleLedger nodeState signingKey otherParties outputs outputHistory connectToChain
   withAsync (runHydraNode traceInIOSim node) $ \_ ->
     action (createTestHydraNode outputs outputHistory node)
 
@@ -694,19 +704,19 @@ createTestHydraNode outputs outputHistory HydraNode{eq} =
     }
 
 createHydraNode ::
-  (MonadDelay m, MonadAsync m) =>
+  (MonadDelay m, MonadAsync m, MonadLabelledSTM m) =>
   Ledger tx ->
-  ChainStateType tx ->
+  NodeState tx m ->
   SigningKey HydraKey ->
   [Party] ->
   TQueue m (ServerOutput tx) ->
   TVar m [ServerOutput tx] ->
   ConnectToChain tx m ->
   m (HydraNode tx m)
-createHydraNode ledger chainState signingKey otherParties outputs outputHistory connectToChain = do
+createHydraNode ledger nodeState signingKey otherParties outputs outputHistory connectToChain = do
   eq <- createEventQueue
-  nodeState <- createNodeState $ IdleState{chainState}
   persistenceVar <- newTVarIO Nothing
+  labelTVarIO persistenceVar ("persistence-" <> shortLabel signingKey)
   chainComponent connectToChain $
     HydraNode
       { eq
@@ -761,3 +771,8 @@ assertHeadIsClosedWith expectedSnapshotNumber = \case
   HeadIsClosed{snapshotNumber} -> do
     snapshotNumber `shouldBe` expectedSnapshotNumber
   _ -> failure "expected HeadIsClosed"
+
+-- | Provide a quick and dirty to way to label stuff from a signing key
+shortLabel :: SigningKey HydraKey -> String
+shortLabel s =
+  take 8 $ drop 1 $ List.head $ drop 2 $ List.words $ show s