simplify chat protocol (#74)

* groups protocol and some group commands

* simplify chat message format, refactor types to include parsed message body

* disable chat test

src/Simplex/Chat/Protocol.hs

@@ -6,21 +6,27 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 
 module Simplex.Chat.Protocol where
 
-import Control.Applicative (optional, (<|>))
+import Control.Applicative (optional)
+import Control.Monad ((<=<))
 import Control.Monad.Except (throwError)
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
+import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
-import Data.List (findIndex)
+import Data.List (find)
 import Data.Text (Text)
 import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Protocol
-import Simplex.Messaging.Parsers (base64P)
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Util (bshow)
 
 data ChatDirection (p :: AParty) where
@@ -34,12 +40,34 @@ deriving instance Eq (ChatDirection p)
 deriving instance Show (ChatDirection p)
 
 data ChatMsgEvent
-  = XMsgNew MessageType
-  | XInfo
+  = XMsgNew {messageType :: MessageType, files :: [(ContentType, Int)], content :: [MsgBodyContent]}
+  | XInfo Profile
+  | XGrpInv InvitationId MemberId GroupMemberRole GroupProfile
+  | XGrpAcpt InvitationId SMPQueueInfo
+  | XGrpMemNew MemberId GroupMemberRole Profile
+  | XGrpMemIntro MemberId GroupMemberRole Profile
   deriving (Eq, Show)
 
+type MemberId = ByteString
+
 data MessageType = MTText | MTImage deriving (Eq, Show)
 
+data GroupMemberRole = GROwner | GRAdmin | GRMember
+  deriving (Eq, Show)
+
+toMemberRole :: ByteString -> Either String GroupMemberRole
+toMemberRole = \case
+  "owner" -> Right GROwner
+  "admin" -> Right GRAdmin
+  "member" -> Right GRMember
+  r -> Left $ "invalid group member role " <> B.unpack r
+
+serializeMemberRole :: GroupMemberRole -> ByteString
+serializeMemberRole = \case
+  GROwner -> "owner"
+  GRAdmin -> "admin"
+  GRMember -> "member"
+
 toMsgType :: ByteString -> Either String MessageType
 toMsgType = \case
   "c.text" -> Right MTText
@@ -54,29 +82,59 @@ rawMsgType = \case
 data ChatMessage = ChatMessage
   { chatMsgId :: Maybe Int64,
     chatMsgEvent :: ChatMsgEvent,
-    chatMsgBody :: [MsgBodyContent],
-    chatDAGIdx :: Maybe Int
+    chatDAG :: Maybe ByteString
   }
   deriving (Eq, Show)
 
 toChatMessage :: RawChatMessage -> Either String ChatMessage
 toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do
-  body <- mapM toMsgBodyContent chatMsgBody
-  let chatDAGIdx = findDAG body
+  (chatDAG, body) <- getDAG <$> mapM toMsgBodyContent chatMsgBody
   case chatMsgEvent of
     "x.msg.new" -> case chatMsgParams of
-      [mt] -> do
+      mt : rawFiles -> do
         t <- toMsgType mt
-        pure ChatMessage {chatMsgId, chatMsgEvent = XMsgNew t, chatMsgBody = body, chatDAGIdx}
-      _ -> throwError "x.msg.new expects one parameter"
+        files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
+        let msg = XMsgNew {messageType = t, files, content = body}
+        pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
+      [] -> throwError "x.msg.new expects at least one parameter"
     "x.info" -> case chatMsgParams of
-      [] -> pure ChatMessage {chatMsgId, chatMsgEvent = XInfo, chatMsgBody = body, chatDAGIdx}
+      [] -> do
+        profile <- getJSON body
+        pure ChatMessage {chatMsgId, chatMsgEvent = XInfo profile, chatDAG}
       _ -> throwError "x.info expects no parameters"
+    "x.grp.inv" -> case chatMsgParams of
+      [invId', memId', role'] -> do
+        invId <- B64.decode invId'
+        memId <- B64.decode memId'
+        role <- toMemberRole role'
+        groupProfile <- getJSON body
+        pure ChatMessage {chatMsgId, chatMsgEvent = XGrpInv invId memId role groupProfile, chatDAG}
+      _ -> throwError "x.grp.inv expects 3 parameters"
+    "x.grp.acpt" -> case chatMsgParams of
+      [invId, qInfo] -> do
+        msg <- XGrpAcpt <$> B64.decode invId <*> parseAll smpQueueInfoP qInfo
+        pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
+      _ -> throwError "x.grp.acpt expects 2 parameters"
+    "x.grp.mem.new" -> case chatMsgParams of
+      [memId, role] -> do
+        msg <- XGrpMemNew <$> B64.decode memId <*> toMemberRole role <*> getJSON body
+        pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
+      _ -> throwError "x.grp.acpt expects 2 parameters"
+    "x.grp.mem.intro" -> case chatMsgParams of
+      [memId, role] -> do
+        msg <- XGrpMemIntro <$> B64.decode memId <*> toMemberRole role <*> getJSON body
+        pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG}
+      _ -> throwError "x.grp.acpt expects 2 parameters"
     _ -> throwError $ "unsupported event " <> B.unpack chatMsgEvent
-toChatMessage _ = Left "message continuation"
-
-findDAG :: [MsgBodyContent] -> Maybe Int
-findDAG = findIndex $ isContentType SimplexDAG
+  where
+    getDAG :: [MsgBodyContent] -> (Maybe ByteString, [MsgBodyContent])
+    getDAG body = case break (isContentType SimplexDAG) body of
+      (b, MsgBodyContent SimplexDAG dag : a) -> (Just dag, b <> a)
+      _ -> (Nothing, body)
+    toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int)
+    toContentInfo (rawType, size) = (,size) <$> toContentType rawType
+    getJSON :: FromJSON a => [MsgBodyContent] -> Either String a
+    getJSON = J.eitherDecodeStrict' <=< getSimplexContentType XCJson
 
 isContentType :: ContentType -> MsgBodyContent -> Bool
 isContentType t MsgBodyContent {contentType = t'} = t == t'
@@ -84,27 +142,64 @@ isContentType t MsgBodyContent {contentType = t'} = t == t'
 isSimplexContentType :: XContentType -> MsgBodyContent -> Bool
 isSimplexContentType = isContentType . SimplexContentType
 
+getContentType :: ContentType -> [MsgBodyContent] -> Either String ByteString
+getContentType t body = case find (isContentType t) body of
+  Just MsgBodyContent {contentData} -> Right contentData
+  Nothing -> Left "no required content type"
+
+getSimplexContentType :: XContentType -> [MsgBodyContent] -> Either String ByteString
+getSimplexContentType = getContentType . SimplexContentType
+
 rawChatMessage :: ChatMessage -> RawChatMessage
-rawChatMessage ChatMessage {chatMsgId, chatMsgEvent = event, chatMsgBody = body} =
-  case event of
-    XMsgNew t -> RawChatMessage {chatMsgId, chatMsgEvent = "x.msg.new", chatMsgParams = [rawMsgType t], chatMsgBody}
-    XInfo -> RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody}
+rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
+  case chatMsgEvent of
+    XMsgNew {messageType = t, files, content} ->
+      let rawFiles = map (serializeContentInfo . rawContentInfo) files
+          chatMsgParams = rawMsgType t : rawFiles
+          chatMsgBody = rawWithDAG content
+       in RawChatMessage {chatMsgId, chatMsgEvent = "x.msg.new", chatMsgParams, chatMsgBody}
+    XInfo profile ->
+      let chatMsgBody = rawWithDAG [jsonBody profile]
+       in RawChatMessage {chatMsgId, chatMsgEvent = "x.info", chatMsgParams = [], chatMsgBody}
+    XGrpInv invId memId role groupProfile ->
+      let chatMsgParams = [B64.encode invId, B64.encode memId, serializeMemberRole role]
+          chatMsgBody = rawWithDAG [jsonBody groupProfile]
+       in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.inv", chatMsgParams, chatMsgBody}
+    XGrpAcpt invId qInfo ->
+      let chatMsgParams = [B64.encode invId, serializeSmpQueueInfo qInfo]
+       in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.acpt", chatMsgParams, chatMsgBody = []}
+    XGrpMemNew memId role profile ->
+      let chatMsgParams = [B64.encode memId, serializeMemberRole role]
+          chatMsgBody = rawWithDAG [jsonBody profile]
+       in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.mem.new", chatMsgParams, chatMsgBody}
+    XGrpMemIntro memId role profile ->
+      let chatMsgParams = [B64.encode memId, serializeMemberRole role]
+          chatMsgBody = rawWithDAG [jsonBody profile]
+       in RawChatMessage {chatMsgId, chatMsgEvent = "x.grp.mem.intro", chatMsgParams, chatMsgBody}
   where
-    chatMsgBody = map rawMsgBodyContent body
+    rawContentInfo :: (ContentType, Int) -> (RawContentType, Int)
+    rawContentInfo (t, size) = (rawContentType t, size)
+    jsonBody :: ToJSON a => a -> MsgBodyContent
+    jsonBody x =
+      let json = LB.toStrict $ J.encode x
+       in MsgBodyContent {contentType = SimplexContentType XCJson, contentData = json}
+    rawWithDAG :: [MsgBodyContent] -> [RawMsgBodyContent]
+    rawWithDAG body = map rawMsgBodyContent $ case chatDAG of
+      Nothing -> body
+      Just dag -> MsgBodyContent {contentType = SimplexDAG, contentData = dag} : body
 
 toMsgBodyContent :: RawMsgBodyContent -> Either String MsgBodyContent
-toMsgBodyContent RawMsgBodyContent {contentType, contentHash, contentData} = do
+toMsgBodyContent RawMsgBodyContent {contentType, contentData} = do
   cType <- toContentType contentType
-  pure MsgBodyContent {contentType = cType, contentHash, contentData}
+  pure MsgBodyContent {contentType = cType, contentData}
 
 rawMsgBodyContent :: MsgBodyContent -> RawMsgBodyContent
-rawMsgBodyContent MsgBodyContent {contentType = t, contentHash, contentData} =
-  RawMsgBodyContent {contentType = rawContentType t, contentHash, contentData}
+rawMsgBodyContent MsgBodyContent {contentType = t, contentData} =
+  RawMsgBodyContent {contentType = rawContentType t, contentData}
 
 data MsgBodyContent = MsgBodyContent
   { contentType :: ContentType,
-    contentHash :: Maybe ByteString,
-    contentData :: MsgBodyPartData
+    contentData :: ByteString
   }
   deriving (Eq, Show)
 
@@ -149,24 +244,17 @@ 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
-      }
+data RawChatMessage = RawChatMessage
+  { chatMsgId :: Maybe Int64,
+    chatMsgEvent :: ByteString,
+    chatMsgParams :: [ByteString],
+    chatMsgBody :: [RawMsgBodyContent]
+  }
   deriving (Eq, Show)
 
 data RawMsgBodyContent = RawMsgBodyContent
   { contentType :: RawContentType,
-    contentHash :: Maybe ByteString,
-    contentData :: MsgBodyPartData
+    contentData :: ByteString
   }
   deriving (Eq, Show)
 
