tests: block on tcp server creation (#99)

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

.github/workflows/build.yml

@@ -56,12 +56,12 @@ jobs:
             stack_args: "--test"
             artifact_rel_path: /bin/dog-food
             asset_name: dog-food-ubuntu-18_04-x86-64
-          # TODO re-enable tests for mac and windows when they consistently pass (remove stack_args altogether)
           - os: macos-latest
             cache_path: ~/.stack
-            stack_args: ""
+            stack_args: "--test"
             artifact_rel_path: /bin/dog-food
             asset_name: dog-food-macos-x86-64
+          # TODO enable tests for windows once fixed (remove stack_args altogether)
           - os: windows-latest
             cache_path: C:/sr
             stack_args: ""

apps/smp-agent/Main.hs

@@ -25,5 +25,4 @@ main :: IO ()
 main = do
   putStrLn $ "SMP agent listening on port " ++ tcpPort (cfg :: AgentConfig)
   setLogLevel LogInfo -- LogError
-  withGlobalLogging logCfg $
-    runSMPAgent cfg
+  withGlobalLogging logCfg $ runSMPAgent cfg

src/Simplex/Messaging/Agent.hs

@@ -10,6 +10,7 @@
 
 module Simplex.Messaging.Agent
   ( runSMPAgent,
+    runSMPAgentBlocking,
     getSMPAgentClient,
     runSMPAgentClient,
   )
@@ -43,10 +44,13 @@ import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
 runSMPAgent :: (MonadRandom m, MonadUnliftIO m) => AgentConfig -> m ()
-runSMPAgent cfg@AgentConfig {tcpPort} = runReaderT smpAgent =<< newSMPAgentEnv cfg
+runSMPAgent cfg = newEmptyTMVarIO >>= (`runSMPAgentBlocking` cfg)
+
+runSMPAgentBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> AgentConfig -> m ()
+runSMPAgentBlocking started cfg@AgentConfig {tcpPort} = runReaderT smpAgent =<< newSMPAgentEnv cfg
   where
     smpAgent :: (MonadUnliftIO m', MonadReader Env m') => m' ()
-    smpAgent = runTCPServer tcpPort $ \h -> do
+    smpAgent = runTCPServer started tcpPort $ \h -> do
       liftIO $ putLn h "Welcome to SMP v0.2.0 agent"
       c <- getSMPAgentClient
       logConnection c True

src/Simplex/Messaging/Server.hs

@@ -11,7 +11,7 @@
 {-# LANGUAGE TupleSections #-}
 
 -- TODO move randomBytes to another module
-module Simplex.Messaging.Server (runSMPServer, randomBytes) where
+module Simplex.Messaging.Server (runSMPServer, runSMPServerBlocking, randomBytes) where
 
 import Control.Concurrent.STM (stateTVar)
 import Control.Monad
@@ -39,14 +39,17 @@ import UnliftIO.IO
 import UnliftIO.STM
 
 runSMPServer :: (MonadRandom m, MonadUnliftIO m) => ServerConfig -> m ()
-runSMPServer cfg@ServerConfig {tcpPort} = do
+runSMPServer cfg = newEmptyTMVarIO >>= (`runSMPServerBlocking` cfg)
+
+runSMPServerBlocking :: (MonadRandom m, MonadUnliftIO m) => TMVar Bool -> ServerConfig -> m ()
+runSMPServerBlocking started cfg@ServerConfig {tcpPort} = do
   env <- newEnv cfg
   runReaderT smpServer env
   where
     smpServer :: (MonadUnliftIO m, MonadReader Env m) => m ()
     smpServer = do
       s <- asks server
-      race_ (runTCPServer tcpPort runClient) (serverThread s)
+      race_ (runTCPServer started tcpPort runClient) (serverThread s)
 
     serverThread :: MonadUnliftIO m => Server -> m ()
     serverThread Server {subscribedQ, subscribers} = forever . atomically $ do

src/Simplex/Messaging/Transport.hs

@@ -24,10 +24,10 @@ import qualified UnliftIO.Exception as E
 import qualified UnliftIO.IO as IO
 import UnliftIO.STM
 
-runTCPServer :: MonadUnliftIO m => ServiceName -> (Handle -> m ()) -> m ()
-runTCPServer port server = do
+runTCPServer :: MonadUnliftIO m => TMVar Bool -> ServiceName -> (Handle -> m ()) -> m ()
+runTCPServer started port server = do
   clients <- newTVarIO S.empty
-  E.bracket (liftIO $ startTCPServer port) (liftIO . closeServer clients) $ \sock -> forever $ do
+  E.bracket (liftIO $ startTCPServer started port) (liftIO . closeServer clients) \sock -> forever $ do
     h <- liftIO $ acceptTCPConn sock
     tid <- forkFinally (server h) (const $ IO.hClose h)
     atomically . modifyTVar clients $ S.insert tid
@@ -35,8 +35,8 @@ runTCPServer port server = do
     closeServer :: TVar (Set ThreadId) -> Socket -> IO ()
     closeServer clients sock = readTVarIO clients >>= mapM_ killThread >> close sock
 
-startTCPServer :: ServiceName -> IO Socket
-startTCPServer port = withSocketsDo $ resolve >>= open
+startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
+startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
   where
     resolve =
       let hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream}
@@ -48,6 +48,7 @@ startTCPServer port = withSocketsDo $ resolve >>= open
       bind sock $ addrAddress addr
       listen sock 1024
       return sock
+    setStarted sock = atomically (putTMVar started True) >> pure sock
 
 acceptTCPConn :: Socket -> IO Handle
 acceptTCPConn sock = accept sock >>= getSocketHandle . fst

tests/AgentTests.hs

@@ -29,7 +29,6 @@ agentTests = do
     it "should connect via one server and 2 agents" $
       smpAgentTest2 testDuplexConnection
   describe "Connection subscriptions" do
-    -- TODO replace delays with a permanent fix, this often fails in github build
     xit "should connect via one server and one agent" $
       smpAgentTest3_1 testSubscription
     it "should send notifications to client when server disconnects" $

tests/AgentTests/SQLiteTests.hs

@@ -22,7 +22,7 @@ import Test.Hspec
 import UnliftIO.Directory (removeFile)
 
 testDB :: String
-testDB = "smp-agent.test.db"
+testDB = "tests/tmp/smp-agent.test.db"
 
 withStore :: SpecWith SQLiteStore -> Spec
 withStore = before createStore . after removeStore

tests/SMPAgentClient.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -10,16 +11,18 @@ import Control.Monad.IO.Unlift
 import Crypto.Random
 import Network.Socket (HostName, ServiceName)
 import SMPClient (testPort, withSmpServer, withSmpServerThreadOn)
-import Simplex.Messaging.Agent
+import Simplex.Messaging.Agent (runSMPAgentBlocking)
 import Simplex.Messaging.Agent.Env.SQLite
 import Simplex.Messaging.Agent.Transmission
 import Simplex.Messaging.Client (SMPClientConfig (..), smpDefaultConfig)
 import Simplex.Messaging.Transport
+import System.Timeout (timeout)
 import Test.Hspec
 import UnliftIO.Concurrent
 import UnliftIO.Directory
 import qualified UnliftIO.Exception as E
 import UnliftIO.IO
+import UnliftIO.STM (atomically, newEmptyTMVarIO, takeTMVar)
 
 agentTestHost :: HostName
 agentTestHost = "localhost"
@@ -34,13 +37,13 @@ agentTestPort3 :: ServiceName
 agentTestPort3 = "5021"
 
 testDB :: String
-testDB = "smp-agent.test.protocol.db"
+testDB = "tests/tmp/smp-agent.test.protocol.db"
 
 testDB2 :: String
-testDB2 = "smp-agent2.test.protocol.db"
+testDB2 = "tests/tmp/smp-agent2.test.protocol.db"
 
 testDB3 :: String
-testDB3 = "smp-agent3.test.protocol.db"
+testDB3 = "tests/tmp/smp-agent3.test.protocol.db"
 
 smpAgentTest :: ARawTransmission -> IO ARawTransmission
 smpAgentTest cmd = runSmpAgentTest $ \h -> tPutRaw h cmd >> tGetRaw h
@@ -122,10 +125,12 @@ cfg =
     }
 
 withSmpAgentThreadOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, String) -> (ThreadId -> m a) -> m a
