terminal: refactor chat core used in terminal app and in bot examples (#516)

* terminal: refactor chat core used in terminal app and in bot examples

* fix tests

* refactor

apps/simplex-bot-advanced/Main.hs

@@ -14,6 +14,7 @@ import qualified Data.Text as T
 import Simplex.Chat
 import Simplex.Chat.Bot
 import Simplex.Chat.Controller
+import Simplex.Chat.Core
 import Simplex.Chat.Messages
 import Simplex.Chat.Options
 import Simplex.Chat.Types
@@ -23,7 +24,7 @@ import Text.Read
 main :: IO ()
 main = do
   opts <- welcomeGetOpts
-  simplexChatBot defaultChatConfig opts mySquaringBot
+  simplexChatCore defaultChatConfig opts Nothing mySquaringBot
 
 welcomeGetOpts :: IO ChatOpts
 welcomeGetOpts = do
@@ -50,5 +51,5 @@ mySquaringBot _user cc = do
           Just n -> msg <> " * " <> msg <> " = " <> show (n * n)
       _ -> pure ()
   where
-    sendMsg Contact {contactId} msg = sendCmd cc $ "/_send @" <> show contactId <> " text " <> msg
+    sendMsg Contact {contactId} msg = sendChatCmd cc $ "/_send @" <> show contactId <> " text " <> msg
     contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"

apps/simplex-bot/Main.hs

@@ -5,6 +5,7 @@ module Main where
 import Simplex.Chat
 import Simplex.Chat.Bot
 import Simplex.Chat.Controller (versionNumber)
+import Simplex.Chat.Core
 import Simplex.Chat.Options
 import System.Directory (getAppUserDataDirectory)
 import Text.Read
@@ -12,7 +13,7 @@ import Text.Read
 main :: IO ()
 main = do
   opts <- welcomeGetOpts
-  simplexChatBot defaultChatConfig opts $
+  simplexChatCore defaultChatConfig opts Nothing $
     chatBotRepl "Hello! I am a simple squaring bot - if you send me a number, I will calculate its square" $ \msg ->
       case readMaybe msg :: Maybe Integer of
         Just n -> msg <> " * " <> msg <> " = " <> show (n * n)

apps/simplex-chat/Main.hs

@@ -4,17 +4,14 @@ module Main where
 
 import Control.Concurrent (threadDelay)
 import Simplex.Chat
-import Simplex.Chat.Bot
-import Simplex.Chat.Controller (ChatConfig, versionNumber)
+import Simplex.Chat.Controller (versionNumber)
+import Simplex.Chat.Core
 import Simplex.Chat.Options
 import Simplex.Chat.Terminal
 import Simplex.Chat.View (serializeChatResponse)
 import System.Directory (getAppUserDataDirectory)
 import System.Terminal (withTerminal)
 
-cfg :: ChatConfig
-cfg = defaultChatConfig
-
 main :: IO ()
 main = do
   appDir <- getAppUserDataDirectory "simplex"
@@ -23,9 +20,9 @@ main = do
     then do
       welcome opts
       t <- withTerminal pure
-      simplexChat cfg opts t
-    else simplexChatBot cfg opts $ \_ cc -> do
-      r <- sendCmd cc chatCmd
+      simplexChatTerminal defaultChatConfig opts t
+    else simplexChatCore defaultChatConfig opts Nothing $ \_ cc -> do
+      r <- sendChatCmd cc chatCmd
       putStrLn $ serializeChatResponse r
       threadDelay $ chatCmdDelay opts * 1000000
 

simplex-chat.cabal

@@ -22,6 +22,7 @@ library
       Simplex.Chat
       Simplex.Chat.Bot
       Simplex.Chat.Controller
+      Simplex.Chat.Core
       Simplex.Chat.Help
       Simplex.Chat.Markdown
       Simplex.Chat.Messages

src/Simplex/Chat.hs

@@ -100,10 +100,11 @@ defaultSMPServers =
 logCfg :: LogConfig
 logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
 
-newChatController :: SQLiteStore -> Maybe User -> ChatConfig -> ChatOpts -> (Notification -> IO ()) -> IO ChatController
-newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize} ChatOpts {dbFilePrefix, smpServers, logConnections} sendNotification = do
+newChatController :: SQLiteStore -> Maybe User -> ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> IO ChatController
+newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize} ChatOpts {dbFilePrefix, smpServers, logConnections} sendToast = do
   let f = chatStoreFile dbFilePrefix
-  let config = cfg {subscriptionEvents = logConnections}
+      config = cfg {subscriptionEvents = logConnections}
+      sendNotification = fromMaybe (const $ pure ()) sendToast
   activeTo <- newTVarIO ActiveNone
   firstTime <- not <$> doesFileExist f
   currentUser <- newTVarIO user

