chat test with VirtualTerminal (#72)

* chat test with VirtualTerminal

* disable chat test

* fix intermittently failing test

* simplify test

tests/ChatClient.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChatClient where
+
+import Control.Concurrent.Async
+import Control.Concurrent.STM (retry)
+import Control.Monad.Except
+import Simplex.Chat
+import Simplex.Chat.Controller (ChatController (..))
+import Simplex.Chat.Options
+import Simplex.Chat.Store
+import Simplex.Chat.Types (Profile)
+import qualified System.Terminal as C
+import System.Terminal.Internal (VirtualTerminal, VirtualTerminalSettings (..), withVirtualTerminal)
+
+testDB1 :: FilePath
+testDB1 = "tests/tmp/test1"
+
+testDB2 :: FilePath
+testDB2 = "tests/tmp/test2"
+
+opts :: ChatOpts
+opts =
+  ChatOpts
+    { dbFile = undefined,
+      smpServers = ["localhost:5223"]
+    }
+
+termSettings :: VirtualTerminalSettings
+termSettings =
+  VirtualTerminalSettings
+    { virtualType = "xterm",
+      virtualWindowSize = pure C.Size {height = 24, width = 1000},
+      virtualEvent = retry,
+      virtualInterrupt = retry
+    }
+
+data TestCC = TestCC ChatController VirtualTerminal (Async ())
+
+virtualSimplexChat :: FilePath -> Profile -> IO TestCC
+virtualSimplexChat dbFile profile = do
+  st <- createStore (dbFile <> ".chat.db") 1
+  void . runExceptT $ createUser st profile True
+  t <- withVirtualTerminal termSettings pure
+  cc <- newChatController opts {dbFile} t . const $ pure () -- no notifications
+  a <- async $ runSimplexChat cc
+  pure (TestCC cc t a)
+
+testChat2 :: Profile -> Profile -> (TestCC -> TestCC -> IO ()) -> IO ()
+testChat2 p1 p2 test = do
+  tc1 <- virtualSimplexChat testDB1 p1
+  tc2 <- virtualSimplexChat testDB2 p2
+  test tc1 tc2

tests/ChatTests.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module ChatTests where
+
+import ChatClient
+import Control.Concurrent.Async (concurrently_)
+import Control.Concurrent.STM
+import Data.Char (isDigit)
+import Data.List (dropWhileEnd, find, isPrefixOf)
+import Simplex.Chat.Controller
+import Simplex.Chat.Types (Profile (..))
+import System.Terminal.Internal (VirtualTerminal (..))
+import Test.Hspec
+
+aliceProfile :: Profile
+aliceProfile = Profile {contactRef = "alice", displayName = "Alice"}
+
+bobProfile :: Profile
+bobProfile = Profile {contactRef = "bob", displayName = "Bob"}
+
+testAddContact :: Spec
+testAddContact = describe "add chat contact" $
+  xit "add contact and send/receive message" $
+    testChat2 aliceProfile bobProfile $ \alice bob -> do
+      alice ##> "/a"
+      Just inv <- invitation <$> getWindow alice
+      bob ##> ("/c " <> inv)
+      concurrently_
+        (bob <## "alice is connected")
+        (alice <## "bob is connected")
+      alice #> "@bob hello"
+      bob <# "alice> hello"
+      bob #> "@alice hi"
+      alice <# "bob> hi"
+
+(##>) :: TestCC -> String -> IO ()
+(##>) cc cmd = do
+  chatCommand cc cmd
+  cc <## cmd
+
+(#>) :: TestCC -> String -> IO ()
+(#>) cc cmd = do
+  chatCommand cc cmd
+  cc <# cmd
+
+chatCommand :: TestCC -> String -> IO ()
+chatCommand (TestCC cc _ _) cmd = atomically $ writeTBQueue (inputQ cc) $ InputCommand cmd
+
+(<##) :: TestCC -> String -> Expectation
+cc <## line = (lastOutput <$> getWindow cc) `shouldReturn` line
+
+(<#) :: TestCC -> String -> Expectation
+cc <# line = (dropTime . lastOutput <$> getWindow cc) `shouldReturn` line
+
+dropTime :: String -> String
+dropTime msg = case splitAt 6 msg of
+  ([m, m', ':', s, s', ' '], text) ->
+    if all isDigit [m, m', s, s'] then text else error "invalid time"
+  _ -> error "invalid time"
+
+getWindow :: TestCC -> IO [String]
+getWindow (TestCC _ t _) = do
+  let w = virtualWindow t
+  win <- readTVarIO w
+  atomically $ do
+    win' <- readTVar w
+    if win' /= win then pure win' else retry
+
+invitation :: [String] -> Maybe String
+invitation win = dropWhileEnd (== ' ') <$> find ("smp::" `isPrefixOf`) win
+
+lastOutput :: [String] -> String
+lastOutput win = dropWhileEnd (== ' ') $ win !! (length win - 2) -- (- 2) to exclude prompt

tests/Test.hs

@@ -1,9 +1,14 @@
+import ChatTests
 import MarkdownTests
 import ProtocolTests
+import System.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
 import Test.Hspec
 
 main :: IO ()
 main = do
+  createDirectoryIfMissing False "tests/tmp"
   hspec $ do
     describe "SimpleX chat markdown" markdownTests
     describe "SimpleX chat protocol" protocolTests
+    describe "SimpleX chat client" testAddContact
+  removeDirectoryRecursive "tests/tmp"