use chat message format to pass profile information, refactor (#71)

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

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)

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"

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