From 922e95756a7b51240d9d8d7008397538772ae69c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 17 May 2023 01:22:00 +0200 Subject: [PATCH] core: use JSON in reactions api, forward compatible JSON parsing for reactions (#2449) --- src/Simplex/Chat.hs | 18 +++++++++--------- src/Simplex/Chat/Controller.hs | 6 +++--- src/Simplex/Chat/Protocol.hs | 26 ++++++++++++++++++++------ src/Simplex/Chat/View.hs | 7 +++++-- 4 files changed, 37 insertions(+), 20 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index fe86fcdd73..b916f3f336 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -740,7 +740,7 @@ processChatCommand = \case SndMessage {msgId} <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId $ Just memberId delGroupChatItem user gInfo ci msgId (Just membership) (_, _) -> throwChatError CEInvalidChatItemDelete - APIChatItemReaction (ChatRef cType chatId) itemId reaction add -> withUser $ \user -> withChatLock "chatItemReaction" $ case cType of + APIChatItemReaction (ChatRef cType chatId) itemId add reaction -> withUser $ \user -> withChatLock "chatItemReaction" $ case cType of CTDirect -> withStore (\db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId) >>= \case (ct, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do @@ -757,7 +757,7 @@ processChatCommand = \case liftIO $ getDirectCIReactions db ct itemSharedMId let ci' = CChatItem md ci {reactions} r = ACIReaction SCTDirect SMDSnd (DirectChat ct) $ CIReaction CIDirectSnd ci' createdAt reaction - pure $ CRChatItemReaction user r add + pure $ CRChatItemReaction user add r _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" CTGroup -> withStore (\db -> (,) <$> getGroup db user chatId <*> getGroupChatItem db user chatId itemId) >>= \case @@ -776,7 +776,7 @@ processChatCommand = \case liftIO $ getGroupCIReactions db g itemMemberId itemSharedMId let ci' = CChatItem md ci {reactions} r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction CIGroupSnd ci' createdAt reaction - pure $ CRChatItemReaction user r add + pure $ CRChatItemReaction user add r _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" @@ -1287,10 +1287,10 @@ processChatCommand = \case chatRef <- getChatRef user chatName let mc = MCText msg processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc - ReactToMessage chatName msg reaction add -> withUser $ \user -> do + ReactToMessage add reaction chatName msg -> withUser $ \user -> do chatRef <- getChatRef user chatName chatItemId <- getChatItemIdByText user chatRef msg - processChatCommand $ APIChatItemReaction chatRef chatItemId reaction add + processChatCommand $ APIChatItemReaction chatRef chatItemId add reaction APINewGroup userId gProfile -> withUserId userId $ \user -> do gVar <- asks idsDrg groupInfo <- withStore $ \db -> createNewGroup db gVar user gProfile @@ -3443,7 +3443,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do reactions <- getDirectCIReactions db ct sharedMsgId let ci' = CChatItem md ci {reactions} r = ACIReaction SCTDirect SMDRcv (DirectChat ct) $ CIReaction CIDirectRcv ci' brokerTs reaction - pure $ Just $ CRChatItemReaction user r add + pure $ Just $ CRChatItemReaction user add r else pure Nothing mapM_ toView cr_ @@ -3464,7 +3464,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do reactions <- getGroupCIReactions db g itemMemberId sharedMsgId let ci' = CChatItem md ci {reactions} r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction - pure $ Just $ CRChatItemReaction user r add + pure $ Just $ CRChatItemReaction user add r else pure Nothing mapM_ toView cr_ @@ -4765,7 +4765,7 @@ chatCommandP = "/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP), "/_delete item " *> (APIDeleteChatItem <$> chatRefP <* A.space <*> A.decimal <* A.space <*> ciDeleteMode), "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <* A.space <*> A.decimal <* A.space <*> A.decimal), - "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> reactionP <* A.space <*> onOffP), + "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP), "/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))), "/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP), "/_delete " *> (APIDeleteChat <$> chatRefP), @@ -4884,7 +4884,7 @@ chatCommandP = ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> textP), ("\\\\ #" <|> "\\\\#") *> (DeleteMemberMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> textP), ("! " <|> "!") *> (EditMessage <$> chatNameP <* A.space <*> (quotedMsg <|> pure "") <*> msgTextP), - (("+" $> True) <|> ("-" $> False)) >>= \add -> reactionP <* A.space >>= \reaction -> ReactToMessage <$> chatNameP' <* A.space <*> textP <*> pure reaction <*> pure add, + ReactToMessage <$> (("+" $> True) <|> ("-" $> False)) <*> reactionP <* A.space <*> chatNameP' <* A.space <*> textP, "/feed " *> (SendMessageBroadcast <$> msgTextP), ("/chats" <|> "/cs") *> (LastChats <$> (" all" $> Nothing <|> Just <$> (A.space *> A.decimal <|> pure 20))), ("/tail" <|> "/t") *> (LastMessages <$> optional (A.space *> chatNameP) <*> msgCountP <*> pure Nothing), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 2dc683d4dc..cfed01e0e1 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -219,7 +219,7 @@ data ChatCommand | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode | APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId - | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, reaction :: MsgReaction, add :: Bool} + | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) | APIChatUnread ChatRef Bool | APIDeleteChat ChatRef @@ -321,7 +321,7 @@ data ChatCommand | DeleteMemberMessage GroupName ContactName Text | EditMessage {chatName :: ChatName, editedMsg :: Text, message :: Text} | UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text} - | ReactToMessage {chatName :: ChatName, reactToMessage :: Text, reaction :: MsgReaction, add :: Bool} + | ReactToMessage {add :: Bool, reaction :: MsgReaction, chatName :: ChatName, reactToMessage :: Text} | APINewGroup UserId GroupProfile | NewGroup GroupProfile | AddMember GroupName ContactName GroupMemberRole @@ -401,7 +401,7 @@ data ChatResponse | CRChatItemStatusUpdated {user :: User, chatItem :: AChatItem} | CRChatItemUpdated {user :: User, chatItem :: AChatItem} | CRChatItemNotChanged {user :: User, chatItem :: AChatItem} - | CRChatItemReaction {user :: User, reaction :: ACIReaction, added :: Bool} + | CRChatItemReaction {user :: User, added :: Bool, reaction :: ACIReaction} | CRChatItemDeleted {user :: User, deletedChatItem :: AChatItem, toChatItem :: Maybe AChatItem, byUser :: Bool, timed :: Bool} | CRChatItemDeletedNotFound {user :: User, contact :: Contact, sharedMsgId :: SharedMsgId} | CRBroadcastSent User MsgContent Int ZonedTime diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 36ff3927f7..dea2b5557b 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -28,6 +28,7 @@ import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy.Char8 as LB import Data.Maybe (fromMaybe) +import Data.String import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -225,15 +226,28 @@ data AChatMsgEvent = forall e. MsgEncodingI e => ACME (SMsgEncoding e) (ChatMsgE deriving instance Show AChatMsgEvent -data MsgReaction = MREmoji {emoji :: MREmojiChar} - deriving (Eq, Show, Generic) +data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} + deriving (Eq, Show) -instance ToJSON MsgReaction where - toEncoding = J.genericToEncoding . taggedObjectJSON $ dropPrefix "MR" - toJSON = J.genericToJSON . taggedObjectJSON $ dropPrefix "MR" +emojiTag :: IsString a => a +emojiTag = "emoji" instance FromJSON MsgReaction where - parseJSON = J.genericParseJSON . taggedObjectJSON $ dropPrefix "MR" + parseJSON (J.Object v) = do + tag <- v .: "type" + if tag == emojiTag + then (MREmoji <$> v .: emojiTag) <|> pure (MRUnknown tag v) + else pure $ MRUnknown tag v + parseJSON invalid = + JT.prependFailure "bad MsgContent, " (JT.typeMismatch "Object" invalid) + +instance ToJSON MsgReaction where + toJSON = \case + MRUnknown {json} -> J.Object json + MREmoji emoji -> J.object ["type" .= (emojiTag :: Text), emojiTag .= emoji] + toEncoding = \case + MRUnknown {json} -> JE.value $ J.Object json + MREmoji emoji -> J.pairs $ "type" .= (emojiTag :: Text) <> emojiTag .= emoji instance ToField MsgReaction where toField = toField . encodeJSON diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index dfd5d73302..2088894126 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -91,7 +91,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewItemUpdate chat item liveItems ts CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts testView - CRChatItemReaction u (ACIReaction _ _ chat reaction) added -> ttyUser u $ unmutedReaction chat reaction $ viewItemReaction showReactions chat reaction added ts tz + CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction chat reaction $ viewItemReaction showReactions chat reaction added ts tz CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"] CRBroadcastSent u mc n t -> ttyUser u $ viewSentBroadcast mc n ts t CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr @@ -536,13 +536,16 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md | showReactions = viewReceivedReaction from msg reactionText ts $ utcToZonedTime tz sentAt | otherwise = [] reactionText = plain $ (if added then "+ " else "- ") <> [emoji] - MREmoji (MREmojiChar emoji) = reaction + emoji = case reaction of + MREmoji (MREmojiChar c) -> c + _ -> '?' sentText = plain $ (if added then "added " else "removed ") <> [emoji] viewItemReactions :: ChatItem c d -> [StyledString] viewItemReactions ChatItem {reactions} = [" " <> viewReactions reactions | not (null reactions)] where viewReactions = mconcat . intersperse " " . map viewReaction + viewReaction CIReactionCount {reaction = MRUnknown {}} = "?" viewReaction CIReactionCount {reaction = MREmoji (MREmojiChar emoji), userReacted, totalReacted} = plain [emoji, ' '] <> (if userReacted then styled Italic else plain) (show totalReacted)