-withSmpAgentThreadOn (port', db') =
+withSmpAgentThreadOn (port', db') f = do
+  started <- newEmptyTMVarIO
   E.bracket
-    (forkIOWithUnmask ($ runSMPAgent cfg {tcpPort = port', dbFile = db'}))
+    (forkIOWithUnmask ($ runSMPAgentBlocking started cfg {tcpPort = port', dbFile = db'}))
     (liftIO . killThread >=> const (removeFile db'))
+    \x -> liftIO (5_000_000 `timeout` atomically (takeTMVar started)) >> f x
 
 withSmpAgentOn :: (MonadUnliftIO m, MonadRandom m) => (ServiceName, String) -> m a -> m a
 withSmpAgentOn (port', db') = withSmpAgentThreadOn (port', db') . const
@@ -135,7 +140,6 @@ withSmpAgent = withSmpAgentOn (agentTestPort, testDB)
 
 testSMPAgentClientOn :: MonadUnliftIO m => ServiceName -> (Handle -> m a) -> m a
 testSMPAgentClientOn port' client = do
-  threadDelay 500_000 -- TODO hack: thread delay for SMP agent to start
   runTCPClient agentTestHost port' $ \h -> do
     line <- liftIO $ getLn h
     if line == "Welcome to SMP v0.2.0 agent"

tests/SMPClient.hs

@@ -9,13 +9,15 @@ import Control.Monad.IO.Unlift
 import Crypto.Random
 import Network.Socket
 import Simplex.Messaging.Protocol
-import Simplex.Messaging.Server
+import Simplex.Messaging.Server (runSMPServerBlocking)
 import Simplex.Messaging.Server.Env.STM
 import Simplex.Messaging.Transport
+import System.Timeout (timeout)
 import Test.Hspec
 import UnliftIO.Concurrent
 import qualified UnliftIO.Exception as E
 import UnliftIO.IO
+import UnliftIO.STM (atomically, newEmptyTMVarIO, takeTMVar)
 
 testHost :: HostName
 testHost = "localhost"
@@ -25,7 +27,6 @@ testPort = "5000"
 
 testSMPClient :: MonadUnliftIO m => (Handle -> m a) -> m a
 testSMPClient client = do
-  threadDelay 250_000 -- TODO hack: thread delay for SMP server to start
   runTCPClient testHost testPort $ \h -> do
     line <- liftIO $ getLn h
     if line == "Welcome to SMP v0.2.0"
@@ -42,10 +43,12 @@ cfg =
     }
 
 withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ServiceName -> (ThreadId -> m a) -> m a
-withSmpServerThreadOn port =
+withSmpServerThreadOn port f = do
+  started <- newEmptyTMVarIO
   E.bracket
-    (forkIOWithUnmask ($ runSMPServer cfg {tcpPort = port}))
+    (forkIOWithUnmask ($ runSMPServerBlocking started cfg {tcpPort = port}))
     (liftIO . killThread)
+    \x -> liftIO (5_000_000 `timeout` atomically (takeTMVar started)) >> f x
 
 withSmpServerOn :: (MonadUnliftIO m, MonadRandom m) => ServiceName -> m a -> m a
 withSmpServerOn port = withSmpServerThreadOn port . const

tests/Test.hs

@@ -1,10 +1,14 @@
 import AgentTests
 import MarkdownTests
 import ServerTests
+import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import Test.Hspec
 
 main :: IO ()
-main = hspec $ do
-  describe "SimpleX markdown" markdownTests
-  describe "SMP server" serverTests
-  describe "SMP client agent" agentTests
+main = do
+  createDirectoryIfMissing False "tests/tmp"
+  hspec $ do
+    describe "SimpleX markdown" markdownTests
+    describe "SMP server" serverTests
+    describe "SMP client agent" agentTests
+  removeDirectoryRecursive "tests/tmp"