diff --git a/apps/simplex-chat/Main.hs b/apps/simplex-chat/Main.hs index 577edc9db7..041ba7d721 100644 --- a/apps/simplex-chat/Main.hs +++ b/apps/simplex-chat/Main.hs @@ -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 diff --git a/apps/simplex-chat/Simplex/Chat.hs b/apps/simplex-chat/Simplex/Chat.hs index 57157e0d7d..fa7ebfc1fe 100644 --- a/apps/simplex-chat/Simplex/Chat.hs +++ b/apps/simplex-chat/Simplex/Chat.hs @@ -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 diff --git a/apps/simplex-chat/Simplex/Chat/Controller.hs b/apps/simplex-chat/Simplex/Chat/Controller.hs index 79e6f08f0b..43d9e5e780 100644 --- a/apps/simplex-chat/Simplex/Chat/Controller.hs +++ b/apps/simplex-chat/Simplex/Chat/Controller.hs @@ -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' diff --git a/apps/simplex-chat/Simplex/Input.hs b/apps/simplex-chat/Simplex/Input.hs index 494ba412d6..9984597179 100644 --- a/apps/simplex-chat/Simplex/Input.hs +++ b/apps/simplex-chat/Simplex/Input.hs @@ -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) diff --git a/apps/simplex-chat/Simplex/Notification.hs b/apps/simplex-chat/Simplex/Notification.hs index 7c1f3966a6..6d96eb0d89 100644 --- a/apps/simplex-chat/Simplex/Notification.hs +++ b/apps/simplex-chat/Simplex/Notification.hs @@ -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 diff --git a/apps/simplex-chat/Simplex/Store.hs b/apps/simplex-chat/Simplex/Store.hs index 4d2638d252..37a54c85ae 100644 --- a/apps/simplex-chat/Simplex/Store.hs +++ b/apps/simplex-chat/Simplex/Store.hs @@ -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) diff --git a/apps/simplex-chat/Simplex/Terminal.hs b/apps/simplex-chat/Simplex/Terminal.hs index e9cd618aa3..b8e77ea9c7 100644 --- a/apps/simplex-chat/Simplex/Terminal.hs +++ b/apps/simplex-chat/Simplex/Terminal.hs @@ -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 diff --git a/apps/simplex-chat/Simplex/View.hs b/apps/simplex-chat/Simplex/View.hs index 1e701c7bd8..ab3c980de1 100644 --- a/apps/simplex-chat/Simplex/View.hs +++ b/apps/simplex-chat/Simplex/View.hs @@ -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 " ] -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] diff --git a/apps/simplex-chat/Types.hs b/apps/simplex-chat/Types.hs deleted file mode 100644 index 4dc0314325..0000000000 --- a/apps/simplex-chat/Types.hs +++ /dev/null @@ -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) diff --git a/migrations/20210612_initial.sql b/migrations/20210612_initial.sql index 4c8ac3a254..22fcae5b22 100644 --- a/migrations/20210612_initial.sql +++ b/migrations/20210612_initial.sql @@ -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 ( diff --git a/package.yaml b/package.yaml index d27fa5f324..e5991df418 100644 --- a/package.yaml +++ b/package.yaml @@ -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.* diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index f0635279e9..5f1c69ebbc 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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 _ = "" diff --git a/src/Simplex/Chat/Protocol_.hs b/src/Simplex/Chat/Protocol_.hs new file mode 100644 index 0000000000..b241ac42b2 --- /dev/null +++ b/src/Simplex/Chat/Protocol_.hs @@ -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] + } diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs new file mode 100644 index 0000000000..6cf6a44c3f --- /dev/null +++ b/src/Simplex/Chat/Types.hs @@ -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 + } diff --git a/src/Simplex/Chat/protocol.md b/src/Simplex/Chat/protocol.md new file mode 100644 index 0000000000..7ed41ce9cb --- /dev/null +++ b/src/Simplex/Chat/protocol.md @@ -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." / contentTypeNamespace "." 1*("." contentTypeName) +contentTypeNamespace = 1*ALPHA +contentTypeName = 1*ALPHA +contentHash = +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 ' +' x.grp.mem.intro 23456,234 1 c.json NNN {...} ' +' x.grp.mem.inv 23456,234 1 c.text NNN ' +' x.grp.mem.req 23456,123 1 c.json NNN {...} ' +' x.grp.mem.direct.inv 23456,234 1 text NNN ' +``` diff --git a/stack.yaml b/stack.yaml index d0635751fb..732c3d6e25 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: [] diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs new file mode 100644 index 0000000000..8dbfe18b75 --- /dev/null +++ b/tests/ProtocolTests.hs @@ -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\"}")] diff --git a/tests/Test.hs b/tests/Test.hs index b4d6ff9275..2575ec5eb9 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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