diff --git a/apps/simplex-bot-advanced/Main.hs b/apps/simplex-bot-advanced/Main.hs index 0e270a45a6..bb81911913 100644 --- a/apps/simplex-bot-advanced/Main.hs +++ b/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" diff --git a/apps/simplex-bot/Main.hs b/apps/simplex-bot/Main.hs index 70faaf777e..1c322dbc18 100644 --- a/apps/simplex-bot/Main.hs +++ b/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) diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index b78d241aa1..0a94c77935 100644 --- a/apps/simplex-chat/Main.hs +++ b/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 diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 9dbb4b6a17..d83866cedf 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index c1f80c33f5..60fc60523e 100644 --- a/src/Simplex/Chat.hs +++ b/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 diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index 93845ba2f0..83a8be168e 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/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" diff --git a/src/Simplex/Chat/Core.hs b/src/Simplex/Chat/Core.hs new file mode 100644 index 0000000000..a4faaf876f --- /dev/null +++ b/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 diff --git a/src/Simplex/Chat/Mobile.hs b/src/Simplex/Chat/Mobile.hs index 0902c58bde..9869b3692c 100644 --- a/src/Simplex/Chat/Mobile.hs +++ b/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 diff --git a/src/Simplex/Chat/Terminal.hs b/src/Simplex/Chat/Terminal.hs index 1daab90035..4b1a6b8a4a 100644 --- a/src/Simplex/Chat/Terminal.hs +++ b/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] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 28f44e294c..57143e7d8f 100644 --- a/tests/ChatClient.hs +++ b/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}