Use io-sim-classes to replace IO with IOSim later

Also, 'expectationFailure' got replaced by 'error' (for now). Maybe use
'MonadThrow' instead?

Author: ch1bo

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

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 :)

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}

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,21 +265,24 @@ testContestationPeriod :: DiffTime
 testContestationPeriod = 10
 
 startHydraNode ::
+  (MonadAsync m, MonadTimer m, MonadFork m, MonadMask m) =>
   Natural ->
-  (HydraNode MockTx IO -> IO Connections) ->
-  IO (HydraProcess IO MockTx)
+  (HydraNode MockTx m -> m (Connections m)) ->
+  m (HydraProcess m MockTx)
 startHydraNode = startHydraNode' NoSnapshots
 
 startHydraNode' ::
+  (MonadAsync m, MonadTimer m, MonadFork m, MonadMask m) =>
   SnapshotStrategy ->
   Natural ->
-  (HydraNode MockTx IO -> IO Connections) ->
-  IO (HydraProcess IO MockTx)
+  (HydraNode MockTx m -> m (Connections m)) ->
+  m (HydraProcess m 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,27 +292,25 @@ 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
       }
  where
   createHydraNode response = do
     let env = Environment nodeId
     eq <- createEventQueue
-    let headState = createHeadState [] (HeadParameters testContestationPeriod mempty) SnapshotStrategy
+    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}

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 ()