src/Simplex/Chat/Bot.hs

@@ -7,40 +7,17 @@ module Simplex.Chat.Bot where
 
 import Control.Concurrent.Async
 import Control.Concurrent.STM
-import Control.Logger.Simple
 import Control.Monad.Reader
 import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
-import Simplex.Chat
 import Simplex.Chat.Controller
+import Simplex.Chat.Core
 import Simplex.Chat.Messages
-import Simplex.Chat.Options (ChatOpts (..))
 import Simplex.Chat.Store
 import Simplex.Chat.Types (Contact (..), User (..))
 import Simplex.Messaging.Encoding.String (strEncode)
 import System.Exit (exitFailure)
 
-simplexChatBot :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO ()
-simplexChatBot cfg@ChatConfig {dbPoolSize, yesToMigrations} opts chatBot
-  | logAgent opts = do
-    setLogLevel LogInfo -- LogError
-    withGlobalLogging logCfg initRun
-  | otherwise = initRun
-  where
-    initRun = do
-      let f = chatStoreFile $ dbFilePrefix opts
-      st <- createStore f dbPoolSize yesToMigrations
-      u <- getCreateActiveUser st
-      cc <- newChatController st (Just u) cfg opts (const $ pure ())
-      runSimplexChatBot u cc chatBot
-
-runSimplexChatBot :: User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
-runSimplexChatBot u cc chatBot = do
-  a1 <- async $ chatBot u cc
-  a2 <- runReaderT (startChatController u) cc
-  waitEither_ a1 a2
-
 chatBotRepl :: String -> (String -> String) -> User -> ChatController -> IO ()
 chatBotRepl welcome answer _user cc = do
   initializeBotAddress cc
@@ -55,23 +32,20 @@ chatBotRepl welcome answer _user cc = do
         void . sendMsg contact $ answer msg
       _ -> pure ()
   where
-    sendMsg Contact {contactId} msg = sendCmd cc $ "/_send @" <> show contactId <> " text " <> msg
+    sendMsg Contact {contactId} msg = sendChatCmd cc $ "/_send @" <> show contactId <> " text " <> msg
     contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
 
 initializeBotAddress :: ChatController -> IO ()
 initializeBotAddress cc = do
-  sendCmd cc "/show_address" >>= \case
+  sendChatCmd cc "/show_address" >>= \case
     CRUserContactLink uri _ -> showBotAddress uri
     CRChatCmdError (ChatErrorStore SEUserContactLinkNotFound) -> do
       putStrLn $ "No bot address, creating..."
-      sendCmd cc "/address" >>= \case
+      sendChatCmd cc "/address" >>= \case
         CRUserContactLinkCreated uri -> showBotAddress uri
         _ -> putStrLn "can't create bot address" >> exitFailure
     _ -> putStrLn "unexpected response" >> exitFailure
   where
     showBotAddress uri = do
       putStrLn $ "Bot's contact address is: " <> B.unpack (strEncode uri)
-      void $ sendCmd cc "/auto_accept on"
-
-sendCmd :: ChatController -> String -> IO ChatResponse
-sendCmd cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc
+      void $ sendChatCmd cc "/auto_accept on"

src/Simplex/Chat/Core.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Simplex.Chat.Core where
+
+import Control.Logger.Simple
+import Control.Monad.Reader
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import Simplex.Chat
+import Simplex.Chat.Controller
+import Simplex.Chat.Options (ChatOpts (..))
+import Simplex.Chat.Store
+import Simplex.Chat.Types
+import UnliftIO.Async
+
+simplexChatCore :: ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> (User -> ChatController -> IO ()) -> IO ()
+simplexChatCore cfg@ChatConfig {dbPoolSize, yesToMigrations} opts sendToast chat
+  | logAgent opts = do
+    setLogLevel LogInfo -- LogError
+    withGlobalLogging logCfg initRun
+  | otherwise = initRun
+  where
+    initRun = do
+      let f = chatStoreFile $ dbFilePrefix opts
+      st <- createStore f dbPoolSize yesToMigrations
+      u <- getCreateActiveUser st
+      cc <- newChatController st (Just u) cfg opts sendToast
+      runSimplexChat u cc chat
+
+runSimplexChat :: User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
+runSimplexChat u cc chat = do
+  a1 <- async $ chat u cc
+  a2 <- runReaderT (startChatController u) cc
+  waitEither_ a1 a2
+
+sendChatCmd :: ChatController -> String -> IO ChatResponse
+sendChatCmd cc s = runReaderT (execChatCommand . encodeUtf8 $ T.pack s) cc

