core: use JSON in reactions api, forward compatible JSON parsing for reactions (#2449)
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
b49f0d211b
commit
922e95756a
@@ -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),
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
Reference in New Issue
Block a user