chat test with VirtualTerminal (#72)

* chat test with VirtualTerminal

* disable chat test

* fix intermittently failing test

* simplify test

apps/simplex-chat/Main.hs

@@ -5,51 +5,16 @@
 
 module Main where
 
-import Control.Concurrent.STM (atomically)
-import Control.Logger.Simple
-import Control.Monad.IO.Unlift
-import Control.Monad.Reader
 import Simplex.Chat
-import Simplex.Chat.Controller
-import Simplex.Chat.Input
-import Simplex.Chat.Notification
 import Simplex.Chat.Options
-import Simplex.Chat.Store (createStore)
-import Simplex.Chat.Terminal
-import Simplex.Messaging.Agent (getSMPAgentClient)
-import Simplex.Messaging.Agent.Env.SQLite
-import Simplex.Messaging.Client (smpDefaultConfig)
 import System.Directory (getAppUserDataDirectory)
-import UnliftIO.Async (race_)
-
-cfg :: AgentConfig
-cfg =
-  AgentConfig
-    { tcpPort = undefined, -- agent does not listen to TCP
-      smpServers = undefined, -- filled in from options
-      rsaKeySize = 2048 `div` 8,
-      connIdBytes = 12,
-      tbqSize = 16,
-      dbFile = "smp-chat.db",
-      dbPoolSize = 4,
-      smpCfg = smpDefaultConfig
-    }
-
-logCfg :: LogConfig
-logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+import System.Terminal (withTerminal)
 
 main :: IO ()
 main = do
-  ChatOpts {dbFile, smpServers} <- welcomeGetOpts
-  st <- createStore (dbFile <> ".chat.db") 4
-  user <- getCreateActiveUser st
-  ct <- newChatTerminal
-  a <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers}
-  notify <- initializeNotifications
-  cc <- atomically $ newChatController a ct st user notify $ tbqSize cfg
-  -- setLogLevel LogInfo -- LogError
-  -- withGlobalLogging logCfg $ do
-  runReaderT simplexChat cc
+  opts <- welcomeGetOpts
+  t <- withTerminal pure
+  simplexChat opts t
 
 welcomeGetOpts :: IO ChatOpts
 welcomeGetOpts = do
@@ -60,9 +25,6 @@ welcomeGetOpts = do
   putStrLn "type \"/help\" or \"/h\" for usage info"
   pure opts
 
-simplexChat :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
-simplexChat = race_ runTerminalInput runChatController
-
 -- defaultSettings :: C.Size -> C.VirtualTerminalSettings
 -- defaultSettings size =
 --   C.VirtualTerminalSettings

package.yaml

@@ -19,11 +19,13 @@ dependencies:
   - bytestring == 0.10.*
   - containers == 0.6.*
   - directory == 1.3.*
+  - exceptions == 0.10.*
   - file-embed == 0.0.14.*
   - filepath == 1.4.*
   - mtl == 2.2.*
   - optparse-applicative == 0.15.*
   - process == 1.6.*
+  - simple-logger == 0.1.*
   - simplexmq == 0.3.*
   - sqlite-simple == 0.4.*
   - terminal == 0.2.*
@@ -42,7 +44,6 @@ executables:
     dependencies:
       - simplex-chat
       - async == 2.2.*
-      - simple-logger == 0.1.*
       - simplexmq == 0.3.*
       - stm == 2.5.*
     ghc-options:
@@ -54,7 +55,9 @@ tests:
     main: Test.hs
     dependencies:
       - simplex-chat
+      - async == 2.2.*
       - hspec == 2.7.*
+      - stm == 2.5.*
 
 ghc-options:
   # - -haddock

src/Simplex/Chat.hs

@@ -11,6 +11,7 @@
 module Simplex.Chat where
 
 import Control.Applicative ((<|>))
+import Control.Logger.Simple
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
@@ -28,7 +29,9 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Simplex.Chat.Controller
 import Simplex.Chat.Help
+import Simplex.Chat.Input
 import Simplex.Chat.Notification
+import Simplex.Chat.Options (ChatOpts (..))
 import Simplex.Chat.Protocol
 import Simplex.Chat.Store
 import Simplex.Chat.Styled (plain)
@@ -36,12 +39,15 @@ import Simplex.Chat.Terminal
 import Simplex.Chat.Types
 import Simplex.Chat.View
 import Simplex.Messaging.Agent
