diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index fd788bf5d4..e618a0c3de 100644 --- a/apps/simplex-chat/Main.hs +++ b/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 diff --git a/package.yaml b/package.yaml index 1dc6b766d7..a838be3c2f 100644 --- a/package.yaml +++ b/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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 981c2e608d..51fbdbb11d 100644 --- a/src/Simplex/Chat.hs +++ b/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) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index fb08a64f60..9d39b28fca 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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) diff --git a/src/Simplex/Chat/Input.hs b/src/Simplex/Chat/Input.hs index 8da7c679f8..7623c40d47 100644 --- a/src/Simplex/Chat/Input.hs +++ b/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} = diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index 5451846665..d3d5cec6ef 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index e305e09902..0a34d67c4a 100644 --- a/src/Simplex/Chat/View.hs +++ b/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 <> "> " diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs new file mode 100644 index 0000000000..4b5907ee77 --- /dev/null +++ b/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 diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs new file mode 100644 index 0000000000..cfd626a744 --- /dev/null +++ b/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 diff --git a/tests/Test.hs b/tests/Test.hs index 2575ec5eb9..f9c0b770e0 100644 --- a/tests/Test.hs +++ b/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"