src/Simplex/Chat/Mobile.hs

@@ -73,7 +73,7 @@ chatInit dbFilePrefix = do
   let f = chatStoreFile dbFilePrefix
   chatStore <- createStore f (dbPoolSize defaultMobileConfig) (yesToMigrations (defaultMobileConfig :: ChatConfig))
   user_ <- getActiveUser_ chatStore
-  newChatController chatStore user_ defaultMobileConfig mobileChatOpts {dbFilePrefix} (const $ pure ())
+  newChatController chatStore user_ defaultMobileConfig mobileChatOpts {dbFilePrefix} Nothing
 
 chatSendCmd :: ChatController -> String -> IO JSONString
 chatSendCmd cc s = LB.unpack . J.encode . APIResponse Nothing <$> runReaderT (execChatCommand $ B.pack s) cc

src/Simplex/Chat/Terminal.hs

@@ -3,43 +3,23 @@
 
 module Simplex.Chat.Terminal where
 
-import Control.Logger.Simple
 import Control.Monad.Except
-import Control.Monad.Reader
-import Simplex.Chat
 import Simplex.Chat.Controller
+import Simplex.Chat.Core
 import Simplex.Chat.Help (chatWelcome)
 import Simplex.Chat.Options
-import Simplex.Chat.Store
 import Simplex.Chat.Terminal.Input
 import Simplex.Chat.Terminal.Notification
 import Simplex.Chat.Terminal.Output
-import Simplex.Chat.Types (User)
 import Simplex.Messaging.Util (raceAny_)
-import UnliftIO (async, waitEither_)
 
-simplexChat :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
-simplexChat cfg@ChatConfig {dbPoolSize, yesToMigrations} opts t
-  | logAgent opts = do
-    setLogLevel LogInfo -- LogError
-    withGlobalLogging logCfg initRun
-  | otherwise = initRun
-  where
-    initRun = do
-      sendNotification' <- initializeNotifications
-      let f = chatStoreFile $ dbFilePrefix opts
-      st <- createStore f dbPoolSize yesToMigrations
-      u <- getCreateActiveUser st
-      ct <- newChatTerminal t
-      cc <- newChatController st (Just u) cfg opts sendNotification'
-      runSimplexChat u ct cc
-
-runSimplexChat :: User -> ChatTerminal -> ChatController -> IO ()
-runSimplexChat u ct cc = do
-  when (firstTime cc) . printToTerminal ct $ chatWelcome u
-  a1 <- async $ runChatTerminal ct cc
-  a2 <- runReaderT (startChatController u) cc
-  waitEither_ a1 a2
+simplexChatTerminal :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
+simplexChatTerminal cfg opts t = do
+  sendToast <- initializeNotifications
+  simplexChatCore cfg opts (Just sendToast) $ \u cc -> do
+    ct <- newChatTerminal t
+    when (firstTime cc) . printToTerminal ct $ chatWelcome u
+    runChatTerminal ct cc
 
 runChatTerminal :: ChatTerminal -> ChatController -> IO ()
 runChatTerminal ct cc = raceAny_ [runTerminalInput ct cc, runTerminalOutput ct cc, runInputLoop ct cc]

tests/ChatClient.hs

@@ -18,6 +18,7 @@ import qualified Data.Text as T
 import Network.Socket
 import Simplex.Chat
 import Simplex.Chat.Controller (ChatConfig (..), ChatController (..))
+import Simplex.Chat.Core
 import Simplex.Chat.Options
 import Simplex.Chat.Store
 import Simplex.Chat.Terminal
@@ -46,7 +47,9 @@ opts =
     { dbFilePrefix = undefined,
       smpServers = ["smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=@localhost:5001"],
       logConnections = False,
-      logAgent = False
+      logAgent = False,
+      chatCmd = "",
+      chatCmdDelay = 3
     }
 
 termSettings :: VirtualTerminalSettings
@@ -83,8 +86,8 @@ virtualSimplexChat dbFilePrefix profile = do
   Right user <- runExceptT $ createUser st profile True
   t <- withVirtualTerminal termSettings pure
   ct <- newChatTerminal t
-  cc <- newChatController st (Just user) cfg opts {dbFilePrefix} (const $ pure ()) -- no notifications
-  chatAsync <- async $ runSimplexChat user ct cc
+  cc <- newChatController st (Just user) cfg opts {dbFilePrefix} Nothing -- no notifications
+  chatAsync <- async . runSimplexChat user cc . const $ runChatTerminal ct
   termQ <- newTQueueIO
   termAsync <- async $ readTerminalOutput t termQ
   pure TestCC {chatController = cc, virtualTerminal = t, chatAsync, termAsync, termQ}