@@ -175,82 +263,51 @@ data RawContentType = RawContentType NameSpace ByteString
 
 type NameSpace = ByteString
 
-data MsgBodyPartData
-  = -- | fully loaded
-    MBFull MsgData
-  | -- | partially loaded
-    MBPartial Int MsgData
-  | -- | not loaded yet
-    MBEmpty Int
-  deriving (Eq, Show)
-
-data MsgData
-  = MsgData ByteString
-  | MsgDataRec {dataId :: Int64, dataSize :: Int}
+newtype MsgData = MsgData ByteString
   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
+rawChatMessageP = do
+  chatMsgId <- optional A.decimal <* A.space
+  chatMsgEvent <- B.intercalate "." <$> identifierP `A.sepBy1'` A.char '.' <* A.space
+  chatMsgParams <- A.takeWhile1 (not . A.inClass ", ") `A.sepBy'` A.char ',' <* A.space
+  chatMsgBody <- msgBodyContent =<< contentInfoP `A.sepBy'` A.char ',' <* A.space
+  pure RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody}
   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 :: [(RawContentType, Int)] -> 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"
+    msgBodyContent ((contentType, size) : ps) = do
+      contentData <- A.take size <* A.space
+      ((RawMsgBodyContent {contentType, contentData}) :) <$> msgBodyContent ps
+
+contentInfoP :: Parser (RawContentType, Int)
+contentInfoP = do
+  contentType <- RawContentType <$> identifierP <* A.char '.' <*> A.takeTill (A.inClass ":, ")
+  size <- A.char ':' *> A.decimal
+  pure (contentType, size)
+
+identifierP :: Parser ByteString
+identifierP = B.cons <$> A.letter_ascii <*> A.takeWhile (\c -> A.isAlpha_ascii c || A.isDigit c)
 
 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
+serializeRawChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} =
+  B.unwords
+    [ maybe "" bshow chatMsgId,
+      chatMsgEvent,
+      B.intercalate "," chatMsgParams,
+      B.unwords $ map serializeBodyContentInfo chatMsgBody,
+      B.unwords $ map msgContentData chatMsgBody
+    ]
 
-serializeContentInfo :: RawMsgBodyContent -> ByteString
-serializeContentInfo RawMsgBodyContent {contentType = RawContentType ns cType, contentHash, contentData} =
-  ns <> "." <> cType <> ":" <> bshow (dataLength contentData) <> maybe "" (":" <>) contentHash
+serializeBodyContentInfo :: RawMsgBodyContent -> ByteString
+serializeBodyContentInfo RawMsgBodyContent {contentType = t, contentData} =
+  serializeContentInfo (t, B.length contentData)
 
-serializeContentData :: RawMsgBodyContent -> ByteString
-serializeContentData RawMsgBodyContent {contentData = MBFull (MsgData s)} = s
-serializeContentData _ = ""
+serializeContentInfo :: (RawContentType, Int) -> ByteString
+serializeContentInfo (RawContentType ns cType, size) = ns <> "." <> cType <> ":" <> bshow size
+
+msgContentData :: RawMsgBodyContent -> ByteString
+msgContentData RawMsgBodyContent {contentData} = contentData <> " "