chat test with VirtualTerminal (#72)

* chat test with VirtualTerminal

* disable chat test

* fix intermittently failing test

* simplify test

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 <> "> "