mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
chat prototype (#35)
* chat prototype * chat prototype now compiles * chat prototype works * agent: respond SENT mId to SEND (instead of OK), ne repsonse to chat message in terminal * chat prototype help, update commands * chat CLI options * add active contact to ChatClient (not used yet) * refactor agentTransmission * InviteContact -> AddContact * automatically insert active contact * highlight contact in chat * name for invitations * do not ask name on start * change default server to smp.simplex.im
This commit is contained in:
Evgeny Poberezkin
Efim Poberezkin
@@ -0,0 +1,56 @@
|
||||
module ChatOptions (getChatOpts, ChatOpts (..)) where
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Options.Applicative
|
||||
import Simplex.Messaging.Agent.Transmission (SMPServer (..), smpServerP)
|
||||
|
||||
data ChatOpts = ChatOpts
|
||||
{ name :: Maybe B.ByteString,
|
||||
dbFileName :: String,
|
||||
smpServer :: SMPServer
|
||||
}
|
||||
|
||||
chatOpts :: Parser ChatOpts
|
||||
chatOpts =
|
||||
ChatOpts
|
||||
<$> option
|
||||
parseName
|
||||
( long "name"
|
||||
<> short 'n'
|
||||
<> metavar "NAME"
|
||||
<> help "optional name to use for invitations"
|
||||
<> value Nothing
|
||||
)
|
||||
<*> strOption
|
||||
( long "database"
|
||||
<> short 'd'
|
||||
<> metavar "DB_FILE"
|
||||
<> help "sqlite database filename (smp-chat.db)"
|
||||
<> value "smp-chat.db"
|
||||
)
|
||||
<*> option
|
||||
parseSMPServer
|
||||
( long "server"
|
||||
<> short 's'
|
||||
<> metavar "SERVER"
|
||||
<> help "SMP server to use (localhost:5223)"
|
||||
<> value (SMPServer "smp.simplex.im" (Just "5223") Nothing)
|
||||
)
|
||||
|
||||
parseName :: ReadM (Maybe B.ByteString)
|
||||
parseName = maybeReader $ Just . Just . B.pack
|
||||
|
||||
parseSMPServer :: ReadM SMPServer
|
||||
parseSMPServer = eitherReader $ A.parseOnly (smpServerP <* A.endOfInput) . B.pack
|
||||
|
||||
getChatOpts :: IO ChatOpts
|
||||
getChatOpts = execParser opts
|
||||
where
|
||||
opts =
|
||||
info
|
||||
(chatOpts <**> helper)
|
||||
( fullDesc
|
||||
<> header "Chat prototype using Simplex Messaging Protocol (SMP)"
|
||||
<> progDesc "Start chat with DB_FILE file and use SERVER as SMP server"
|
||||
)
|
||||
@@ -0,0 +1,257 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import ChatOptions
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.STM
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad.Reader
|
||||
import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding
|
||||
import Numeric.Natural
|
||||
import Simplex.Messaging.Agent (getSMPAgentClient, runSMPAgentClient)
|
||||
import Simplex.Messaging.Agent.Client (AgentClient (..))
|
||||
import Simplex.Messaging.Agent.Env.SQLite
|
||||
import Simplex.Messaging.Agent.Transmission
|
||||
import Simplex.Messaging.Client (smpDefaultConfig)
|
||||
import Simplex.Messaging.Transport (getLn, putLn)
|
||||
import Simplex.Messaging.Util (bshow, raceAny_)
|
||||
import qualified System.Console.ANSI as C
|
||||
import System.IO
|
||||
|
||||
cfg :: AgentConfig
|
||||
cfg =
|
||||
AgentConfig
|
||||
{ tcpPort = undefined, -- TODO maybe take it out of config
|
||||
tbqSize = 16,
|
||||
connIdBytes = 12,
|
||||
dbFile = "smp-chat.db",
|
||||
smpCfg = smpDefaultConfig
|
||||
}
|
||||
|
||||
logCfg :: LogConfig
|
||||
logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
|
||||
|
||||
data ChatClient = ChatClient
|
||||
{ inQ :: TBQueue ChatCommand,
|
||||
outQ :: TBQueue ChatResponse,
|
||||
smpServer :: SMPServer,
|
||||
activeContact :: TVar (Maybe Contact),
|
||||
username :: TVar (Maybe Contact)
|
||||
}
|
||||
|
||||
newtype Contact = Contact {toBs :: ByteString}
|
||||
|
||||
-- | GroupMessage ChatGroup ByteString
|
||||
-- | AddToGroup Contact
|
||||
data ChatCommand
|
||||
= ChatHelp
|
||||
| AddContact Contact
|
||||
| AcceptContact Contact SMPQueueInfo
|
||||
| ChatWith Contact
|
||||
| SetName Contact
|
||||
| SendMessage Contact ByteString
|
||||
|
||||
chatCommandP :: Parser ChatCommand
|
||||
chatCommandP =
|
||||
"/help" $> ChatHelp
|
||||
<|> "/add " *> (AddContact <$> contact)
|
||||
<|> "/accept " *> acceptContact
|
||||
<|> "/chat " *> chatWith
|
||||
<|> "/name " *> setName
|
||||
<|> "@" *> sendMessage
|
||||
where
|
||||
acceptContact = AcceptContact <$> contact <* A.space <*> smpQueueInfoP
|
||||
chatWith = ChatWith <$> contact
|
||||
setName = SetName <$> contact
|
||||
sendMessage = SendMessage <$> contact <* A.space <*> A.takeByteString
|
||||
contact = Contact <$> A.takeTill (== ' ')
|
||||
|
||||
data ChatResponse
|
||||
= ChatHelpInfo
|
||||
| Invitation SMPQueueInfo
|
||||
| Connected Contact
|
||||
| ReceivedMessage Contact ByteString
|
||||
| Disconnected Contact
|
||||
| YesYes
|
||||
| ErrorInput ByteString
|
||||
| ChatError AgentErrorType
|
||||
| NoChatResponse
|
||||
|
||||
serializeChatResponse :: Maybe Contact -> ChatResponse -> ByteString
|
||||
serializeChatResponse name = \case
|
||||
ChatHelpInfo -> chatHelpInfo
|
||||
Invitation qInfo -> "ask your contact to enter: /accept " <> showName name <> " " <> serializeSmpQueueInfo qInfo
|
||||
Connected c -> ttyContact c <> " connected"
|
||||
ReceivedMessage c t -> ttyContact c <> ": " <> t
|
||||
Disconnected c -> "disconnected from " <> ttyContact c <> " - try \"/chat " <> toBs c <> "\""
|
||||
YesYes -> "you got it!"
|
||||
ErrorInput t -> "invalid input: " <> t
|
||||
ChatError e -> "chat error: " <> bshow e
|
||||
NoChatResponse -> ""
|
||||
where
|
||||
showName Nothing = "<your name>"
|
||||
showName (Just (Contact a)) = a
|
||||
|
||||
chatHelpInfo :: ByteString
|
||||
chatHelpInfo =
|
||||
"Using chat:\n\
|
||||
\/add <name> - create invitation to send out-of-band\n\
|
||||
\ to your contact <name>\n\
|
||||
\ (any unique string without spaces)\n\
|
||||
\/accept <name> <invitation> - accept <invitation>\n\
|
||||
\ (a string that starts from \"smp::\")\n\
|
||||
\ from your contact <name>\n\
|
||||
\/chat <name> - resume chat with <name>\n\
|
||||
\/name <name> - set <name> to use in invitations\n\
|
||||
\@<name> <message> - send <message> (any string) to contact <name>\n\
|
||||
\ @<name> can be omitted to send to previous"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
ChatOpts {dbFileName, smpServer, name} <- getChatOpts
|
||||
putStrLn "simpleX chat prototype (no encryption), \"/help\" for usage information"
|
||||
t <- getChatClient smpServer (Contact <$> name)
|
||||
-- setLogLevel LogInfo -- LogError
|
||||
-- withGlobalLogging logCfg $
|
||||
env <- newSMPAgentEnv cfg {dbFile = dbFileName}
|
||||
dogFoodChat t env
|
||||
|
||||
dogFoodChat :: ChatClient -> Env -> IO ()
|
||||
dogFoodChat t env = do
|
||||
c <- runReaderT getSMPAgentClient env
|
||||
raceAny_
|
||||
[ runReaderT (runSMPAgentClient c) env,
|
||||
sendToAgent t c,
|
||||
sendToTTY t,
|
||||
receiveFromAgent t c,
|
||||
receiveFromTTY t
|
||||
]
|
||||
|
||||
getChatClient :: SMPServer -> Maybe Contact -> IO ChatClient
|
||||
getChatClient srv name = atomically $ newChatClient (tbqSize cfg) srv name
|
||||
|
||||
newChatClient :: Natural -> SMPServer -> Maybe Contact -> STM ChatClient
|
||||
newChatClient qSize smpServer name = do
|
||||
inQ <- newTBQueue qSize
|
||||
outQ <- newTBQueue qSize
|
||||
activeContact <- newTVar Nothing
|
||||
username <- newTVar name
|
||||
return ChatClient {inQ, outQ, smpServer, activeContact, username}
|
||||
|
||||
receiveFromTTY :: ChatClient -> IO ()
|
||||
receiveFromTTY t =
|
||||
forever $ getChatLn t >>= processOrError . A.parseOnly (chatCommandP <* A.endOfInput)
|
||||
where
|
||||
processOrError = \case
|
||||
Left err -> atomically . writeTBQueue (outQ t) . ErrorInput $ B.pack err
|
||||
Right ChatHelp -> atomically . writeTBQueue (outQ t) $ ChatHelpInfo
|
||||
Right (SetName a) -> atomically $ do
|
||||
writeTVar (username t) $ Just a
|
||||
writeTBQueue (outQ t) YesYes
|
||||
Right cmd -> atomically $ writeTBQueue (inQ t) cmd
|
||||
|
||||
sendToTTY :: ChatClient -> IO ()
|
||||
sendToTTY ChatClient {outQ, username} = forever $ do
|
||||
atomically (readTBQueue outQ) >>= \case
|
||||
NoChatResponse -> return ()
|
||||
resp -> do
|
||||
name <- readTVarIO username
|
||||
putLn stdout $ serializeChatResponse name resp
|
||||
|
||||
sendToAgent :: ChatClient -> AgentClient -> IO ()
|
||||
sendToAgent ChatClient {inQ, smpServer, activeContact} AgentClient {rcvQ} =
|
||||
forever . atomically $ do
|
||||
cmd <- readTBQueue inQ
|
||||
writeTBQueue rcvQ `mapM_` agentTransmission cmd
|
||||
setActiveContact cmd
|
||||
where
|
||||
setActiveContact :: ChatCommand -> STM ()
|
||||
setActiveContact cmd =
|
||||
writeTVar activeContact $ case cmd of
|
||||
ChatWith a -> Just a
|
||||
SendMessage a _ -> Just a
|
||||
_ -> Nothing
|
||||
agentTransmission :: ChatCommand -> Maybe (ATransmission 'Client)
|
||||
agentTransmission = \case
|
||||
AddContact a -> transmission a $ NEW smpServer
|
||||
AcceptContact a qInfo -> transmission a $ JOIN qInfo $ ReplyVia smpServer
|
||||
ChatWith a -> transmission a SUB
|
||||
SendMessage a msg -> transmission a $ SEND msg
|
||||
ChatHelp -> Nothing
|
||||
SetName _ -> Nothing
|
||||
transmission :: Contact -> ACommand 'Client -> Maybe (ATransmission 'Client)
|
||||
transmission (Contact a) cmd = Just ("1", a, cmd)
|
||||
|
||||
receiveFromAgent :: ChatClient -> AgentClient -> IO ()
|
||||
receiveFromAgent t c = forever . atomically $ do
|
||||
resp <- chatResponse <$> readTBQueue (sndQ c)
|
||||
writeTBQueue (outQ t) resp
|
||||
setActiveContact resp
|
||||
where
|
||||
chatResponse :: ATransmission 'Agent -> ChatResponse
|
||||
chatResponse (_, a, resp) = case resp of
|
||||
INV qInfo -> Invitation qInfo
|
||||
CON -> Connected $ Contact a
|
||||
END -> Disconnected $ Contact a
|
||||
MSG {m_body} -> ReceivedMessage (Contact a) m_body
|
||||
SENT _ -> NoChatResponse
|
||||
OK -> YesYes
|
||||
ERR e -> ChatError e
|
||||
setActiveContact :: ChatResponse -> STM ()
|
||||
setActiveContact = \case
|
||||
Connected a -> set $ Just a
|
||||
ReceivedMessage a _ -> set $ Just a
|
||||
Disconnected _ -> set Nothing
|
||||
_ -> return ()
|
||||
where
|
||||
set a = writeTVar (activeContact t) a
|
||||
|
||||
getChatLn :: ChatClient -> IO ByteString
|
||||
getChatLn t = do
|
||||
setTTY NoBuffering
|
||||
getChar >>= \case
|
||||
'/' -> getRest "/"
|
||||
'@' -> getRest "@"
|
||||
ch -> do
|
||||
let s = encodeUtf8 $ T.singleton ch
|
||||
readTVarIO (activeContact t) >>= \case
|
||||
Nothing -> getRest s
|
||||
Just a -> getWithContact a s
|
||||
where
|
||||
getWithContact :: Contact -> ByteString -> IO ByteString
|
||||
getWithContact a s = do
|
||||
C.cursorBackward 1
|
||||
B.hPut stdout $ " " <> ttyContact a <> " " <> s
|
||||
getRest $ "@" <> toBs a <> " " <> s
|
||||
getRest :: ByteString -> IO ByteString
|
||||
getRest s = do
|
||||
setTTY LineBuffering
|
||||
(s <>) <$> getLn stdin
|
||||
|
||||
setTTY :: BufferMode -> IO ()
|
||||
setTTY mode = do
|
||||
hSetBuffering stdin mode
|
||||
hSetBuffering stdout mode
|
||||
|
||||
ttyContact :: Contact -> ByteString
|
||||
ttyContact (Contact a) = withSGR contactSGR $ "@" <> a
|
||||
|
||||
contactSGR :: [C.SGR]
|
||||
contactSGR = [C.SetColor C.Foreground C.Vivid C.Cyan]
|
||||
|
||||
withSGR :: [C.SGR] -> ByteString -> ByteString
|
||||
withSGR sgr s = B.pack (C.setSGRCode sgr) <> s <> B.pack (C.setSGRCode [C.Reset])
|
||||
Reference in New Issue
Block a user