+import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
 import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Client (smpDefaultConfig)
 import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util (bshow, raceAny_)
 import System.Exit (exitFailure)
 import System.IO (hFlush, stdout)
 import Text.Read (readMaybe)
+import UnliftIO.Async (race_)
 import qualified UnliftIO.Exception as E
 import UnliftIO.STM
 
@@ -54,6 +60,43 @@ data ChatCommand
   | SendMessage ContactRef ByteString
   deriving (Show)
 
+cfg :: AgentConfig
+cfg =
+  AgentConfig
+    { tcpPort = undefined, -- agent does not listen to TCP
+      smpServers = undefined, -- filled in from options
+      rsaKeySize = 2048 `div` 8,
+      connIdBytes = 12,
+      tbqSize = 16,
+      dbFile = undefined, -- filled in from options
+      dbPoolSize = 4,
+      smpCfg = smpDefaultConfig
+    }
+
+logCfg :: LogConfig
+logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
+
+simplexChat :: WithTerminal t => ChatOpts -> t -> IO ()
+simplexChat opts t = do
+  -- setLogLevel LogInfo -- LogError
+  -- withGlobalLogging logCfg $ do
+  initializeNotifications
+    >>= newChatController opts t
+    >>= runSimplexChat
+
+newChatController :: WithTerminal t => ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
+newChatController ChatOpts {dbFile, smpServers} t sendNotification = do
+  chatStore <- createStore (dbFile <> ".chat.db") 4
+  currentUser <- getCreateActiveUser chatStore
+  chatTerminal <- newChatTerminal t
+  smpAgent <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers}
+  inputQ <- newTBQueueIO $ tbqSize cfg
+  notifyQ <- newTBQueueIO $ tbqSize cfg
+  pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, inputQ, notifyQ, sendNotification}
+
+runSimplexChat :: ChatController -> IO ()
+runSimplexChat = runReaderT (race_ runTerminalInput runChatController)
+
 runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
 runChatController =
   raceAny_
@@ -107,7 +150,6 @@ processChatCommand User {userId, profile} = \case
 agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
 agentSubscriber = do
   q <- asks $ subQ . smpAgent
-  -- cQ <- asks chatQ
   forever $ do
     (_, connId, msg) <- atomically $ readTBQueue q
     user <- asks currentUser
@@ -123,14 +165,7 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do
         MSG meta msgBody -> do
           ChatMessage {chatMsgEvent, chatMsgBody} <- liftEither $ parseChatMessage msgBody
           case chatMsgEvent of
-            XMsgNew MTText -> do
-              case find (isSimplexContentType XCText) chatMsgBody of
-                Just MsgBodyContent {contentData = MBFull (MsgData bs)} -> do
-                  let text = safeDecodeUtf8 bs
-                  showReceivedMessage c (snd $ broker meta) text (integrity meta)
-                  showToast ("@" <> c) text
-                  setActive $ ActiveC c
-                _ -> pure ()
+            XMsgNew MTText -> newTextMessage c meta $ find (isSimplexContentType XCText) chatMsgBody
             XInfo -> pure () -- TODO profile update
             _ -> pure ()
         CON -> do
@@ -154,6 +189,15 @@ processAgentMessage User {userId, profile} agentConnId agentMessage = do
         _ -> pure ()
     _ -> pure ()
   where
+    newTextMessage :: ContactRef -> MsgMeta -> Maybe MsgBodyContent -> m ()
+    newTextMessage c meta = \case
+      Just MsgBodyContent {contentData = MBFull (MsgData bs)} -> do
+        let text = safeDecodeUtf8 bs
+        showReceivedMessage c (snd $ broker meta) text (integrity meta)
+        showToast ("@" <> c) text
+        setActive $ ActiveC c
+      _ -> pure ()
+
     parseChatMessage :: ByteString -> Either ChatError ChatMessage
     parseChatMessage msgBody = first ChatErrorMessage (parseAll rawChatMessageP msgBody >>= toChatMessage)
 

src/Simplex/Chat/Controller.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Simplex.Chat.Controller where
@@ -11,7 +10,6 @@ import Control.Exception
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Reader
-import Numeric.Natural
 import Simplex.Chat.Notification
 import Simplex.Chat.Store (StoreError)
 import Simplex.Chat.Terminal
@@ -45,13 +43,6 @@ data ContactError = CENotFound ContactRef | CEProfile String
 
 type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
 
