From 25ac250d3759b7160d2366b742b4eae2fa431b77 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 6 Jul 2021 19:07:03 +0100 Subject: [PATCH] use chat message format to pass profile information, refactor (#71) --- src/Simplex/Chat.hs | 117 +++++++++++++++++---------------- src/Simplex/Chat/Controller.hs | 7 +- src/Simplex/Chat/Protocol.hs | 55 +++++++--------- src/Simplex/Chat/Store.hs | 35 +++++----- 4 files changed, 103 insertions(+), 111 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index a025e46caf..981c2e608d 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -18,7 +19,6 @@ 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 qualified Data.ByteString.Lazy.Char8 as LB import Data.Functor (($>)) import Data.List (find) @@ -59,7 +59,6 @@ runChatController = raceAny_ [ inputSubscriber, agentSubscriber, - chatSubscriber, notificationSubscriber ] @@ -77,9 +76,7 @@ inputSubscriber = do SendMessage c msg -> showSentMessage c msg _ -> printToView [plain s] user <- asks currentUser - runExceptT (processChatCommand user cmd) >>= \case - Left e -> showChatError e - _ -> pure () + void . runExceptT $ processChatCommand user cmd `catchError` showChatError processChatCommand :: ChatMonad m => User -> ChatCommand -> m () processChatCommand User {userId, profile} = \case @@ -90,7 +87,7 @@ processChatCommand User {userId, profile} = \case withStore $ \st -> createDirectConnection st userId connId showInvitation qInfo Connect qInfo -> do - connId <- withAgent $ \agent -> joinConnection agent qInfo $ LB.toStrict (J.encode profile) + connId <- withAgent $ \agent -> joinConnection agent qInfo $ encodeProfile profile withStore $ \st -> createDirectConnection st userId connId DeleteContact cRef -> do conns <- withStore $ \st -> getContactConnections st userId cRef @@ -109,35 +106,22 @@ processChatCommand User {userId, profile} = \case agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () agentSubscriber = do - aQ <- asks $ subQ . smpAgent - cQ <- asks chatQ + q <- asks $ subQ . smpAgent + -- cQ <- asks chatQ forever $ do - (_, agentConnId, resp) <- atomically (readTBQueue aQ) - User {userId} <- asks currentUser - 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} + (_, connId, msg) <- atomically $ readTBQueue q + user <- asks currentUser + -- TODO handle errors properly + void . runExceptT $ processAgentMessage user connId msg `catchError` (liftIO . print) -chatSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () -chatSubscriber = do - cQ <- asks chatQ - forever $ do - User {userId, profile} <- asks currentUser - atomically (readTBQueue cQ) >>= \case - ChatTransmission - { agentMsgMeta = meta, - chatDirection = ReceivedDirectMessage Contact {localContactRef = c}, - chatMessage = ChatMessage {chatMsgEvent, chatMsgBody} - } -> +processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m () +processAgentMessage User {userId, profile} agentConnId agentMessage = do + chatDirection <- withStore $ \st -> getConnectionChatDirection st userId agentConnId + case chatDirection of + ReceivedDirectMessage Contact {localContactRef = c} -> + case agentMessage of + MSG meta msgBody -> do + ChatMessage {chatMsgEvent, chatMsgBody} <- liftEither $ parseChatMessage msgBody case chatMsgEvent of XMsgNew MTText -> do case find (isSimplexContentType XCText) chatMsgBody of @@ -147,33 +131,50 @@ chatSubscriber = do showToast ("@" <> c) text setActive $ ActiveC c _ -> pure () + XInfo -> pure () -- TODO profile update _ -> pure () - AgentTransmission {agentConnId, chatDirection = ReceivedDirectMessage NewContact {activeConn}, agentMessage} -> - void . runExceptT $ case agentMessage of - CONF confId connInfo -> do - -- TODO update connection status - saveContact userId activeConn connInfo - withAgent $ \a -> allowConnection a agentConnId confId $ LB.toStrict (J.encode profile) - INFO connInfo -> - saveContact userId activeConn connInfo - _ -> pure () - AgentTransmission {chatDirection = ReceivedDirectMessage Contact {localContactRef = c}, agentMessage} -> - case agentMessage of - CON -> do - -- TODO update connection status - showContactConnected c - showToast ("@" <> c) "connected" - setActive $ ActiveC c - END -> do - showContactDisconnected c - showToast ("@" <> c) "disconnected" - unsetActive $ ActiveC c - _ -> pure () - _ -> pure () + CON -> do + -- TODO update connection status + showContactConnected c + showToast ("@" <> c) "connected" + setActive $ ActiveC c + END -> do + showContactDisconnected c + showToast ("@" <> c) "disconnected" + unsetActive $ ActiveC c + _ -> pure () + ReceivedDirectMessage NewContact {activeConn} -> + case agentMessage of + CONF confId connInfo -> do + -- TODO update connection status + saveConnInfo activeConn connInfo + withAgent $ \a -> allowConnection a agentConnId confId $ encodeProfile profile + INFO connInfo -> + saveConnInfo activeConn connInfo + _ -> pure () + _ -> pure () where - saveContact userId activeConn connInfo = do - p <- liftEither . first (ChatErrorContact . CEProfile) $ J.eitherDecodeStrict' connInfo - withStore $ \st -> createDirectContact st userId activeConn p + parseChatMessage :: ByteString -> Either ChatError ChatMessage + parseChatMessage msgBody = first ChatErrorMessage (parseAll rawChatMessageP msgBody >>= toChatMessage) + + saveConnInfo :: Connection -> ConnInfo -> m () + saveConnInfo activeConn connInfo = do + ChatMessage {chatMsgEvent, chatMsgBody} <- liftEither $ parseChatMessage connInfo + case chatMsgEvent of + XInfo -> + case find (isSimplexContentType XCJson) chatMsgBody of + Just MsgBodyContent {contentData = MBFull (MsgData bs)} -> do + p <- liftEither . first (ChatErrorContact . CEProfile) $ J.eitherDecodeStrict' bs + withStore $ \st -> createDirectContact st userId activeConn p + _ -> pure () -- TODO show/log error? + _ -> pure () -- TODO show/log error, other events in SMP confirmation + +encodeProfile :: Profile -> ByteString +encodeProfile profile = + let json = LB.toStrict $ J.encode profile + body = MsgBodyContent {contentType = SimplexContentType XCJson, contentHash = Nothing, contentData = MBFull $ MsgData json} + chatMsg = ChatMessage {chatMsgId = Nothing, chatMsgEvent = XInfo, chatMsgBody = [body], chatDAGIdx = Nothing} + in serializeRawChatMessage $ rawChatMessage chatMsg getCreateActiveUser :: SQLiteStore -> IO User getCreateActiveUser st = do diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 4aba3cdb9e..fb08a64f60 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -13,7 +13,6 @@ import Control.Monad.IO.Unlift import Control.Monad.Reader import Numeric.Natural import Simplex.Chat.Notification -import Simplex.Chat.Protocol import Simplex.Chat.Store (StoreError) import Simplex.Chat.Terminal import Simplex.Chat.Types @@ -27,7 +26,6 @@ data ChatController = ChatController smpAgent :: AgentClient, chatTerminal :: ChatTerminal, chatStore :: SQLiteStore, - chatQ :: TBQueue ChatTransmission, inputQ :: TBQueue InputEvent, notifyQ :: TBQueue Notification, sendNotification :: Notification -> IO () @@ -37,6 +35,7 @@ data InputEvent = InputCommand String | InputControl Char data ChatError = ChatErrorContact ContactError + | ChatErrorMessage String | ChatErrorAgent AgentErrorType | ChatErrorStore StoreError deriving (Show, Exception) @@ -50,8 +49,8 @@ newChatController :: AgentClient -> ChatTerminal -> SQLiteStore -> User -> (Noti newChatController smpAgent chatTerminal chatStore currentUser sendNotification qSize = do inputQ <- newTBQueue qSize notifyQ <- newTBQueue qSize - chatQ <- newTBQueue qSize - pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, chatQ, inputQ, notifyQ, sendNotification} + -- chatQ <- newTBQueue qSize + pure ChatController {currentUser, smpAgent, chatTerminal, chatStore, inputQ, notifyQ, sendNotification} setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m () setActive to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 5f1c69ebbc..6474b3cf8d 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -21,28 +21,8 @@ import Data.Text (Text) 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 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 ChatDirection (p :: AParty) where ReceivedDirectMessage :: Contact -> ChatDirection 'Agent SentDirectMessage :: Contact -> ChatDirection 'Client @@ -53,16 +33,18 @@ deriving instance Eq (ChatDirection p) deriving instance Show (ChatDirection p) -newtype ChatMsgEvent = XMsgNew MessageType +data ChatMsgEvent + = XMsgNew MessageType + | XInfo deriving (Eq, Show) data MessageType = MTText | MTImage deriving (Eq, Show) -toMsgType :: ByteString -> Either ByteString MessageType +toMsgType :: ByteString -> Either String MessageType toMsgType = \case "c.text" -> Right MTText "c.image" -> Right MTImage - t -> Left $ "invalid message type " <> t + t -> Left $ "invalid message type " <> B.unpack t rawMsgType :: MessageType -> ByteString rawMsgType = \case @@ -77,16 +59,20 @@ data ChatMessage = ChatMessage } deriving (Eq, Show) -toChatMessage :: RawChatMessage -> Either ByteString ChatMessage +toChatMessage :: RawChatMessage -> Either String ChatMessage toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do body <- mapM toMsgBodyContent chatMsgBody + let chatDAGIdx = findDAG body 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} + pure ChatMessage {chatMsgId, chatMsgEvent = XMsgNew t, chatMsgBody = body, chatDAGIdx} _ -> throwError "x.msg.new expects one parameter" - _ -> throwError $ "unsupported event " <> chatMsgEvent + "x.info" -> case chatMsgParams of + [] -> pure ChatMessage {chatMsgId, chatMsgEvent = XInfo, chatMsgBody = body, chatDAGIdx} + _ -> throwError "x.info expects no parameters" + _ -> throwError $ "unsupported event " <> B.unpack chatMsgEvent toChatMessage _ = Left "message continuation" findDAG :: [MsgBodyContent] -> Maybe Int @@ -101,11 +87,12 @@ 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} + XMsgNew t -> RawChatMessage {chatMsgId, chatMsgEvent = "x.msg.new", chatMsgParams = [rawMsgType t], chatMsgBody} + XInfo -> RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody} + where + chatMsgBody = map rawMsgBodyContent body -toMsgBodyContent :: RawMsgBodyContent -> Either ByteString MsgBodyContent +toMsgBodyContent :: RawMsgBodyContent -> Either String MsgBodyContent toMsgBodyContent RawMsgBodyContent {contentType, contentHash, contentData} = do cType <- toContentType contentType pure MsgBodyContent {contentType = cType, contentHash, contentData} @@ -127,15 +114,16 @@ data ContentType | SimplexDAG deriving (Eq, Show) -data XContentType = XCText | XCImage deriving (Eq, Show) +data XContentType = XCText | XCImage | XCJson deriving (Eq, Show) data MContentType = MCImageJPG | MCImagePNG deriving (Eq, Show) -toContentType :: RawContentType -> Either ByteString ContentType +toContentType :: RawContentType -> Either String ContentType toContentType (RawContentType ns cType) = case ns of "x" -> case cType of "text" -> Right $ SimplexContentType XCText "image" -> Right $ SimplexContentType XCImage + "json" -> Right $ SimplexContentType XCJson "dag" -> Right SimplexDAG _ -> err "m" -> case cType of @@ -144,13 +132,14 @@ toContentType (RawContentType ns cType) = case ns of _ -> err _ -> err where - err = Left $ "invalid content type " <> ns <> "." <> cType + err = Left . B.unpack $ "invalid content type " <> ns <> "." <> cType rawContentType :: ContentType -> RawContentType rawContentType t = case t of SimplexContentType t' -> RawContentType "x" $ case t' of XCText -> "text" XCImage -> "image" + XCJson -> "json" MimeContentType t' -> RawContentType "m" $ case t' of MCImageJPG -> "image/jpg" MCImagePNG -> "image/png" diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 0c80bd4a5f..86a2cb9200 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -170,22 +170,25 @@ createDirectContact st userId Connection {connId} Profile {contactRef, displayNa deleteContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactRef -> m () deleteContact st userId contactRef = - liftIO . withTransaction st $ \db -> - forM_ - [ [sql| - DELETE FROM connections WHERE connection_id IN ( - SELECT connection_id - FROM connections c - JOIN contacts cs ON c.contact_id = cs.contact_id - WHERE cs.user_id = :user_id AND cs.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] + liftIO . withTransaction st $ \db -> do + DB.executeNamed + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN contacts cs ON c.contact_id = cs.contact_id + WHERE cs.user_id = :user_id AND cs.local_contact_ref = :contact_ref + ); + |] + [":user_id" := userId, ":contact_ref" := contactRef] + DB.executeNamed + db + [sql| + DELETE FROM contacts + WHERE user_id = :user_id AND local_contact_ref = :contact_ref; + |] + [":user_id" := userId, ":contact_ref" := contactRef] -- TODO return the last connection that is ready, not any last connection -- requires updating connection status