core: use JSON in reactions api, forward compatible JSON parsing for reactions (#2449)

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

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

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)