-newChatController :: AgentClient -> ChatTerminal -> SQLiteStore -> User -> (Notification -> IO ()) -> Natural -> STM ChatController
-newChatController smpAgent chatTerminal chatStore currentUser sendNotification qSize = do
-  inputQ <- newTBQueue qSize
-  notifyQ <- newTBQueue qSize
-  -- chatQ <- newTBQueue qSize
-  pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, inputQ, notifyQ, sendNotification}
-
 setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
 setActive to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to)
 

src/Simplex/Chat/Input.hs

@@ -24,9 +24,10 @@ getKey =
 runTerminalInput :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
 runTerminalInput = do
   ChatController {inputQ, chatTerminal = ct} <- ask
-  liftIO . withTerminal . runTerminalT $ do
-    updateInput ct
-    receiveFromTTY inputQ ct
+  liftIO $
+    withChatTerm ct $ do
+      updateInput ct
+      receiveFromTTY inputQ ct
 
 receiveFromTTY :: MonadTerminal m => TBQueue InputEvent -> ChatTerminal -> m ()
 receiveFromTTY inputQ ct@ChatTerminal {activeTo, termSize, termState} =

src/Simplex/Chat/Terminal.hs

@@ -1,13 +1,18 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Simplex.Chat.Terminal where
 
+import Control.Monad.Catch (MonadMask)
+import Control.Monad.IO.Class (MonadIO)
 import Simplex.Chat.Styled
 import Simplex.Chat.Types
 import System.Console.ANSI.Types
 import System.Terminal
+import System.Terminal.Internal (LocalTerminal, Terminal, VirtualTerminal)
 import UnliftIO.STM
 
 data ActiveTo = ActiveNone | ActiveC ContactRef
@@ -15,6 +20,7 @@ data ActiveTo = ActiveNone | ActiveC ContactRef
 
 data ChatTerminal = ChatTerminal
   { activeTo :: TVar ActiveTo,
+    termDevice :: TerminalDevice,
     termState :: TVar TerminalState,
     termSize :: Size,
     nextMessageRow :: TVar Int,
@@ -28,16 +34,30 @@ data TerminalState = TerminalState
     previousInput :: String
   }
 
-newChatTerminal :: IO ChatTerminal
-newChatTerminal = do
+class Terminal t => WithTerminal t where
+  withTerm :: (MonadIO m, MonadMask m) => t -> (t -> m a) -> m a
+
+data TerminalDevice = forall t. WithTerminal t => TerminalDevice t
+
+instance WithTerminal LocalTerminal where
+  withTerm _ = withTerminal
+
+instance WithTerminal VirtualTerminal where
+  withTerm t = ($ t)
+
+withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
+withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
+
+newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
+newChatTerminal t = do
   activeTo <- newTVarIO ActiveNone
-  termSize <- withTerminal . runTerminalT $ getWindowSize
+  termSize <- withTerm t . runTerminalT $ getWindowSize
   let lastRow = height termSize - 1
   termState <- newTVarIO newTermState
   termLock <- newTMVarIO ()
   nextMessageRow <- newTVarIO lastRow
   -- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
-  return ChatTerminal {activeTo, termState, termSize, nextMessageRow, termLock}
+  return ChatTerminal {activeTo, termDevice = TerminalDevice t, termState, termSize, nextMessageRow, termLock}
 
 newTermState :: TerminalState
 newTermState =
@@ -55,9 +75,11 @@ withTermLock ChatTerminal {termLock} action = do
   atomically $ putTMVar termLock ()
 
 printToTerminal :: ChatTerminal -> [StyledString] -> IO ()
-printToTerminal ct s = withTerminal . runTerminalT . withTermLock ct $ do
-  printMessage ct s
-  updateInput ct
+printToTerminal ct s =
+  withChatTerm ct $
+    withTermLock ct $ do
+      printMessage ct s
+      updateInput ct
 
 updateInput :: forall m. MonadTerminal m => ChatTerminal -> m ()
 updateInput ChatTerminal {termSize = Size {height, width}, termState, nextMessageRow} = do

src/Simplex/Chat/View.hs

@@ -133,7 +133,7 @@ ttyContact :: ContactRef -> StyledString
 ttyContact = styled (Colored Green)
 
 ttyToContact :: ContactRef -> StyledString
-ttyToContact c = styled (Colored Cyan) $ c <> " "
+ttyToContact c = styled (Colored Cyan) $ "@" <> c <> " "
 
 ttyFromContact :: ContactRef -> StyledString
 ttyFromContact c = styled (Colored Yellow) $ c <> "> "

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"