blade/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2024-12-17 17:20:21 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

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

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

* fix tests

* refactor
This commit is contained in:
Evgeny Poberezkin
2022-04-10 17:13:06 +01:00
committed by GitHub
parent 0ac9785e4b
commit fa313caa82
10 changed files with 73 additions and 77 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+4 -3
View File
@@ -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
+5 -31
View File
@@ -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
+38
View File
@@ -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
+1 -1
View File
@@ -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
+8 -28
View File
@@ -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]