From 2eb5ce24ec6f1b21f4d51f4bc8d016a26226b0a7 Mon Sep 17 00:00:00 2001 From: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com> Date: Wed, 14 Apr 2021 02:25:57 +0400 Subject: [PATCH] tests: block on tcp server creation (#99) Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> --- .github/workflows/build.yml | 4 ++-- apps/smp-agent/Main.hs | 3 +-- src/Simplex/Messaging/Agent.hs | 8 ++++++-- src/Simplex/Messaging/Server.hs | 9 ++++++--- src/Simplex/Messaging/Transport.hs | 11 ++++++----- tests/AgentTests.hs | 1 - tests/AgentTests/SQLiteTests.hs | 2 +- tests/SMPAgentClient.hs | 18 +++++++++++------- tests/SMPClient.hs | 11 +++++++---- tests/Test.hs | 12 ++++++++---- 10 files changed, 48 insertions(+), 31 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 3ea55e045..dd30dbb1d 100644 --- a/.github/workflows/build.yml +++ b/.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: "" diff --git a/apps/smp-agent/Main.hs b/apps/smp-agent/Main.hs index b39af0eeb..f77eb0527 100644 --- a/apps/smp-agent/Main.hs +++ b/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 diff --git a/src/Simplex/Messaging/Agent.hs b/src/Simplex/Messaging/Agent.hs index eb9330dd3..e11d91f8d 100644 --- a/src/Simplex/Messaging/Agent.hs +++ b/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 diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs index a76a916e9..034ff8ff8 100644 --- a/src/Simplex/Messaging/Server.hs +++ b/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 diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs index d0e2aa0e9..02346fa3d 100644 --- a/src/Simplex/Messaging/Transport.hs +++ b/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 diff --git a/tests/AgentTests.hs b/tests/AgentTests.hs index c3b7b0a5c..3bcdd1314 100644 --- a/tests/AgentTests.hs +++ b/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" $ diff --git a/tests/AgentTests/SQLiteTests.hs b/tests/AgentTests/SQLiteTests.hs index fe6593c88..9bf9b6a8b 100644 --- a/tests/AgentTests/SQLiteTests.hs +++ b/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 diff --git a/tests/SMPAgentClient.hs b/tests/SMPAgentClient.hs index 23b65d25b..5f7175871 100644 --- a/tests/SMPAgentClient.hs +++ b/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" diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs index 0cde0e740..56598673a 100644 --- a/tests/SMPClient.hs +++ b/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 diff --git a/tests/Test.hs b/tests/Test.hs index 052b01f7a..06f495d99 100644 --- a/tests/Test.hs +++ b/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"