use chat protocol and contacts in chat commands/messages (#66)
* chat types, chat protocol syntax idea * chat message syntax, raw message type * chat message format and parsing * raw chat message parsing test * add message parsing tests * interpret RawChatMessage * use chat message format when sending messages * save contacts and related connections to DB (WIP) * use contacts in all chat commands (add, connect, send, delete) * use contacts when receiving messages and notifications * handle contact not found error * automatically accept connection when CONF is received from the agent
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
c3d5797a0b
commit
2f604d91ba
@@ -31,6 +31,7 @@ cfg =
|
||||
connIdBytes = 12,
|
||||
tbqSize = 16,
|
||||
dbFile = "smp-chat.db",
|
||||
dbPoolSize = 4,
|
||||
smpCfg = smpDefaultConfig
|
||||
}
|
||||
|
||||
@@ -40,11 +41,11 @@ logCfg = LogConfig {lc_file = Nothing, lc_stderr = True}
|
||||
main :: IO ()
|
||||
main = do
|
||||
ChatOpts {dbFile, smpServers} <- welcomeGetOpts
|
||||
void $ createStore "simplex-chat.db" 4
|
||||
st <- createStore (dbFile <> ".chat.db") 4
|
||||
ct <- newChatTerminal
|
||||
a <- getSMPAgentClient cfg {dbFile, smpServers}
|
||||
a <- getSMPAgentClient cfg {dbFile = dbFile <> ".agent.db", smpServers}
|
||||
notify <- initializeNotifications
|
||||
cc <- atomically $ newChatController a ct notify $ tbqSize cfg
|
||||
cc <- atomically $ newChatController a ct st notify $ tbqSize cfg
|
||||
-- setLogLevel LogInfo -- LogError
|
||||
-- withGlobalLogging logCfg $ do
|
||||
runReaderT simplexChat cc
|
||||
|
||||
@@ -1,12 +1,15 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Simplex.Chat where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
@@ -14,29 +17,36 @@ import Data.Attoparsec.ByteString.Char8 (Parser)
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Styled (plain)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Help
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (raceAny_)
|
||||
import Simplex.Messaging.Util (bshow, raceAny_)
|
||||
import Simplex.Notification
|
||||
import Simplex.Store
|
||||
import Simplex.Terminal
|
||||
import Simplex.View
|
||||
import Types
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.STM
|
||||
|
||||
data ChatCommand
|
||||
= ChatHelp
|
||||
| MarkdownHelp
|
||||
| AddContact Contact
|
||||
| Connect Contact SMPQueueInfo
|
||||
| DeleteContact Contact
|
||||
| SendMessage Contact ByteString
|
||||
| AddContact (Maybe ContactRef)
|
||||
| Connect (Maybe ContactRef) SMPQueueInfo
|
||||
| DeleteContact ContactRef
|
||||
| SendMessage ContactRef ByteString
|
||||
deriving (Show)
|
||||
|
||||
runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
@@ -44,6 +54,7 @@ runChatController =
|
||||
raceAny_
|
||||
[ inputSubscriber,
|
||||
agentSubscriber,
|
||||
chatSubscriber,
|
||||
notificationSubscriber
|
||||
]
|
||||
|
||||
@@ -61,66 +72,136 @@ inputSubscriber = do
|
||||
SendMessage c msg -> showSentMessage c msg
|
||||
_ -> printToView [plain s]
|
||||
runExceptT (processChatCommand cmd) >>= \case
|
||||
Left (ChatErrorAgent c e) -> showAgentError c e
|
||||
Left e -> showChatError e
|
||||
_ -> pure ()
|
||||
|
||||
processChatCommand :: ChatMonad m => ChatCommand -> m ()
|
||||
processChatCommand = \case
|
||||
ChatHelp -> printToView chatHelpInfo
|
||||
MarkdownHelp -> printToView markdownInfo
|
||||
AddContact c -> do
|
||||
(_, qInfo) <- withAgent c (`createConnection` Just (fromContact c))
|
||||
showInvitation c qInfo
|
||||
Connect c qInfo ->
|
||||
void . withAgent c $ \smp -> joinConnection smp (Just $ fromContact c) qInfo
|
||||
DeleteContact c -> do
|
||||
withAgent c (`deleteConnection` fromContact c)
|
||||
showContactDeleted c
|
||||
unsetActive' $ ActiveC c
|
||||
SendMessage c msg -> do
|
||||
void . withAgent c $ \smp -> sendMessage smp (fromContact c) msg
|
||||
setActive' $ ActiveC c
|
||||
AddContact cRef -> do
|
||||
(connId, qInfo) <- withAgent (fromMaybe "" cRef) createConnection
|
||||
userId <- asks currentUserId
|
||||
contact <- withStore $ \st -> createDirectContact st userId connId cRef
|
||||
showInvitation (localContactRef contact) qInfo
|
||||
Connect cRef qInfo -> do
|
||||
userId <- asks currentUserId
|
||||
connId <- withAgent (fromMaybe "" cRef) $ \agent -> joinConnection agent qInfo "user profile here"
|
||||
void $ withStore $ \st -> createDirectContact st userId connId cRef
|
||||
DeleteContact cRef -> do
|
||||
userId <- asks currentUserId
|
||||
conns <- withStore $ \st -> getContactConnections st userId cRef
|
||||
withAgent cRef $ \smp -> forM_ conns $ \Connection {agentConnId} ->
|
||||
deleteConnection smp agentConnId `catchError` \(_ :: AgentErrorType) -> pure ()
|
||||
void $ withStore $ \st -> deleteContact st userId cRef
|
||||
unsetActive $ ActiveC cRef
|
||||
when (null conns) . throwError . ChatErrorContact $ CENotFound cRef
|
||||
showContactDeleted cRef
|
||||
SendMessage cRef msg -> do
|
||||
userId <- asks currentUserId
|
||||
Connection {agentConnId} <- withStore $ \st -> getContactConnection st userId cRef
|
||||
let body = MsgBodyContent {contentType = SimplexContentType XCText, contentHash = Nothing, contentData = MBFull $ MsgData msg}
|
||||
rawMsg = rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent = XMsgNew MTText, chatMsgBody = [body], chatDAGIdx = Nothing}
|
||||
void . withAgent cRef $ \smp -> sendMessage smp agentConnId $ serializeRawChatMessage rawMsg
|
||||
setActive $ ActiveC cRef
|
||||
|
||||
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
agentSubscriber = do
|
||||
q <- asks $ subQ . smpAgent
|
||||
nQ <- asks notifyQ
|
||||
aQ <- asks $ subQ . smpAgent
|
||||
cQ <- asks chatQ
|
||||
forever $ do
|
||||
(_, a, resp) <- atomically (readTBQueue q)
|
||||
let notify = \text -> atomically $ writeTBQueue nQ Notification {title = "@" <> a, text}
|
||||
case resp of
|
||||
CON -> do
|
||||
showContactConnected $ Contact a
|
||||
setActive' $ ActiveC $ Contact a
|
||||
END -> do
|
||||
showContactDisconnected $ Contact a
|
||||
notify "disconnected"
|
||||
unsetActive' $ ActiveC $ Contact a
|
||||
MSG {brokerMeta, msgBody, msgIntegrity} -> do
|
||||
-- ReceivedMessage contact (snd brokerMeta) msgBody msgIntegrity
|
||||
showReceivedMessage (Contact a) (snd brokerMeta) msgBody msgIntegrity
|
||||
notify msgBody
|
||||
setActive' $ ActiveC $ Contact a
|
||||
(_, agentConnId, resp) <- atomically (readTBQueue aQ)
|
||||
userId <- asks currentUserId
|
||||
runExceptT (withStore $ \st -> getConnectionChatDirection st userId agentConnId) >>= \case
|
||||
-- TODO handle errors
|
||||
Left e -> liftIO $ print e
|
||||
Right chatDirection -> do
|
||||
case resp of
|
||||
MSG agentMsgMeta msgBody -> do
|
||||
atomically . writeTBQueue cQ $
|
||||
case first B.pack (parseAll rawChatMessageP msgBody) >>= toChatMessage of
|
||||
Right chatMessage -> ChatTransmission {agentMsgMeta, chatDirection, chatMessage}
|
||||
Left msgError -> ChatTransmissionError {agentMsgMeta, chatDirection, msgBody, msgError}
|
||||
agentMessage ->
|
||||
atomically $ writeTBQueue cQ AgentTransmission {agentConnId, chatDirection, agentMessage}
|
||||
|
||||
chatSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
chatSubscriber = do
|
||||
cQ <- asks chatQ
|
||||
forever $
|
||||
atomically (readTBQueue cQ) >>= \case
|
||||
ChatTransmission
|
||||
{ agentMsgMeta = meta,
|
||||
chatDirection = ReceivedDirectMessage Contact {localContactRef = c},
|
||||
chatMessage = ChatMessage {chatMsgEvent, chatMsgBody}
|
||||
} ->
|
||||
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 ()
|
||||
_ -> pure ()
|
||||
AgentTransmission {agentConnId, chatDirection = ReceivedDirectMessage Contact {localContactRef = c}, agentMessage} ->
|
||||
case agentMessage of
|
||||
CONF confId _ ->
|
||||
-- TODO save profile? Show confirmation?
|
||||
void . runExceptT . withAgent c $ \a -> allowConnection a agentConnId confId "user profile here"
|
||||
CON -> do
|
||||
showContactConnected c
|
||||
showToast ("@" <> c) "connected"
|
||||
setActive $ ActiveC c
|
||||
END -> do
|
||||
showContactDisconnected c
|
||||
showToast ("@" <> c) "disconnected"
|
||||
unsetActive $ ActiveC c
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
|
||||
showToast :: (MonadUnliftIO m, MonadReader ChatController m) => Text -> Text -> m ()
|
||||
showToast title text = atomically . (`writeTBQueue` Notification {title, text}) =<< asks notifyQ
|
||||
|
||||
notificationSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
notificationSubscriber = do
|
||||
ChatController {notifyQ, sendNotification} <- ask
|
||||
forever $ atomically (readTBQueue notifyQ) >>= liftIO . sendNotification
|
||||
|
||||
withAgent :: ChatMonad m => Contact -> (AgentClient -> ExceptT AgentErrorType m a) -> m a
|
||||
withAgent :: ChatMonad m => ContactRef -> (AgentClient -> ExceptT AgentErrorType m a) -> m a
|
||||
withAgent c action =
|
||||
asks smpAgent
|
||||
>>= runExceptT . action
|
||||
>>= liftEither . first (ChatErrorAgent c)
|
||||
|
||||
withStore ::
|
||||
ChatMonad m =>
|
||||
(forall m'. (MonadUnliftIO m', MonadError StoreError m') => SQLiteStore -> m' a) ->
|
||||
m a
|
||||
withStore action = do
|
||||
st <- asks chatStore
|
||||
runExceptT (action st `E.catch` handleInternal) >>= \case
|
||||
Right c -> pure c
|
||||
Left e -> throwError $ storeError e
|
||||
where
|
||||
-- TODO when parsing exception happens in store, the agent hangs;
|
||||
-- changing SQLError to SomeException does not help
|
||||
handleInternal :: (MonadError StoreError m') => E.SomeException -> m' a
|
||||
handleInternal e = throwError . SEInternal $ bshow e
|
||||
storeError :: StoreError -> ChatError
|
||||
storeError = \case
|
||||
SEContactNotFound c -> ChatErrorContact $ CENotFound c
|
||||
e -> ChatErrorStore e
|
||||
|
||||
chatCommandP :: Parser ChatCommand
|
||||
chatCommandP =
|
||||
("/help" <|> "/h") $> ChatHelp
|
||||
<|> ("/add " <|> "/a ") *> (AddContact <$> contact)
|
||||
<|> ("/connect " <|> "/c ") *> (Connect <$> contact <* A.space <*> smpQueueInfoP)
|
||||
<|> ("/delete " <|> "/d ") *> (DeleteContact <$> contact)
|
||||
<|> A.char '@' *> (SendMessage <$> contact <* A.space <*> A.takeByteString)
|
||||
<|> ("/add" <|> "/a") *> (AddContact <$> optional (A.space *> contactRef))
|
||||
<|> ("/connect" <|> "/c") *> ((Connect <$> optional (A.space *> contactRef) <*> qInfo) <|> (Connect Nothing <$> qInfo))
|
||||
<|> ("/delete " <|> "/d ") *> (DeleteContact <$> contactRef)
|
||||
<|> A.char '@' *> (SendMessage <$> contactRef <*> (A.space *> A.takeByteString))
|
||||
<|> ("/markdown" <|> "/m") $> MarkdownHelp
|
||||
where
|
||||
contact = Contact <$> A.takeTill (== ' ')
|
||||
contactRef = safeDecodeUtf8 <$> A.takeTill (== ' ')
|
||||
qInfo = A.space *> smpQueueInfoP
|
||||
|
||||
@@ -10,16 +10,22 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Numeric.Natural
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent (AgentClient)
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
|
||||
import Simplex.Notification
|
||||
import Simplex.Store (StoreError)
|
||||
import Simplex.Terminal
|
||||
import Types
|
||||
import UnliftIO.STM
|
||||
|
||||
data ChatController = ChatController
|
||||
{ smpAgent :: AgentClient,
|
||||
{ currentUserId :: UserId,
|
||||
smpAgent :: AgentClient,
|
||||
chatTerminal :: ChatTerminal,
|
||||
chatStore :: SQLiteStore,
|
||||
chatQ :: TBQueue ChatTransmission,
|
||||
inputQ :: TBQueue InputEvent,
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO ()
|
||||
@@ -27,21 +33,28 @@ data ChatController = ChatController
|
||||
|
||||
data InputEvent = InputCommand String | InputControl Char
|
||||
|
||||
data ChatError = ChatErrorAgent Contact AgentErrorType
|
||||
data ChatError
|
||||
= ChatErrorContact ContactError
|
||||
| ChatErrorAgent ContactRef AgentErrorType
|
||||
| ChatErrorStore StoreError
|
||||
deriving (Show, Exception)
|
||||
|
||||
newtype ContactError = CENotFound ContactRef
|
||||
deriving (Show, Exception)
|
||||
|
||||
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
|
||||
|
||||
newChatController :: AgentClient -> ChatTerminal -> (Notification -> IO ()) -> Natural -> STM ChatController
|
||||
newChatController smpAgent chatTerminal sendNotification qSize = do
|
||||
newChatController :: AgentClient -> ChatTerminal -> SQLiteStore -> (Notification -> IO ()) -> Natural -> STM ChatController
|
||||
newChatController smpAgent chatTerminal chatStore sendNotification qSize = do
|
||||
inputQ <- newTBQueue qSize
|
||||
notifyQ <- newTBQueue qSize
|
||||
pure ChatController {smpAgent, chatTerminal, inputQ, notifyQ, sendNotification}
|
||||
chatQ <- newTBQueue qSize
|
||||
pure ChatController {currentUserId = 1, smpAgent, chatTerminal, chatStore, chatQ, inputQ, notifyQ, sendNotification}
|
||||
|
||||
setActive' :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
setActive' to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to)
|
||||
setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
setActive to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to)
|
||||
|
||||
unsetActive' :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
unsetActive' a = asks (activeTo . chatTerminal) >>= atomically . (`modifyTVar` unset)
|
||||
unsetActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
unsetActive a = asks (activeTo . chatTerminal) >>= atomically . (`modifyTVar` unset)
|
||||
where
|
||||
unset a' = if a == a' then ActiveNone else a'
|
||||
|
||||
@@ -6,13 +6,12 @@ module Simplex.Input where
|
||||
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.List (dropWhileEnd)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Terminal
|
||||
import System.Exit (exitSuccess)
|
||||
import System.Terminal hiding (insertChars)
|
||||
import Types
|
||||
import UnliftIO.STM
|
||||
|
||||
getKey :: MonadTerminal m => m (Key, Modifiers)
|
||||
@@ -80,8 +79,8 @@ updateTermState ac tw (key, ms) ts@TerminalState {inputString = s, inputPosition
|
||||
insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
|
||||
contactPrefix = case ac of
|
||||
ActiveNone -> ""
|
||||
ActiveC (Contact c) -> "@" <> B.unpack c <> " "
|
||||
ActiveG (Group g) -> "#" <> B.unpack g <> " "
|
||||
ActiveC c -> "@" <> T.unpack c <> " "
|
||||
-- ActiveG (Group g) -> "#" <> B.unpack g <> " "
|
||||
backDeleteChar
|
||||
| p == 0 || null s = ts
|
||||
| p >= length s = ts' (init s, length s - 1)
|
||||
|
||||
@@ -5,18 +5,16 @@
|
||||
module Simplex.Notification (Notification (..), initializeNotifications) where
|
||||
|
||||
import Control.Monad (void)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Char (toLower)
|
||||
import Data.List (isInfixOf)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Util (safeDecodeUtf8)
|
||||
import System.Directory (doesFileExist, getAppUserDataDirectory)
|
||||
import System.FilePath (combine)
|
||||
import System.Info (os)
|
||||
import System.Process (readCreateProcess, shell)
|
||||
|
||||
data Notification = Notification {title :: ByteString, text :: ByteString}
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
initializeNotifications :: IO (Notification -> IO ())
|
||||
initializeNotifications = case os of
|
||||
@@ -37,16 +35,16 @@ notify script notification =
|
||||
void $ readCreateProcess (shell . T.unpack $ script notification) ""
|
||||
|
||||
linuxScript :: Notification -> Text
|
||||
linuxScript Notification {title, text} = "notify-send \"" <> safeDecodeUtf8 title <> "\" \"" <> safeDecodeUtf8 text <> "\""
|
||||
linuxScript Notification {title, text} = "notify-send \"" <> title <> "\" \"" <> text <> "\""
|
||||
|
||||
macScript :: Notification -> Text
|
||||
macScript Notification {title, text} = "osascript -e 'display notification \"" <> safeDecodeUtf8 text <> "\" with title \"" <> safeDecodeUtf8 title <> "\"'"
|
||||
macScript Notification {title, text} = "osascript -e 'display notification \"" <> text <> "\" with title \"" <> title <> "\"'"
|
||||
|
||||
initWinNotify :: IO (Notification -> IO ())
|
||||
initWinNotify = notify . winScript <$> savePowershellScript
|
||||
|
||||
winScript :: FilePath -> Notification -> Text
|
||||
winScript path Notification {title, text} = "powershell.exe \"" <> T.pack path <> " \'" <> safeDecodeUtf8 title <> "\' \'" <> safeDecodeUtf8 text <> "\'\""
|
||||
winScript path Notification {title, text} = "powershell.exe \"" <> T.pack path <> " \'" <> title <> "\' \'" <> text <> "\'\""
|
||||
|
||||
savePowershellScript :: IO FilePath
|
||||
savePowershellScript = do
|
||||
|
||||
@@ -1,19 +1,46 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Simplex.Store where
|
||||
module Simplex.Store
|
||||
( SQLiteStore,
|
||||
StoreError (..),
|
||||
createStore,
|
||||
createDirectContact,
|
||||
deleteContact,
|
||||
getContactConnection,
|
||||
getContactConnections,
|
||||
getConnectionChatDirection,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad (replicateM_)
|
||||
import Control.Exception
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.FileEmbed (embedDir, makeRelativeToProject)
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (sortBy)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..))
|
||||
import qualified Database.SQLite.Simple as DB
|
||||
import Numeric.Natural (Natural)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), connectSQLiteStore, createSQLiteStore)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AParty (..), ConnId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction)
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
import Simplex.Messaging.Util (liftIOEither)
|
||||
import System.FilePath (takeBaseName, takeExtension)
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -25,17 +52,128 @@ migrations =
|
||||
sqlFile (file, _) = takeExtension file == ".sql"
|
||||
migration (file, qStr) = Migration {name = takeBaseName file, up = decodeUtf8 qStr}
|
||||
|
||||
data SQLitePool = SQLitePool
|
||||
{ dbFilePath :: FilePath,
|
||||
dbPool :: TBQueue DB.Connection,
|
||||
dbNew :: Bool
|
||||
}
|
||||
createStore :: FilePath -> Int -> IO SQLiteStore
|
||||
createStore dbFilePath poolSize = createSQLiteStore dbFilePath poolSize migrations
|
||||
|
||||
createStore :: FilePath -> Natural -> IO SQLitePool
|
||||
createStore dbFilePath poolSize = do
|
||||
SQLiteStore {dbConn = c, dbNew} <- createSQLiteStore dbFilePath migrations
|
||||
dbPool <- newTBQueueIO poolSize
|
||||
atomically $ writeTBQueue dbPool c
|
||||
replicateM_ (fromInteger $ toInteger $ poolSize - 1) $
|
||||
connectSQLiteStore dbFilePath >>= atomically . writeTBQueue dbPool . dbConn
|
||||
pure SQLitePool {dbFilePath, dbPool, dbNew}
|
||||
insertedRowId :: DB.Connection -> IO Int64
|
||||
insertedRowId db = fromOnly . head <$> DB.query_ db "SELECT last_insert_rowid();"
|
||||
|
||||
createDirectContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> Maybe Text -> m Contact
|
||||
createDirectContact st userId agentConnId contactRef =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO connections (user_id, agent_conn_id, conn_status) VALUES (?,?,?);" (userId, agentConnId, ConnNew)
|
||||
connId <- insertedRowId db
|
||||
let activeConn = Connection {connId, agentConnId, connLevel = 0, viaContact = Nothing, connStatus = ConnNew}
|
||||
-- TODO support undefined localContactRef (Nothing) - currently it would fail
|
||||
let localContactRef = fromMaybe "" contactRef
|
||||
DB.execute db "INSERT INTO contacts (user_id, local_contact_ref) VALUES (?,?);" (userId, localContactRef)
|
||||
contactId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO contact_connections (connection_id, contact_id, active) VALUES (?,?,1);" (connId, contactId)
|
||||
pure Contact {contactId, localContactRef, profile = Nothing, activeConn}
|
||||
|
||||
deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactRef -> m ()
|
||||
deleteContact st userId contactRef =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
forM_
|
||||
[ [sql|
|
||||
DELETE FROM connections
|
||||
WHERE user_id = :user_id AND connection_id IN (
|
||||
SELECT cc.connection_id
|
||||
FROM contact_connections AS cc
|
||||
JOIN contacts AS cs ON cs.contact_id = cc.contact_id
|
||||
WHERE local_contact_ref = :contact_ref
|
||||
);
|
||||
|],
|
||||
[sql|
|
||||
DELETE FROM contacts
|
||||
WHERE user_id = :user_id AND local_contact_ref = :contact_ref;
|
||||
|]
|
||||
]
|
||||
$ \q -> DB.executeNamed db q [":user_id" := userId, ":contact_ref" := contactRef]
|
||||
|
||||
getContactConnection :: (MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ContactRef -> m Connection
|
||||
getContactConnection st userId contactRef =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
connection
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status
|
||||
FROM connections AS c
|
||||
JOIN contact_connections AS cc ON cc.connection_id == c.connection_id
|
||||
JOIN contacts AS cs ON cc.contact_id == cs.contact_id
|
||||
WHERE c.user_id = :user_id
|
||||
AND cs.user_id = :user_id
|
||||
AND cs.local_contact_ref == :contact_ref
|
||||
AND cc.active == 1;
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
where
|
||||
connection (connRow : _) = Right $ toConnection connRow
|
||||
connection _ = Left $ SEContactNotFound contactRef
|
||||
|
||||
getContactConnections :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactRef -> m [Connection]
|
||||
getContactConnections st userId contactRef =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
map toConnection
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.conn_status
|
||||
FROM connections AS c
|
||||
JOIN contact_connections AS cc ON cc.connection_id == c.connection_id
|
||||
JOIN contacts AS cs ON cc.contact_id == cs.contact_id
|
||||
WHERE c.user_id = :user_id
|
||||
AND cs.user_id = :user_id
|
||||
AND cs.local_contact_ref == :contact_ref
|
||||
AND cc.active == 1;
|
||||
|]
|
||||
[":user_id" := userId, ":contact_ref" := contactRef]
|
||||
|
||||
toConnection :: (Int64, ConnId, Int, Maybe Int64, ConnStatus) -> Connection
|
||||
toConnection (connId, agentConnId, connLevel, viaContact, connStatus) =
|
||||
Connection {connId, agentConnId, connLevel, viaContact, connStatus}
|
||||
|
||||
getConnectionChatDirection ::
|
||||
(MonadUnliftIO m, MonadError StoreError m) => SQLiteStore -> UserId -> ConnId -> m (ChatDirection 'Agent)
|
||||
getConnectionChatDirection st userId agentConnId =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
chatDirection
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
cs.contact_id, cs.local_contact_ref,
|
||||
a.connection_id, a.conn_level, a.via_contact, a.conn_status,
|
||||
p.contact_profile_id, p.contact_ref, p.display_name
|
||||
FROM contacts AS cs
|
||||
JOIN contact_connections AS cc ON cs.contact_id = cc.contact_id
|
||||
JOIN contact_connections AS ac ON cs.contact_id = ac.contact_id
|
||||
JOIN connections AS c ON c.connection_id = cc.connection_id
|
||||
JOIN connections AS a ON a.connection_id = ac.connection_id
|
||||
LEFT JOIN contact_profiles AS p ON p.contact_profile_id = cs.contact_profile_id
|
||||
WHERE cs.user_id = :user_id
|
||||
AND c.agent_conn_id = :agent_conn_id
|
||||
AND ac.active = 1
|
||||
|]
|
||||
[":user_id" := userId, ":agent_conn_id" := agentConnId]
|
||||
where
|
||||
chatDirection :: [ChatDirRow] -> Either StoreError (ChatDirection 'Agent)
|
||||
chatDirection [d] = Right $ toChatDirection agentConnId d
|
||||
chatDirection _ = Left SEConnectionNotFound
|
||||
|
||||
type ChatDirRow = (Int64, Text, Int64, Int, Maybe Int64, ConnStatus, Maybe Int64, Maybe ContactRef, Maybe Text)
|
||||
|
||||
toChatDirection :: ConnId -> ChatDirRow -> ChatDirection 'Agent
|
||||
toChatDirection
|
||||
agentConnId
|
||||
(contactId, localContactRef, connId, connLevel, viaContact, connStatus, profileId, contactRef, displayName) =
|
||||
let profile = Profile <$> profileId <*> contactRef <*> displayName
|
||||
activeConn = Connection {connId, agentConnId, connLevel, viaContact, connStatus}
|
||||
in ReceivedDirectMessage $ Contact {contactId, localContactRef, profile, activeConn}
|
||||
|
||||
data StoreError
|
||||
= SEContactNotFound ContactRef
|
||||
| SEConnectionNotFound
|
||||
| SEInternal ByteString
|
||||
deriving (Show, Exception)
|
||||
|
||||
@@ -5,12 +5,12 @@
|
||||
module Simplex.Terminal where
|
||||
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import System.Console.ANSI.Types
|
||||
import System.Terminal
|
||||
import Types
|
||||
import UnliftIO.STM
|
||||
|
||||
data ActiveTo = ActiveNone | ActiveC Contact | ActiveG Group
|
||||
data ActiveTo = ActiveNone | ActiveC ContactRef
|
||||
deriving (Eq)
|
||||
|
||||
data ChatTerminal = ChatTerminal
|
||||
|
||||
@@ -6,16 +6,12 @@
|
||||
module Simplex.View
|
||||
( printToView,
|
||||
showInvitation,
|
||||
showAgentError,
|
||||
showChatError,
|
||||
showContactDeleted,
|
||||
showContactConnected,
|
||||
showContactDisconnected,
|
||||
showReceivedMessage,
|
||||
showSentMessage,
|
||||
ttyContact,
|
||||
ttyFromContact,
|
||||
ttyGroup,
|
||||
ttyFromGroup,
|
||||
safeDecodeUtf8,
|
||||
)
|
||||
where
|
||||
@@ -24,6 +20,7 @@ import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Composition ((.:))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (DiffTime, UTCTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
@@ -31,36 +28,36 @@ import Data.Time.LocalTime (TimeZone, ZonedTime, getCurrentTimeZone, getZonedTim
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Terminal (printToTerminal)
|
||||
import Simplex.Util (safeDecodeUtf8)
|
||||
import System.Console.ANSI.Types
|
||||
import Types
|
||||
|
||||
type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m)
|
||||
|
||||
showInvitation :: ChatReader m => Contact -> SMPQueueInfo -> m ()
|
||||
showInvitation :: ChatReader m => ContactRef -> SMPQueueInfo -> m ()
|
||||
showInvitation = printToView .: invitation
|
||||
|
||||
showAgentError :: ChatReader m => Contact -> AgentErrorType -> m ()
|
||||
showAgentError = printToView .: agentError
|
||||
showChatError :: ChatReader m => ChatError -> m ()
|
||||
showChatError = printToView . chatError
|
||||
|
||||
showContactDeleted :: ChatReader m => Contact -> m ()
|
||||
showContactDeleted :: ChatReader m => ContactRef -> m ()
|
||||
showContactDeleted = printToView . contactDeleted
|
||||
|
||||
showContactConnected :: ChatReader m => Contact -> m ()
|
||||
showContactConnected :: ChatReader m => ContactRef -> m ()
|
||||
showContactConnected = printToView . contactConnected
|
||||
|
||||
showContactDisconnected :: ChatReader m => Contact -> m ()
|
||||
showContactDisconnected :: ChatReader m => ContactRef -> m ()
|
||||
showContactDisconnected = printToView . contactDisconnected
|
||||
|
||||
showReceivedMessage :: ChatReader m => Contact -> UTCTime -> ByteString -> MsgIntegrity -> m ()
|
||||
showReceivedMessage :: ChatReader m => ContactRef -> UTCTime -> Text -> MsgIntegrity -> m ()
|
||||
showReceivedMessage c utcTime msg mOk = printToView =<< liftIO (receivedMessage c utcTime msg mOk)
|
||||
|
||||
showSentMessage :: ChatReader m => Contact -> ByteString -> m ()
|
||||
showSentMessage :: ChatReader m => ContactRef -> ByteString -> m ()
|
||||
showSentMessage c msg = printToView =<< liftIO (sentMessage c msg)
|
||||
|
||||
invitation :: Contact -> SMPQueueInfo -> [StyledString]
|
||||
invitation :: ContactRef -> SMPQueueInfo -> [StyledString]
|
||||
invitation c qInfo =
|
||||
[ "pass this invitation to your contact " <> ttyContact c <> " (via any channel): ",
|
||||
"",
|
||||
@@ -69,16 +66,16 @@ invitation c qInfo =
|
||||
"and ask them to connect: /c <name_for_you> <invitation_above>"
|
||||
]
|
||||
|
||||
contactDeleted :: Contact -> [StyledString]
|
||||
contactDeleted :: ContactRef -> [StyledString]
|
||||
contactDeleted c = [ttyContact c <> " is deleted"]
|
||||
|
||||
contactConnected :: Contact -> [StyledString]
|
||||
contactConnected :: ContactRef -> [StyledString]
|
||||
contactConnected c = [ttyContact c <> " is connected"]
|
||||
|
||||
contactDisconnected :: Contact -> [StyledString]
|
||||
contactDisconnected :: ContactRef -> [StyledString]
|
||||
contactDisconnected c = ["disconnected from " <> ttyContact c <> " - restart chat"]
|
||||
|
||||
receivedMessage :: Contact -> UTCTime -> ByteString -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage :: ContactRef -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage c utcTime msg mOk = do
|
||||
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
|
||||
pure $ prependFirst (t <> " " <> ttyFromContact c) (msgPlain msg) ++ showIntegrity mOk
|
||||
@@ -104,43 +101,48 @@ receivedMessage c utcTime msg mOk = do
|
||||
msgError :: String -> [StyledString]
|
||||
msgError s = [styled (Colored Red) s]
|
||||
|
||||
sentMessage :: Contact -> ByteString -> IO [StyledString]
|
||||
sentMessage :: ContactRef -> ByteString -> IO [StyledString]
|
||||
sentMessage c msg = do
|
||||
time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
|
||||
pure $ prependFirst (styleTime time <> " " <> ttyToContact c) (msgPlain msg)
|
||||
pure $ prependFirst (styleTime time <> " " <> ttyToContact c) (msgPlain $ safeDecodeUtf8 msg)
|
||||
|
||||
prependFirst :: StyledString -> [StyledString] -> [StyledString]
|
||||
prependFirst s [] = [s]
|
||||
prependFirst s (s' : ss) = (s <> s') : ss
|
||||
|
||||
msgPlain :: ByteString -> [StyledString]
|
||||
msgPlain = map styleMarkdownText . T.lines . safeDecodeUtf8
|
||||
msgPlain :: Text -> [StyledString]
|
||||
msgPlain = map styleMarkdownText . T.lines
|
||||
|
||||
agentError :: Contact -> AgentErrorType -> [StyledString]
|
||||
agentError c = \case
|
||||
CONN e -> case e of
|
||||
NOT_FOUND -> ["no contact " <> ttyContact c]
|
||||
DUPLICATE -> ["contact " <> ttyContact c <> " already exists"]
|
||||
SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"]
|
||||
chatError :: ChatError -> [StyledString]
|
||||
chatError = \case
|
||||
ChatErrorContact e -> case e of
|
||||
CENotFound c -> ["no contact " <> ttyContact c]
|
||||
ChatErrorAgent c err -> case err of
|
||||
CONN e -> case e of
|
||||
-- TODO replace with ChatErrorContact errors, these errors should never happen
|
||||
NOT_FOUND -> ["no contact " <> ttyContact c]
|
||||
DUPLICATE -> ["contact " <> ttyContact c <> " already exists"]
|
||||
SIMPLEX -> ["contact " <> ttyContact c <> " did not accept invitation yet"]
|
||||
e -> ["smp agent error: " <> plain (show e)]
|
||||
e -> ["chat error: " <> plain (show e)]
|
||||
|
||||
printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m ()
|
||||
printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s)
|
||||
|
||||
ttyContact :: Contact -> StyledString
|
||||
ttyContact (Contact a) = styled (Colored Green) a
|
||||
ttyContact :: ContactRef -> StyledString
|
||||
ttyContact = styled (Colored Green)
|
||||
|
||||
ttyToContact :: Contact -> StyledString
|
||||
ttyToContact (Contact a) = styled (Colored Cyan) $ a <> " "
|
||||
ttyToContact :: ContactRef -> StyledString
|
||||
ttyToContact c = styled (Colored Cyan) $ c <> " "
|
||||
|
||||
ttyFromContact :: Contact -> StyledString
|
||||
ttyFromContact (Contact a) = styled (Colored Yellow) $ a <> "> "
|
||||
ttyFromContact :: ContactRef -> StyledString
|
||||
ttyFromContact c = styled (Colored Yellow) $ c <> "> "
|
||||
|
||||
ttyGroup :: Group -> StyledString
|
||||
ttyGroup (Group g) = styled (Colored Blue) $ "#" <> g
|
||||
-- ttyGroup :: Group -> StyledString
|
||||
-- ttyGroup (Group g) = styled (Colored Blue) $ "#" <> g
|
||||
|
||||
ttyFromGroup :: Group -> Contact -> StyledString
|
||||
ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> "
|
||||
-- ttyFromGroup :: Group -> Contact -> StyledString
|
||||
-- ttyFromGroup (Group g) (Contact a) = styled (Colored Yellow) $ "#" <> g <> " " <> a <> "> "
|
||||
|
||||
styleTime :: String -> StyledString
|
||||
styleTime = Styled [SetColor Foreground Vivid Black]
|
||||
|
||||
@@ -1,7 +0,0 @@
|
||||
module Types where
|
||||
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
|
||||
newtype Contact = Contact {fromContact :: ByteString} deriving (Eq, Show)
|
||||
|
||||
newtype Group = Group {fromGroup :: ByteString} deriving (Eq, Show)
|
||||
@@ -1,6 +1,7 @@
|
||||
CREATE TABLE contact_profiles ( -- remote user profile
|
||||
contact_profile_id INTEGER PRIMARY KEY,
|
||||
contact_ref TEXT NOT NULL, -- contact name set by remote user (not unique), this name must not contain spaces
|
||||
display_name TEXT NOT NULL DEFAULT '',
|
||||
properties TEXT NOT NULL DEFAULT '{}' -- JSON with contact profile properties
|
||||
);
|
||||
|
||||
@@ -21,7 +22,7 @@ CREATE TABLE known_servers(
|
||||
host TEXT NOT NULL,
|
||||
port TEXT NOT NULL,
|
||||
key_hash BLOB,
|
||||
user_id INTEGER NOT NULL REFERENCES user_id,
|
||||
user_id INTEGER NOT NULL REFERENCES users,
|
||||
UNIQUE (user_id, host, port)
|
||||
) WITHOUT ROWID;
|
||||
|
||||
@@ -30,22 +31,22 @@ CREATE TABLE contacts (
|
||||
local_contact_ref TEXT NOT NULL UNIQUE, -- contact name set by local user - must be unique
|
||||
local_properties TEXT NOT NULL DEFAULT '{}', -- JSON set by local user
|
||||
contact_profile_id INTEGER UNIQUE REFERENCES contact_profiles, -- profile sent by remote contact, NULL for incognito contacts
|
||||
contact_status TEXT NOT NULL DEFAULT '',
|
||||
user_id INTEGER NOT NULL REFERENCES user_id
|
||||
user_id INTEGER NOT NULL REFERENCES users
|
||||
);
|
||||
|
||||
CREATE TABLE connections ( -- all SMP agent connections
|
||||
connection_id INTEGER PRIMARY KEY,
|
||||
agent_conn_id BLOB NOT NULL UNIQUE,
|
||||
conn_level INTEGER NOT NULL DEFAULT 0,
|
||||
via_conn BLOB REFERENCES contact_connections (connection_id),
|
||||
conn_status TEXT NOT NULL DEFAULT '',
|
||||
user_id INTEGER NOT NULL REFERENCES user_id
|
||||
via_contact INTEGER REFERENCES contacts (contact_id),
|
||||
conn_status TEXT NOT NULL,
|
||||
user_id INTEGER NOT NULL REFERENCES users
|
||||
);
|
||||
|
||||
CREATE TABLE contact_connections ( -- connections only for direct messages, many per contact
|
||||
connection_id INTEGER NOT NULL UNIQUE REFERENCES connections ON DELETE CASCADE,
|
||||
contact_id INTEGER NOT NULL REFERENCES contacts ON DELETE RESTRICT -- connection must be removed first via the agent
|
||||
contact_id INTEGER REFERENCES contacts ON DELETE RESTRICT, -- connection must be removed first via the agent
|
||||
active INTEGER NOT NULL DEFAULT 0
|
||||
);
|
||||
|
||||
CREATE TABLE contact_invitations (
|
||||
@@ -59,17 +60,21 @@ CREATE TABLE contact_invitations (
|
||||
CREATE TABLE group_profiles ( -- shared group profiles
|
||||
group_profile_id INTEGER PRIMARY KEY,
|
||||
group_ref TEXT NOT NULL, -- this name must not contain spaces
|
||||
display_name TEXT NOT NULL DEFAULT '',
|
||||
properties TEXT NOT NULL DEFAULT '{}' -- JSON with user or contact profile
|
||||
);
|
||||
|
||||
CREATE TABLE groups (
|
||||
group_id INTEGER PRIMARY KEY, -- local group ID
|
||||
invited_by INTEGER REFERENCES contacts ON DELETE RESTRICT,
|
||||
external_group_id BLOB NOT NULL,
|
||||
local_group_ref TEXT NOT NULL UNIQUE, -- local group name without spaces
|
||||
local_properties TEXT NOT NULL, -- local JSON group properties
|
||||
group_profile_id INTEGER REFERENCES group_profiles, -- shared group profile
|
||||
user_group_member_details_id INTEGER NOT NULL
|
||||
REFERENCES group_member_details (group_member_details_id) ON DELETE RESTRICT,
|
||||
user_id INTEGER NOT NULL REFERENCES user_id
|
||||
user_id INTEGER NOT NULL REFERENCES users,
|
||||
UNIQUE (invited_by, external_group_id)
|
||||
);
|
||||
|
||||
CREATE TABLE group_members ( -- group members, excluding the local user
|
||||
@@ -97,6 +102,8 @@ CREATE TABLE events ( -- messages received by the agent, append only
|
||||
agent_meta TEXT NOT NULL, -- JSON with timestamps etc. sent in MSG
|
||||
connection_id INTEGER NOT NULL REFERENCES connections,
|
||||
received INTEGER NOT NULL, -- 0 for received, 1 for sent
|
||||
chat_event_id INTEGER,
|
||||
continuation_of INTEGER, -- references chat_event_id, but can be incorrect
|
||||
event_type TEXT NOT NULL, -- event type - see protocol/types.ts
|
||||
event_encoding INTEGER NOT NULL, -- format of event_body: 0 - binary, 1 - text utf8, 2 - JSON (utf8)
|
||||
content_type TEXT NOT NULL, -- content type - see protocol/types.ts
|
||||
@@ -108,6 +115,15 @@ CREATE TABLE events ( -- messages received by the agent, append only
|
||||
|
||||
CREATE INDEX events_external_msg_id_index ON events (connection_id, external_msg_id);
|
||||
|
||||
CREATE TABLE event_body_parts (
|
||||
event_body_part_id INTEGER PRIMARY KEY,
|
||||
event_id REFERENCES events,
|
||||
full_size INTEGER NOT NULL,
|
||||
part_status TEXT, -- full, partial
|
||||
content_type TEXT NOT NULL,
|
||||
event_part BLOB
|
||||
);
|
||||
|
||||
CREATE TABLE contact_profile_events (
|
||||
event_id INTEGER NOT NULL UNIQUE REFERENCES events,
|
||||
contact_profile_id INTEGER NOT NULL REFERENCES contact_profiles
|
||||
@@ -130,17 +146,12 @@ CREATE TABLE group_event_parents (
|
||||
parent_group_member_id INTEGER REFERENCES group_members (group_member_id), -- can be NULL if parent_member_id is incorrect
|
||||
parent_member_id BLOB, -- shared member ID, unique per group
|
||||
parent_event_id INTEGER REFERENCES events (event_id) ON DELETE CASCADE, -- this can be NULL if received event references another event that's not received yet
|
||||
parent_external_msg_id INTEGER NOT NULL,
|
||||
parent_chat_event_id INTEGER NOT NULL,
|
||||
parent_event_hash BLOB NOT NULL
|
||||
);
|
||||
|
||||
CREATE INDEX group_event_parents_parent_external_msg_id_index
|
||||
ON group_event_parents (parent_member_id, parent_external_msg_id);
|
||||
|
||||
CREATE TABLE blobs (
|
||||
blob_id INTEGER PRIMARY KEY,
|
||||
content BLOB NOT NULL
|
||||
);
|
||||
CREATE INDEX group_event_parents_parent_chat_event_id_index
|
||||
ON group_event_parents (parent_member_id, parent_chat_event_id);
|
||||
|
||||
CREATE TABLE messages ( -- mutable messages presented to user
|
||||
message_id INTEGER PRIMARY KEY,
|
||||
@@ -150,8 +161,16 @@ CREATE TABLE messages ( -- mutable messages presented to user
|
||||
msg_type TEXT NOT NULL,
|
||||
content_type TEXT NOT NULL,
|
||||
msg_text TEXT NOT NULL, -- textual representation
|
||||
msg_props TEXT NOT NULL, -- JSON
|
||||
msg_blob_id INTEGER REFERENCES blobs (blob_id) ON DELETE RESTRICT -- optional binary content
|
||||
msg_props TEXT NOT NULL -- JSON
|
||||
);
|
||||
|
||||
CREATE TABLE message_content (
|
||||
message_content_id INTEGER PRIMARY KEY,
|
||||
message_id INTEGER REFERENCES messages ON DELETE CASCADE,
|
||||
content_type TEXT NOT NULL,
|
||||
content_size INTEGER, -- full expected content size
|
||||
content_status TEXT, -- empty, part, full
|
||||
content BLOB NOT NULL
|
||||
);
|
||||
|
||||
CREATE TABLE message_events (
|
||||
|
||||
@@ -17,7 +17,9 @@ dependencies:
|
||||
- base >= 4.7 && < 5
|
||||
- bytestring == 0.10.*
|
||||
- containers == 0.6.*
|
||||
- mtl == 2.2.*
|
||||
- simplexmq == 0.3.*
|
||||
- sqlite-simple == 0.4.*
|
||||
- text == 1.2.*
|
||||
|
||||
library:
|
||||
@@ -29,6 +31,7 @@ executables:
|
||||
main: Main.hs
|
||||
dependencies:
|
||||
- simplex-chat
|
||||
- aeson == 1.5.*
|
||||
- async == 2.2.*
|
||||
- bytestring == 0.10.*
|
||||
- composition == 1.0.*
|
||||
|
||||
@@ -1,44 +1,267 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
module Simplex.Chat.Protocol where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Monad.Except (throwError)
|
||||
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.Int (Int64)
|
||||
import Data.List (findIndex)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Parsers (base64P)
|
||||
import Simplex.Messaging.Protocol (MsgBody)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
|
||||
data ChatEvent = GroupEvent | MessageEvent | InfoEvent
|
||||
data ChatTransmission
|
||||
= ChatTransmission
|
||||
{ agentMsgMeta :: MsgMeta,
|
||||
chatDirection :: ChatDirection 'Agent,
|
||||
chatMessage :: ChatMessage
|
||||
}
|
||||
| ChatTransmissionError
|
||||
{ agentMsgMeta :: MsgMeta,
|
||||
chatDirection :: ChatDirection 'Agent,
|
||||
msgBody :: MsgBody,
|
||||
msgError :: ByteString
|
||||
}
|
||||
| AgentTransmission
|
||||
{ agentConnId :: ConnId,
|
||||
chatDirection :: ChatDirection 'Agent,
|
||||
agentMessage :: ACommand 'Agent
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Profile = Profile
|
||||
{ profileId :: ByteString,
|
||||
displayName :: Text
|
||||
data ChatDirection (p :: AParty) where
|
||||
ReceivedDirectMessage :: Contact -> ChatDirection 'Agent
|
||||
SentDirectMessage :: Contact -> ChatDirection 'Client
|
||||
ReceivedGroupMessage :: Group -> Contact -> ChatDirection 'Agent
|
||||
SentGroupMessage :: Group -> ChatDirection 'Client
|
||||
|
||||
deriving instance Eq (ChatDirection p)
|
||||
|
||||
deriving instance Show (ChatDirection p)
|
||||
|
||||
newtype ChatMsgEvent = XMsgNew MessageType
|
||||
deriving (Eq, Show)
|
||||
|
||||
data MessageType = MTText | MTImage deriving (Eq, Show)
|
||||
|
||||
toMsgType :: ByteString -> Either ByteString MessageType
|
||||
toMsgType = \case
|
||||
"c.text" -> Right MTText
|
||||
"c.image" -> Right MTImage
|
||||
t -> Left $ "invalid message type " <> t
|
||||
|
||||
rawMsgType :: MessageType -> ByteString
|
||||
rawMsgType = \case
|
||||
MTText -> "c.text"
|
||||
MTImage -> "c.image"
|
||||
|
||||
data ChatMessage = ChatMessage
|
||||
{ chatMsgId :: Maybe Int64,
|
||||
chatMsgEvent :: ChatMsgEvent,
|
||||
chatMsgBody :: [MsgBodyContent],
|
||||
chatDAGIdx :: Maybe Int
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Contact = Contact
|
||||
{ contactId :: ByteString,
|
||||
profile :: Profile,
|
||||
connections :: [Connection]
|
||||
toChatMessage :: RawChatMessage -> Either ByteString ChatMessage
|
||||
toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do
|
||||
body <- mapM toMsgBodyContent chatMsgBody
|
||||
case chatMsgEvent of
|
||||
"x.msg.new" -> case chatMsgParams of
|
||||
[mt] -> do
|
||||
t <- toMsgType mt
|
||||
pure ChatMessage {chatMsgId, chatMsgEvent = XMsgNew t, chatMsgBody = body, chatDAGIdx = findDAG body}
|
||||
_ -> throwError "x.msg.new expects one parameter"
|
||||
_ -> throwError $ "unsupported event " <> chatMsgEvent
|
||||
toChatMessage _ = Left "message continuation"
|
||||
|
||||
findDAG :: [MsgBodyContent] -> Maybe Int
|
||||
findDAG = findIndex $ isContentType SimplexDAG
|
||||
|
||||
isContentType :: ContentType -> MsgBodyContent -> Bool
|
||||
isContentType t MsgBodyContent {contentType = t'} = t == t'
|
||||
|
||||
isSimplexContentType :: XContentType -> MsgBodyContent -> Bool
|
||||
isSimplexContentType = isContentType . SimplexContentType
|
||||
|
||||
rawChatMessage :: ChatMessage -> RawChatMessage
|
||||
rawChatMessage ChatMessage {chatMsgId, chatMsgEvent = event, chatMsgBody = body} =
|
||||
case event of
|
||||
XMsgNew t ->
|
||||
let chatMsgBody = map rawMsgBodyContent body
|
||||
in RawChatMessage {chatMsgId, chatMsgEvent = "x.msg.new", chatMsgParams = [rawMsgType t], chatMsgBody}
|
||||
|
||||
toMsgBodyContent :: RawMsgBodyContent -> Either ByteString MsgBodyContent
|
||||
toMsgBodyContent RawMsgBodyContent {contentType, contentHash, contentData} = do
|
||||
cType <- toContentType contentType
|
||||
pure MsgBodyContent {contentType = cType, contentHash, contentData}
|
||||
|
||||
rawMsgBodyContent :: MsgBodyContent -> RawMsgBodyContent
|
||||
rawMsgBodyContent MsgBodyContent {contentType = t, contentHash, contentData} =
|
||||
RawMsgBodyContent {contentType = rawContentType t, contentHash, contentData}
|
||||
|
||||
data MsgBodyContent = MsgBodyContent
|
||||
{ contentType :: ContentType,
|
||||
contentHash :: Maybe ByteString,
|
||||
contentData :: MsgBodyPartData
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Connection = Connection
|
||||
{ connId :: ConnId,
|
||||
connLevel :: Int,
|
||||
viaConn :: ConnId
|
||||
data ContentType
|
||||
= SimplexContentType XContentType
|
||||
| MimeContentType MContentType
|
||||
| SimplexDAG
|
||||
deriving (Eq, Show)
|
||||
|
||||
data XContentType = XCText | XCImage deriving (Eq, Show)
|
||||
|
||||
data MContentType = MCImageJPG | MCImagePNG deriving (Eq, Show)
|
||||
|
||||
toContentType :: RawContentType -> Either ByteString ContentType
|
||||
toContentType (RawContentType ns cType) = case ns of
|
||||
"x" -> case cType of
|
||||
"text" -> Right $ SimplexContentType XCText
|
||||
"image" -> Right $ SimplexContentType XCImage
|
||||
"dag" -> Right SimplexDAG
|
||||
_ -> err
|
||||
"m" -> case cType of
|
||||
"image/jpg" -> Right $ MimeContentType MCImageJPG
|
||||
"image/png" -> Right $ MimeContentType MCImagePNG
|
||||
_ -> err
|
||||
_ -> err
|
||||
where
|
||||
err = Left $ "invalid content type " <> ns <> "." <> cType
|
||||
|
||||
rawContentType :: ContentType -> RawContentType
|
||||
rawContentType t = case t of
|
||||
SimplexContentType t' -> RawContentType "x" $ case t' of
|
||||
XCText -> "text"
|
||||
XCImage -> "image"
|
||||
MimeContentType t' -> RawContentType "m" $ case t' of
|
||||
MCImageJPG -> "image/jpg"
|
||||
MCImagePNG -> "image/png"
|
||||
SimplexDAG -> RawContentType "x" "dag"
|
||||
|
||||
newtype ContentMsg = NewContentMsg ContentData
|
||||
|
||||
newtype ContentData = ContentText Text
|
||||
|
||||
data RawChatMessage
|
||||
= RawChatMessage
|
||||
{ chatMsgId :: Maybe Int64,
|
||||
chatMsgEvent :: ByteString,
|
||||
chatMsgParams :: [ByteString],
|
||||
chatMsgBody :: [RawMsgBodyContent]
|
||||
}
|
||||
| RawChatMsgContinuation
|
||||
{ prevChatMsgId :: Int64,
|
||||
continuationId :: Int,
|
||||
continuationData :: ByteString
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RawMsgBodyContent = RawMsgBodyContent
|
||||
{ contentType :: RawContentType,
|
||||
contentHash :: Maybe ByteString,
|
||||
contentData :: MsgBodyPartData
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data GroupMember = GroupMember
|
||||
{ groupId :: ByteString,
|
||||
sharedMemberId :: ByteString,
|
||||
contact :: Contact,
|
||||
memberRole :: GroupMemberRole,
|
||||
memberStatus :: GroupMemberStatus
|
||||
}
|
||||
data RawContentType = RawContentType NameSpace ByteString
|
||||
deriving (Eq, Show)
|
||||
|
||||
data GroupMemberRole = GROwner | GRAdmin | GRStandard
|
||||
type NameSpace = ByteString
|
||||
|
||||
data GroupMemberStatus = GSInvited | GSConnected | GSConnectedAll
|
||||
data MsgBodyPartData
|
||||
= -- | fully loaded
|
||||
MBFull MsgData
|
||||
| -- | partially loaded
|
||||
MBPartial Int MsgData
|
||||
| -- | not loaded yet
|
||||
MBEmpty Int
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Group = Group
|
||||
{ groupId :: ByteString,
|
||||
displayName :: Text,
|
||||
members :: [GroupMember]
|
||||
}
|
||||
data MsgData
|
||||
= MsgData ByteString
|
||||
| MsgDataRec {dataId :: Int64, dataSize :: Int}
|
||||
deriving (Eq, Show)
|
||||
|
||||
class DataLength a where
|
||||
dataLength :: a -> Int
|
||||
|
||||
instance DataLength MsgBodyPartData where
|
||||
dataLength (MBFull d) = dataLength d
|
||||
dataLength (MBPartial l _) = l
|
||||
dataLength (MBEmpty l) = l
|
||||
|
||||
instance DataLength MsgData where
|
||||
dataLength (MsgData s) = B.length s
|
||||
dataLength MsgDataRec {dataSize} = dataSize
|
||||
|
||||
rawChatMessageP :: Parser RawChatMessage
|
||||
rawChatMessageP = A.char '#' *> chatMsgContP <|> chatMsgP
|
||||
where
|
||||
chatMsgContP :: Parser RawChatMessage
|
||||
chatMsgContP = do
|
||||
prevChatMsgId <- A.decimal <* A.char '.'
|
||||
continuationId <- A.decimal <* A.space
|
||||
continuationData <- A.takeByteString
|
||||
pure RawChatMsgContinuation {prevChatMsgId, continuationId, continuationData}
|
||||
chatMsgP :: Parser RawChatMessage
|
||||
chatMsgP = do
|
||||
chatMsgId <- optional A.decimal <* A.space
|
||||
chatMsgEvent <- B.intercalate "." <$> identifier `A.sepBy1'` A.char '.' <* A.space
|
||||
chatMsgParams <- A.takeWhile1 (not . A.inClass ", ") `A.sepBy'` A.char ',' <* A.space
|
||||
chatMsgBody <- msgBodyContent =<< contentInfo `A.sepBy'` A.char ',' <* A.space
|
||||
pure RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody}
|
||||
identifier :: Parser ByteString
|
||||
identifier = B.cons <$> A.letter_ascii <*> A.takeWhile (\c -> A.isAlpha_ascii c || A.isDigit c)
|
||||
contentInfo :: Parser RawMsgBodyContent
|
||||
contentInfo = do
|
||||
contentType <- RawContentType <$> identifier <* A.char '.' <*> A.takeTill (A.inClass ":, ")
|
||||
contentSize <- A.char ':' *> A.decimal
|
||||
contentHash <- optional (A.char ':' *> base64P)
|
||||
pure RawMsgBodyContent {contentType, contentHash, contentData = MBEmpty contentSize}
|
||||
msgBodyContent :: [RawMsgBodyContent] -> Parser [RawMsgBodyContent]
|
||||
msgBodyContent [] = pure []
|
||||
msgBodyContent (p@RawMsgBodyContent {contentData = MBEmpty size} : ps) = do
|
||||
s <- A.take size <* A.space <|> A.takeByteString
|
||||
if B.length s == size
|
||||
then ((p {contentData = MBFull $ MsgData s} :: RawMsgBodyContent) :) <$> msgBodyContent ps
|
||||
else pure $ (if B.null s then p else p {contentData = MBPartial size $ MsgData s} :: RawMsgBodyContent) : ps
|
||||
msgBodyContent _ = fail "expected contentData = MBEmpty"
|
||||
|
||||
serializeRawChatMessage :: RawChatMessage -> ByteString
|
||||
serializeRawChatMessage = \case
|
||||
RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} ->
|
||||
B.unwords
|
||||
[ maybe "" bshow chatMsgId,
|
||||
chatMsgEvent,
|
||||
B.intercalate "," chatMsgParams,
|
||||
B.unwords $ map serializeContentInfo chatMsgBody,
|
||||
B.unwords $ map serializeContentData chatMsgBody
|
||||
]
|
||||
RawChatMsgContinuation {prevChatMsgId, continuationId, continuationData} ->
|
||||
bshow prevChatMsgId <> "." <> bshow continuationId <> " " <> continuationData
|
||||
|
||||
serializeContentInfo :: RawMsgBodyContent -> ByteString
|
||||
serializeContentInfo RawMsgBodyContent {contentType = RawContentType ns cType, contentHash, contentData} =
|
||||
ns <> "." <> cType <> ":" <> bshow (dataLength contentData) <> maybe "" (":" <>) contentHash
|
||||
|
||||
serializeContentData :: RawMsgBodyContent -> ByteString
|
||||
serializeContentData RawMsgBodyContent {contentData = MBFull (MsgData s)} = s
|
||||
serializeContentData _ = ""
|
||||
|
||||
44
src/Simplex/Chat/Protocol_.hs
Normal file
44
src/Simplex/Chat/Protocol_.hs
Normal file
@@ -0,0 +1,44 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
|
||||
module Simplex.Chat.Protocol_ where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
|
||||
data ChatEvent = GroupEvent | MessageEvent | InfoEvent
|
||||
|
||||
data Profile = Profile
|
||||
{ profileId :: ByteString,
|
||||
displayName :: Text
|
||||
}
|
||||
|
||||
data Contact = Contact
|
||||
{ contactId :: ByteString,
|
||||
profile :: Profile,
|
||||
connections :: [Connection]
|
||||
}
|
||||
|
||||
data Connection = Connection
|
||||
{ connId :: ConnId,
|
||||
connLevel :: Int,
|
||||
viaConn :: ConnId
|
||||
}
|
||||
|
||||
data GroupMember = GroupMember
|
||||
{ groupId :: ByteString,
|
||||
sharedMemberId :: ByteString,
|
||||
contact :: Contact,
|
||||
memberRole :: GroupMemberRole,
|
||||
memberStatus :: GroupMemberStatus
|
||||
}
|
||||
|
||||
data GroupMemberRole = GROwner | GRAdmin | GRStandard
|
||||
|
||||
data GroupMemberStatus = GSInvited | GSConnected | GSConnectedAll
|
||||
|
||||
data Group = Group
|
||||
{ groupId :: ByteString,
|
||||
displayName :: Text,
|
||||
members :: [GroupMember]
|
||||
}
|
||||
80
src/Simplex/Chat/Types.hs
Normal file
80
src/Simplex/Chat/Types.hs
Normal file
@@ -0,0 +1,80 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Types where
|
||||
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Database.SQLite.Simple.FromField (FromField (..))
|
||||
import Database.SQLite.Simple.ToField (ToField (..))
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
|
||||
|
||||
data User = User
|
||||
{ userId :: UserId,
|
||||
profile :: Profile
|
||||
}
|
||||
|
||||
type UserId = Int64
|
||||
|
||||
data Contact = Contact
|
||||
{ contactId :: Int64,
|
||||
localContactRef :: ContactRef,
|
||||
profile :: Maybe Profile,
|
||||
activeConn :: Connection
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type ContactRef = Text
|
||||
|
||||
data Group = Group
|
||||
{ groupId :: Int64,
|
||||
localGroupRef :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Profile = Profile
|
||||
{ profileId :: Int64,
|
||||
contactRef :: ContactRef,
|
||||
displayName :: Text
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Connection = Connection
|
||||
{ connId :: Int64,
|
||||
agentConnId :: ConnId,
|
||||
connLevel :: Int,
|
||||
viaContact :: Maybe Int64,
|
||||
connStatus :: ConnStatus
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ConnStatus = ConnNew | ConnConfirmed | ConnAccepted | ConnReady
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromField ConnStatus where fromField = fromTextField_ connStatusT
|
||||
|
||||
instance ToField ConnStatus where toField = toField . serializeConnStatus
|
||||
|
||||
connStatusT :: Text -> Maybe ConnStatus
|
||||
connStatusT = \case
|
||||
"NEW" -> Just ConnNew
|
||||
"CONF" -> Just ConnConfirmed
|
||||
"ACPT" -> Just ConnAccepted
|
||||
"READY" -> Just ConnReady
|
||||
_ -> Nothing
|
||||
|
||||
serializeConnStatus :: ConnStatus -> Text
|
||||
serializeConnStatus = \case
|
||||
ConnNew -> "NEW"
|
||||
ConnConfirmed -> "CONF"
|
||||
ConnAccepted -> "ACPT"
|
||||
ConnReady -> "READY"
|
||||
|
||||
data NewConnection = NewConnection
|
||||
{ agentConnId :: ByteString,
|
||||
connLevel :: Int,
|
||||
viaConn :: Maybe Int64
|
||||
}
|
||||
70
src/Simplex/Chat/protocol.md
Normal file
70
src/Simplex/Chat/protocol.md
Normal file
@@ -0,0 +1,70 @@
|
||||
# Chat protocol
|
||||
|
||||
## Design constraints
|
||||
|
||||
- the transport message has a fixed size (8 or 16kb)
|
||||
- the chat message can have multiple parts/attachments
|
||||
- the chat message including attachments can be of any size
|
||||
- if the message is partially received, it should be possible to parse and display the received parts
|
||||
|
||||
## Questions
|
||||
|
||||
- should content types be:
|
||||
- limited to MIME-types
|
||||
- separate content types vocabulary
|
||||
- both MIME types and extensions
|
||||
- allow additional content types namespaces
|
||||
|
||||
## Message syntax
|
||||
|
||||
The syntax of the message inside agent MSG:
|
||||
|
||||
```abnf
|
||||
agentMessageBody = message / msgContinuation
|
||||
message = [chatMsgId] SP msgEvent SP [parameters] SP [contentParts [SP msgBodyParts]]
|
||||
chatMsgId = 1*DIGIT ; used to refer to previous message;
|
||||
; in the group should only be used in messages sent to all members,
|
||||
; which is the main reason not to use external agent ID -
|
||||
; some messages are sent only to one member
|
||||
msgEvent = protocolNamespace 1*("." msgTypeName)
|
||||
protocolNamespace = 1*ALPHA ; "x" for all events defined in the protocol
|
||||
msgTypeName = 1*ALPHA
|
||||
parameters = parameter *("," parameter)
|
||||
parameter = 1*(%x21-2B / %x2D-7E) ; exclude control characters, space, comma (%x2C)
|
||||
contentParts = contentPart *("," contentPart)
|
||||
contentPart = contentTypeNamespace "." contentType ":" contentSize [":" contentHash]
|
||||
contentType = "i." <mime-type> / contentTypeNamespace "." 1*("." contentTypeName)
|
||||
contentTypeNamespace = 1*ALPHA
|
||||
contentTypeName = 1*ALPHA
|
||||
contentHash = <base64>
|
||||
msgBodyParts = msgBodyPart *(SP msgBodyPart)
|
||||
msgEventParents = msgEventParent *msgEventParent ; binary body part for content type "x.dag"
|
||||
msgEventParent = memberId refMsgId refMsgHash
|
||||
memberId = 8*8(OCTET) ; shared member ID
|
||||
refMsgId = 8*8(OCTET) ; sequential message number - external agent message ID
|
||||
refMsgHash = 16*16(OCTET) ; SHA256 of agent message body
|
||||
msgContinuation = "#" prevMsgId "." continuationId continuationData
|
||||
```
|
||||
|
||||
### Example: messages, updates, groups
|
||||
|
||||
```
|
||||
"3 x.msg.new c.text c.text:5 hello "
|
||||
"4 x.msg.new c.image i.image/jpg:256,i.image/png:4096 abcd abcd "
|
||||
"4 x.msg.new c.image x.dag:32,i.image/jpg:8000:hash1,i.image/png:16000:hash2 binary1"
|
||||
"#4.1 binary1end binary2"
|
||||
"#4.2 binary2continued"
|
||||
"#4.3 binary2end "
|
||||
"5 x.msg.new c.image i.image/jpg:256,i.image/url:160 abcd https://media.example.com/asdf#abcd "
|
||||
'6 x.msg.update 3 c.text:11,x.dag:16 hello there abcd '
|
||||
'7 x.msg.delete 3'
|
||||
'8 x.msg.new app/v1 i.text/html:NNN,i.text/css:NNN,c.js:NNN,c.json:NNN ... ... ... {...} '
|
||||
'9 x.msg.eval 8 c.json:NNN {...} '
|
||||
'10 x.msg.new c.text 2 c.text:16,x.dag:32 hello there @123 abcd '
|
||||
' x.grp.mem.inv 23456,123 1 c.json NNN {...} '
|
||||
' x.grp.mem.acpt 23456 1 c.text NNN <invitation> '
|
||||
' x.grp.mem.intro 23456,234 1 c.json NNN {...} '
|
||||
' x.grp.mem.inv 23456,234 1 c.text NNN <invitation> '
|
||||
' x.grp.mem.req 23456,123 1 c.json NNN {...} '
|
||||
' x.grp.mem.direct.inv 23456,234 1 text NNN <invitation> '
|
||||
```
|
||||
@@ -43,7 +43,8 @@ extra-deps:
|
||||
# - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688
|
||||
# - ../simplexmq
|
||||
- github: simplex-chat/simplexmq
|
||||
commit: 09c6adeabc533537dcc039e2195123c6f7167ebe
|
||||
commit: 8ba3e3e45a6006d173738db9eac1068edad74df7
|
||||
# this commit is in PR #164
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
|
||||
57
tests/ProtocolTests.hs
Normal file
57
tests/ProtocolTests.hs
Normal file
@@ -0,0 +1,57 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module ProtocolTests where
|
||||
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Test.Hspec
|
||||
|
||||
protocolTests :: Spec
|
||||
protocolTests = do
|
||||
parseChatMessageTest
|
||||
|
||||
(#==) :: ByteString -> RawChatMessage -> Expectation
|
||||
s #== msg = parseAll rawChatMessageP s `shouldBe` Right msg
|
||||
|
||||
parseChatMessageTest :: Spec
|
||||
parseChatMessageTest = describe "Raw chat message format" $ do
|
||||
it "no parameters and content" $
|
||||
"5 x.grp.mem.leave " #== RawChatMessage (Just 5) "x.grp.mem.leave" [] []
|
||||
it "one parameter, no content" $
|
||||
"6 x.msg.del 3 " #== RawChatMessage (Just 6) "x.msg.del" ["3"] []
|
||||
it "with content that fits the message and optional trailing space" $
|
||||
"7 x.msg.new c.text c.text:11 hello there "
|
||||
#== RawChatMessage
|
||||
(Just 7)
|
||||
"x.msg.new"
|
||||
["c.text"]
|
||||
[RawMsgBodyContent (RawContentType "c" "text") Nothing $ MBFull (MsgData "hello there")]
|
||||
it "with content that fits the message, without trailing space" $
|
||||
"7 x.msg.new c.text c.text:11 hello there"
|
||||
#== RawChatMessage
|
||||
(Just 7)
|
||||
"x.msg.new"
|
||||
["c.text"]
|
||||
[RawMsgBodyContent (RawContentType "c" "text") Nothing $ MBFull (MsgData "hello there")]
|
||||
it "with DAG reference and partial content" $
|
||||
"8 x.msg.new c.image x.dag:16,c.text:7,m.image/jpg:64:MDEyMzQ1Njc=,m.image/png:4000:MDEyMzQ1Njc= 0123456789012345 picture abcdef"
|
||||
#== RawChatMessage
|
||||
(Just 8)
|
||||
"x.msg.new"
|
||||
["c.image"]
|
||||
[ RawMsgBodyContent (RawContentType "x" "dag") Nothing $ MBFull (MsgData "0123456789012345"),
|
||||
RawMsgBodyContent (RawContentType "c" "text") Nothing $ MBFull (MsgData "picture"),
|
||||
RawMsgBodyContent (RawContentType "m" "image/jpg") (Just "01234567") $ MBPartial 64 (MsgData "abcdef"),
|
||||
RawMsgBodyContent (RawContentType "m" "image/png") (Just "01234567") $ MBEmpty 4000
|
||||
]
|
||||
it "message continuation" $
|
||||
"#8.1 abcdef" #== RawChatMsgContinuation 8 1 "abcdef"
|
||||
it "without message id" $
|
||||
" x.grp.mem.inv 23456,123 c.json:46 {\"contactRef\":\"john\",\"displayName\":\"John Doe\"}"
|
||||
#== RawChatMessage
|
||||
Nothing
|
||||
"x.grp.mem.inv"
|
||||
["23456", "123"]
|
||||
[RawMsgBodyContent (RawContentType "c" "json") Nothing $ MBFull (MsgData "{\"contactRef\":\"john\",\"displayName\":\"John Doe\"}")]
|
||||
@@ -1,7 +1,9 @@
|
||||
import MarkdownTests
|
||||
import ProtocolTests
|
||||
import Test.Hspec
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
hspec $ do
|
||||
describe "SimpleX chat markdown" markdownTests
|
||||
describe "SimpleX chat protocol" protocolTests
|
||||
|
||||
Reference in New Issue
Block a user