core: test async handshake (#569)

* core: test async handshake

* Update tests/ChatTests.hs

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>

cabal.project

@@ -3,7 +3,7 @@ packages: .
 source-repository-package
     type: git
     location: https://github.com/simplex-chat/simplexmq.git
-    tag: c6dde772b459a2d8f392ad5455d6f8fd6f16e867
+    tag: f8ec838912579159ca0ebd956a559fc20bf1d7ea
 
 source-repository-package
     type: git

scripts/nix/sha256map.nix

@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."c6dde772b459a2d8f392ad5455d6f8fd6f16e867" = "08crpg2jnpvj08cl372znbhf3n0frm8ldbl2bwva0f0jq5j364nk";
+  "https://github.com/simplex-chat/simplexmq.git"."f8ec838912579159ca0ebd956a559fc20bf1d7ea" = "0kywhk2q92h3j24pp9lxycs062myl8ch7wdwlyd6v82lcm14w8pd";
   "https://github.com/simplex-chat/aeson.git"."3eb66f9a68f103b5f1489382aad89f5712a64db7" = "0kilkx59fl6c3qy3kjczqvm8c3f4n3p0bdk9biyflf51ljnzp4yp";
   "https://github.com/simplex-chat/haskell-terminal.git"."f708b00009b54890172068f168bf98508ffcd495" = "0zmq7lmfsk8m340g47g5963yba7i88n4afa6z93sg9px5jv1mijj";
   "https://github.com/zw3rk/android-support.git"."3c3a5ab0b8b137a072c98d3d0937cbdc96918ddb" = "1r6jyxbim3dsvrmakqfyxbd6ms6miaghpbwyl0sr6dzwpgaprz97";

src/Simplex/Chat.hs

@@ -146,6 +146,11 @@ startChatController user = do
       atomically . writeTVar s $ Just a
       pure a
 
+stopChatController :: MonadUnliftIO m => ChatController -> m ()
+stopChatController ChatController {smpAgent, agentAsync = s} = do
+  disconnectAgentClient smpAgent
+  readTVarIO s >>= mapM_ uninterruptibleCancel >> atomically (writeTVar s Nothing)
+
 withLock :: MonadUnliftIO m => TMVar () -> m a -> m a
 withLock lock =
   E.bracket_

stack.yaml

@@ -49,7 +49,7 @@ extra-deps:
   # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
   # - ../simplexmq
   - github: simplex-chat/simplexmq
-    commit: c6dde772b459a2d8f392ad5455d6f8fd6f16e867
+    commit: f8ec838912579159ca0ebd956a559fc20bf1d7ea
   # - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977
   - github: simplex-chat/aeson
     commit: 3eb66f9a68f103b5f1489382aad89f5712a64db7

tests/ChatClient.hs

@@ -8,12 +8,12 @@
 
 module ChatClient where
 
-import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread)
+import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread, threadDelay)
 import Control.Concurrent.Async
 import Control.Concurrent.STM
 import Control.Exception (bracket, bracket_)
 import Control.Monad.Except
-import Data.List (dropWhileEnd)
+import Data.List (dropWhileEnd, find)
 import Data.Maybe (fromJust)
 import qualified Data.Text as T
 import Network.Socket
@@ -81,10 +81,22 @@ cfg =
       testView = True
     }
 
-virtualSimplexChat :: FilePath -> Profile -> IO TestCC
-virtualSimplexChat dbFilePrefix profile = do
+createTestChat :: Int -> Profile -> IO TestCC
+createTestChat dbNumber profile = do
+  let dbFilePrefix = testDBPrefix <> show dbNumber
   st <- createStore (dbFilePrefix <> "_chat.db") 1 False
   Right user <- runExceptT $ createUser st profile True
+  startTestChat_ st dbFilePrefix user
+
+startTestChat :: Int -> IO TestCC
+startTestChat dbNumber = do
+  let dbFilePrefix = testDBPrefix <> show dbNumber
+  st <- createStore (dbFilePrefix <> "_chat.db") 1 False
+  Just user <- find activeUser <$> getUsers st
+  startTestChat_ st dbFilePrefix user
+
+startTestChat_ :: SQLiteStore -> FilePath -> User -> IO TestCC
+startTestChat_ st dbFilePrefix user = do
   t <- withVirtualTerminal termSettings pure
   ct <- newChatTerminal t
   cc <- newChatController st (Just user) cfg opts {dbFilePrefix} Nothing -- no notifications
@@ -93,6 +105,19 @@ virtualSimplexChat dbFilePrefix profile = do
   termAsync <- async $ readTerminalOutput t termQ
   pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ}
 
+stopTestChat :: TestCC -> IO ()
+stopTestChat TestCC {chatController = cc, chatAsync, termAsync} = do
+  threadDelay 500000
+  stopChatController cc
+  uninterruptibleCancel termAsync
+  uninterruptibleCancel chatAsync
+
+withNewTestChat :: Int -> Profile -> (TestCC -> IO a) -> IO a
+withNewTestChat dbNumber profile = bracket (createTestChat dbNumber profile) stopTestChat
+
+withTestChat :: Int -> (TestCC -> IO a) -> IO a
+withTestChat dbNumber = bracket (startTestChat dbNumber) stopTestChat
+
 readTerminalOutput :: VirtualTerminal -> TQueue String -> IO ()
 readTerminalOutput t termQ = do
   let w = virtualWindow t
