From a6efcc34e31b4d1f6630c8efc7a1233471fbacf5 Mon Sep 17 00:00:00 2001 From: Sebastian Nagel Date: Mon, 7 Jun 2021 11:48:45 +0200 Subject: [PATCH] Use io-sim-classes to replace IO with IOSim later Also, 'expectationFailure' got replaced by 'error' (for now). Maybe use 'MonadThrow' instead? --- hydra-node/hydra-node.cabal | 1 - hydra-node/src/Hydra/Logging.hs | 10 ++-- hydra-node/src/Hydra/Node.hs | 15 ++---- hydra-node/test/Hydra/BehaviorSpec.hs | 76 +++++++++++++++++---------- hydra-node/test/Test/Util.hs | 10 ++-- 5 files changed, 64 insertions(+), 48 deletions(-) diff --git a/hydra-node/hydra-node.cabal b/hydra-node/hydra-node.cabal index 1395450923b..348f0300a97 100644 --- a/hydra-node/hydra-node.cabal +++ b/hydra-node/hydra-node.cabal @@ -118,7 +118,6 @@ library , optparse-applicative , ouroboros-network-framework , prometheus - , safe-exceptions , serialise , shelley-spec-ledger , shelley-spec-ledger-test diff --git a/hydra-node/src/Hydra/Logging.hs b/hydra-node/src/Hydra/Logging.hs index a49c4a36301..139a05dd9b8 100644 --- a/hydra-node/src/Hydra/Logging.hs +++ b/hydra-node/src/Hydra/Logging.hs @@ -10,7 +10,7 @@ module Hydra.Logging ( nullTracer, contramap, traceWith, - traceInTVarIO, + traceInTVar, LoggerName, -- * Using it @@ -38,8 +38,7 @@ import Cardano.BM.Setup ( setupTrace_, shutdown, ) -import Cardano.BM.Trace (traceInTVarIO) -import Cardano.Prelude +import Cardano.Prelude hiding (atomically) import Control.Tracer ( Tracer (..), contramap, @@ -50,6 +49,7 @@ import Control.Tracer ( import qualified Cardano.BM.Configuration.Model as CM import qualified Cardano.BM.Data.BackendKind as CM +import Control.Monad.Class.MonadSTM (MonadSTM (atomically), TVar, modifyTVar) data Verbosity = Quiet | Verbose LoggerName deriving (Eq, Show) @@ -89,3 +89,7 @@ transformLogObject transform tr = Tracer $ \a -> do traceWith tr . (mempty,) =<< LogObject mempty <$> mkLOMeta Debug Public <*> pure (LogMessage (transform a)) + +traceInTVar :: MonadSTM m => TVar m [a] -> Tracer m a +traceInTVar tvar = Tracer $ \a -> + atomically $ modifyTVar tvar (a :) diff --git a/hydra-node/src/Hydra/Node.hs b/hydra-node/src/Hydra/Node.hs index 1ed6d96d7b4..ee3c5c7211e 100644 --- a/hydra-node/src/Hydra/Node.hs +++ b/hydra-node/src/Hydra/Node.hs @@ -6,14 +6,9 @@ module Hydra.Node where import Cardano.Prelude hiding (STM, async, atomically, cancel, check, poll, threadDelay) -import Control.Concurrent.STM ( - newTQueueIO, - readTQueue, - writeTQueue, - ) -import Control.Exception.Safe (MonadThrow) import Control.Monad.Class.MonadAsync (MonadAsync, async) -import Control.Monad.Class.MonadSTM (MonadSTM (STM), atomically, newTVar, stateTVar) +import Control.Monad.Class.MonadSTM (MonadSTM (STM), atomically, newTQueue, newTVar, readTQueue, stateTVar, writeTQueue) +import Control.Monad.Class.MonadThrow (MonadThrow) import Control.Monad.Class.MonadTimer (MonadTimer, threadDelay) import Hydra.HeadLogic ( ClientRequest (..), @@ -126,9 +121,9 @@ data EventQueue m e = EventQueue , nextEvent :: m e } -createEventQueue :: IO (EventQueue IO e) +createEventQueue :: MonadSTM m => m (EventQueue m e) createEventQueue = do - q <- newTQueueIO + q <- atomically newTQueue pure EventQueue { putEvent = atomically . writeTQueue q @@ -156,7 +151,7 @@ putState :: HydraHead tx m -> HeadState tx -> STM m () putState HydraHead{modifyHeadState} new = modifyHeadState $ const ((), new) -createHydraHead :: (MonadSTM m) => HeadState tx -> Ledger tx -> m (HydraHead tx m) +createHydraHead :: MonadSTM m => HeadState tx -> Ledger tx -> m (HydraHead tx m) createHydraHead initialState ledger = do tv <- atomically $ newTVar initialState pure HydraHead{modifyHeadState = stateTVar tv, ledger} diff --git a/hydra-node/test/Hydra/BehaviorSpec.hs b/hydra-node/test/Hydra/BehaviorSpec.hs index 9ad6d38da8e..447f3c5f6b8 100644 --- a/hydra-node/test/Hydra/BehaviorSpec.hs +++ b/hydra-node/test/Hydra/BehaviorSpec.hs @@ -1,12 +1,26 @@ {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} module Hydra.BehaviorSpec where -import Cardano.Prelude hiding (atomically, check, threadDelay) -import Control.Monad.Class.MonadSTM (TVar, atomically, check, modifyTVar, newTVarIO, readTVar) -import Control.Monad.Class.MonadTime (DiffTime) -import Control.Monad.Class.MonadTimer (threadDelay) -import Data.IORef (modifyIORef', newIORef, readIORef) +import Cardano.Prelude hiding (Async, STM, async, atomically, cancel, check, link, poll, threadDelay) +import Control.Monad.Class.MonadAsync (MonadAsync, async, cancel, link, poll) +import Control.Monad.Class.MonadFork (MonadFork) +import Control.Monad.Class.MonadSTM ( + MonadSTM, + TVar, + atomically, + check, + modifyTVar, + modifyTVar', + newEmptyTMVar, + newTVarIO, + putTMVar, + readTVar, + takeTMVar, + ) +import Control.Monad.Class.MonadThrow (MonadMask) +import Control.Monad.Class.MonadTimer (DiffTime, MonadTimer, threadDelay, timeout) import Hydra.HeadLogic ( ClientRequest (..), ClientResponse (..), @@ -19,8 +33,7 @@ import Hydra.HeadLogic ( ) import Hydra.Ledger (LedgerState) import Hydra.Ledger.Mock (MockTx (..), mockLedger) - -import Hydra.Logging (traceInTVarIO) +import Hydra.Logging (traceInTVar) import Hydra.Network (HydraNetwork (..)) import Hydra.Node ( HydraNode (..), @@ -34,17 +47,16 @@ import Hydra.Node ( queryLedgerState, runHydraNode, ) -import System.Timeout (timeout) import Test.Hspec ( Spec, describe, - expectationFailure, it, shouldContain, shouldNotBe, shouldReturn, ) import Test.Util (failAfter) +import Prelude (error) spec :: Spec spec = describe "Behavior of one ore more hydra-nodes" $ do @@ -64,7 +76,7 @@ spec = describe "Behavior of one ore more hydra-nodes" $ do sendRequest n (Init [1]) `shouldReturn` () it "accepts Commit after successful Init" $ do - n <- simulatedChainAndNetwork >>= startHydraNode 1 + n :: HydraProcess IO MockTx <- simulatedChainAndNetwork >>= startHydraNode 1 sendRequest n (Init [1]) sendRequest n (Commit 1) @@ -217,7 +229,7 @@ data HydraProcess m tx = HydraProcess , capturedLogs :: TVar m [HydraNodeLog tx] } -data Connections = Connections {chain :: OnChain IO, network :: HydraNetwork MockTx IO} +data Connections m = Connections {chain :: OnChain m, network :: HydraNetwork MockTx m} -- | Creates a simulated chain by returning a function to create the chain -- client interface for a node. This is necessary, to get to know all nodes @@ -226,19 +238,25 @@ data Connections = Connections {chain :: OnChain IO, network :: HydraNetwork Moc -- NOTE: This implementation currently ensures that no two equal 'OnChainTx' can -- be posted on chain assuming the construction of the real transaction is -- referentially transparent. -simulatedChainAndNetwork :: IO (HydraNode MockTx IO -> IO Connections) +simulatedChainAndNetwork :: MonadSTM m => m (HydraNode MockTx m -> m (Connections m)) simulatedChainAndNetwork = do - refHistory <- newIORef [] + refHistory <- newTVarIO [] nodes <- newTVarIO [] pure $ \n -> do atomically $ modifyTVar nodes (n :) pure $ Connections OnChain{postTx = postTx nodes refHistory} HydraNetwork{broadcast = broadcast nodes} where postTx nodes refHistory tx = do - h <- readIORef refHistory - unless (tx `elem` h) $ do - modifyIORef' refHistory (tx :) - atomically (readTVar nodes) >>= mapM_ (`handleChainTx` tx) + res <- atomically $ do + h <- readTVar refHistory + if tx `elem` h + then pure Nothing + else do + modifyTVar' refHistory (tx :) + Just <$> readTVar nodes + case res of + Nothing -> pure () + Just ns -> mapM_ (`handleChainTx` tx) ns broadcast nodes msg = atomically (readTVar nodes) >>= mapM_ (`handleMessage` msg) @@ -247,6 +265,7 @@ testContestationPeriod :: DiffTime testContestationPeriod = 10 startHydraNode :: + (MonadAsync m, MonadTimer m, MonadFork m, MonadMask m) => Natural -> (HydraNode MockTx IO -> IO Connections) -> IO (HydraProcess IO MockTx) @@ -259,9 +278,10 @@ startHydraNode' :: IO (HydraProcess IO MockTx) startHydraNode' snapshotStrategy nodeId connectToChain = do capturedLogs <- newTVarIO [] - response <- newEmptyMVar + response <- atomically newEmptyTMVar node <- createHydraNode response - nodeThread <- async $ runHydraNode (traceInTVarIO capturedLogs) node + -- TODO(SN): trace directly into io-sim's 'Trace' + nodeThread <- async $ runHydraNode (traceInTVar capturedLogs) node link nodeThread pure $ HydraProcess @@ -271,17 +291,15 @@ startHydraNode' snapshotStrategy nodeId connectToChain = do Nothing -> pure Ready Just _ -> pure NotReady , sendRequest = handleClientRequest node - , waitForResponse = takeMVar response + , waitForResponse = atomically $ takeTMVar response , waitForLedgerState = \st -> do - result <- - timeout - 1_000_000 - ( atomically $ do - st' <- queryLedgerState node - check (st == st') - ) - when (isNothing result) $ expectationFailure ("Expected ledger state of node " <> show nodeId <> " to be " <> show st) + result <- timeout 1 $ + atomically $ do + st' <- queryLedgerState node + check (st == st') + -- TODO(SN): use MonadThrow instead? + when (isNothing result) $ error ("Expected ledger state of node " <> show nodeId <> " to be " <> show st) , nodeId , capturedLogs } @@ -292,6 +310,6 @@ startHydraNode' snapshotStrategy nodeId connectToChain = do let headState = createHeadState [] (HeadParameters testContestationPeriod mempty) SnapshotStrategy hh <- createHydraHead headState mockLedger let hn' = HydraNetwork{broadcast = const $ pure ()} - let node = HydraNode{eq, hn = hn', hh, oc = OnChain (const $ pure ()), sendResponse = putMVar response, env} + let node = HydraNode{eq, hn = hn', hh, oc = OnChain (const $ pure ()), sendResponse = atomically . putTMVar response, env} Connections oc hn <- connectToChain node pure node{oc, hn} diff --git a/hydra-node/test/Test/Util.hs b/hydra-node/test/Test/Util.hs index e775762f775..1bf655ac991 100644 --- a/hydra-node/test/Test/Util.hs +++ b/hydra-node/test/Test/Util.hs @@ -1,12 +1,12 @@ module Test.Util where import Cardano.Prelude -import Control.Monad.Class.MonadTime (DiffTime) -import Control.Monad.Class.MonadTimer (timeout) -import Test.Hspec (expectationFailure) +import Control.Monad.Class.MonadTimer (DiffTime, MonadTimer, timeout) +import Prelude (error) -failAfter :: HasCallStack => DiffTime -> IO () -> IO () +failAfter :: (HasCallStack, MonadTimer m) => DiffTime -> m () -> m () failAfter seconds action = timeout seconds action >>= \case - Nothing -> expectationFailure $ "Test timed out after " <> show seconds <> " seconds" + -- TODO(SN): use MonadThrow instead? + Nothing -> error $ "Test timed out after " <> show seconds <> " seconds" Just _ -> pure ()