@@ -124,14 +149,14 @@ withTmpFiles =
 
 testChatN :: [Profile] -> ([TestCC] -> IO ()) -> IO ()
 testChatN ps test = withTmpFiles $ do
-  let envs = zip ps $ map ((testDBPrefix <>) . show) [(1 :: Int) ..]
-  tcs <- getTestCCs envs []
+  tcs <- getTestCCs (zip ps [1 ..]) []
   test tcs
   concurrentlyN_ $ map (<// 100000) tcs
+  concurrentlyN_ $ map stopTestChat tcs
   where
-    getTestCCs :: [(Profile, FilePath)] -> [TestCC] -> IO [TestCC]
+    getTestCCs :: [(Profile, Int)] -> [TestCC] -> IO [TestCC]
     getTestCCs [] tcs = pure tcs
-    getTestCCs ((p, db) : envs') tcs = (:) <$> virtualSimplexChat db p <*> getTestCCs envs' tcs
+    getTestCCs ((p, db) : envs') tcs = (:) <$> createTestChat db p <*> getTestCCs envs' tcs
 
 (<//) :: TestCC -> Int -> Expectation
 (<//) cc t = timeout t (getTermLine cc) `shouldReturn` Nothing

tests/ChatTests.hs

@@ -81,6 +81,10 @@ chatTests = do
     it "delete connection requests when contact link deleted" testDeleteConnectionRequests
   describe "SMP servers" $
     it "get and set SMP servers" testGetSetSMPServers
+  describe "Async connection handshake" $ do
+    it "should connect when initiating client goes offline" testAsyncInitiatingOffline
+    it "should connect when accepting client goes offline" testAsyncAcceptingOffline
+    it "should connect when clients are never simultaneously online" testAsyncNeverTogetherOnline
 
 testAddContact :: IO ()
 testAddContact =
@@ -1742,6 +1746,53 @@ testGetSetSMPServers =
       alice #$> ("/smp_servers default", id, "ok")
       alice #$> ("/smp_servers", id, "no custom SMP servers saved")
 
+testAsyncInitiatingOffline :: IO ()
+testAsyncInitiatingOffline = withTmpFiles $ do
+  inv <- withNewTestChat 1 aliceProfile $ \alice -> do
+    alice ##> "/c"
+    getInvitation alice
+  withNewTestChat 2 bobProfile $ \bob -> do
+    bob ##> ("/c " <> inv)
+    bob <## "confirmation sent!"
+    withTestChat 1 $ \alice -> do
+      concurrently_
+        (bob <## "alice (Alice): contact is connected")
+        (alice <## "bob (Bob): contact is connected")
+
+testAsyncAcceptingOffline :: IO ()
+testAsyncAcceptingOffline = withTmpFiles $ do
+  inv <- withNewTestChat 1 aliceProfile $ \alice -> do
+    alice ##> "/c"
+    getInvitation alice
+  withNewTestChat 2 bobProfile $ \bob -> do
+    bob ##> ("/c " <> inv)
+    bob <## "confirmation sent!"
+  withTestChat 1 $ \alice ->
+    withTestChat 2 $ \bob ->
+      concurrently_
+        (bob <## "alice (Alice): contact is connected")
+        (alice <## "bob (Bob): contact is connected")
+
+testAsyncNeverTogetherOnline :: IO ()
+testAsyncNeverTogetherOnline = withTmpFiles $ do
+  inv <- withNewTestChat 1 aliceProfile $ \alice -> do
+    alice ##> "/c"
+    getInvitation alice
+  withNewTestChat 2 bobProfile $ \bob -> do
+    bob ##> ("/c " <> inv)
+    bob <## "confirmation sent!"
+  withTestChat 1 $ \_ -> pure ()
+  withTestChat 2 $ \_ -> pure ()
+  withTestChat 1 $ \alice ->
+    alice <## "1 contacts connected (use /cs for the list)"
+  withTestChat 2 $ \_ -> pure ()
+  withTestChat 1 $ \alice -> do
+    alice <## "1 contacts connected (use /cs for the list)"
+    alice <## "bob (Bob): contact is connected"
+  withTestChat 2 $ \bob -> do
+    bob <## "1 contacts connected (use /cs for the list)"
+    bob <## "alice (Alice): contact is connected"
+
 startFileTransfer :: TestCC -> TestCC -> IO ()
 startFileTransfer alice bob = do
   alice #> "/f @bob ./tests/fixtures/test.jpg"

tests/Test.hs

@@ -1,5 +1,6 @@
 import ChatClient
 import ChatTests
+-- import Control.Logger.Simple
 import MarkdownTests
 import MobileTests
 import ProtocolTests
@@ -7,9 +8,15 @@ import SchemaDump
 import Test.Hspec
 
 main :: IO ()
-main = withSmpServer . hspec $ do
-  describe "SimpleX chat markdown" markdownTests
-  describe "SimpleX chat protocol" protocolTests
-  describe "Mobile API Tests" mobileTests
-  describe "SimpleX chat client" chatTests
-  describe "Schema dump" schemaDumpTest
+main = do
+  -- setLogLevel LogDebug -- LogError
+  -- withGlobalLogging logCfg $
+  withSmpServer . hspec $ do
+    describe "SimpleX chat markdown" markdownTests
+    describe "SimpleX chat protocol" protocolTests
+    describe "Mobile API Tests" mobileTests
+    describe "SimpleX chat client" chatTests
+    describe "Schema dump" schemaDumpTest
+
+-- logCfg :: LogConfig
+-- logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}