diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 707163fde7..66c11dac15 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -316,7 +316,7 @@ newChatController randomPresetServers <- chooseRandomServers presetServers' let rndSrvs = L.toList randomPresetServers operatorWithId (i, op) = (\o -> o {operatorId = DBEntityId i}) <$> pOperator op - opDomains = operatorDomains $ mapMaybe operatorWithId $ zip [1..] rndSrvs + opDomains = operatorDomains $ mapMaybe operatorWithId $ zip [1 ..] rndSrvs agentSMP <- randomServerCfgs "agent SMP servers" SPSMP opDomains rndSrvs agentXFTP <- randomServerCfgs "agent XFTP servers" SPXFTP opDomains rndSrvs let randomAgentServers = RandomAgentServers {smpServers = agentSMP, xftpServers = agentXFTP} @@ -1078,8 +1078,11 @@ processChatCommand' vr = \case throwChatError (CECommandError $ "reaction already " <> if add then "added" else "removed") when (add && length rs >= maxMsgReactions) $ throwChatError (CECommandError "too many reactions") - APIGetReactionMembers _userId _groupId _itemId _reaction -> withUser $ \user -> do - pure $ chatCmdError (Just user) "not supported" + APIGetReactionMembers userId groupId itemId reaction -> withUserId userId $ \user -> do + memberReactions <- withStore $ \db -> do + CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}} <- getGroupChatItem db user groupId itemId + liftIO $ getReactionMembers db groupId itemSharedMId reaction + pure $ CRReactionMembers user memberReactions APIPlanForwardChatItems (ChatRef fromCType fromChatId) itemIds -> withUser $ \user -> case fromCType of CTDirect -> planForward user . snd =<< getCommandDirectChatItems user fromChatId itemIds CTGroup -> planForward user . snd =<< getCommandGroupChatItems user fromChatId itemIds @@ -1633,7 +1636,7 @@ processChatCommand' vr = \case liftIO $ fmap (opsConds,) . mapM (getServers db as ops' opDomains) =<< getUsers db lift $ withAgent' $ \a -> forM_ srvs $ \(auId, (smp', xftp')) -> do setProtocolServers a auId smp' - setProtocolServers a auId xftp' + setProtocolServers a auId xftp' pure $ CRServerOperatorConditions opsConds where getServers :: DB.Connection -> RandomAgentServers -> [Maybe ServerOperator] -> [(Text, ServerOperator)] -> User -> IO (UserId, (NonEmpty (ServerCfg 'PSMP), NonEmpty (ServerCfg 'PXFTP))) @@ -1942,7 +1945,7 @@ processChatCommand' vr = \case canKeepLink (CRInvitationUri crData _) newUser = do let ConnReqUriData {crSmpQueues = q :| _} = crData SMPQueueUri {queueAddress = SMPQueueAddress {smpServer}} = q - newUserServers <- + newUserServers <- map protoServer' . L.filter (\ServerCfg {enabled} -> enabled) <$> getKnownAgentServers SPSMP newUser pure $ smpServer `elem` newUserServers @@ -3430,7 +3433,7 @@ processChatCommand' vr = \case msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId) CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId) -protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) +protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) protocolServers p (operators, smpServers, xftpServers) = case p of SPSMP -> (operators, smpServers, []) SPXFTP -> (operators, [], xftpServers) @@ -8269,7 +8272,7 @@ chatCommandP = "/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <* A.space <*> ciDeleteMode), "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP), "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP), - "/_reaction members " *> (APIGetReactionMembers <$> A.decimal <* A.space <*> A.decimal <* A.space <*> A.decimal <* A.space <*> jsonP), + "/_reaction members " *> (APIGetReactionMembers <$> A.decimal <* " #" <*> A.decimal <* A.space <*> A.decimal <* A.space <*> jsonP), "/_forward plan " *> (APIPlanForwardChatItems <$> chatRefP <*> _strP), "/_forward " *> (APIForwardChatItems <$> chatRefP <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP), "/_read user " *> (APIUserRead <$> A.decimal), diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index a79eb98f14..74951cf3d1 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -76,6 +76,7 @@ module Simplex.Chat.Store.Messages getGroupCIReactions, getGroupReactions, setGroupReaction, + getReactionMembers, getChatItemIdsByAgentMsgId, getDirectChatItem, getDirectCIWithReactions, @@ -2852,6 +2853,21 @@ setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reacti |] (groupId, groupMemberId' m, itemSharedMId, itemMemberId, sent, reaction) +getReactionMembers :: DB.Connection -> GroupId -> SharedMsgId -> MsgReaction -> IO [MemberReaction] +getReactionMembers db groupId itemSharedMId reaction = + map toMemberReaction + <$> DB.query + db + [sql| + SELECT group_member_id, reaction_ts + FROM chat_item_reactions + WHERE group_id = ? AND shared_msg_id = ? AND reaction = ? + |] + (groupId, itemSharedMId, reaction) + where + toMemberReaction :: (GroupMemberId, UTCTime) -> MemberReaction + toMemberReaction (groupMemberId, reactionTs) = MemberReaction {groupMemberId, reactionTs} + getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)] getTimedItems db User {userId} startTimedThreadCutoff = mapMaybe toCIRefDeleteAt diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index e0c836d8d7..093d750a42 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -154,7 +154,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView deletions' -> ttyUser u [sShow (length deletions') <> " messages deleted"] CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction u chat reaction $ viewItemReaction showReactions chat reaction added ts tz - CRReactionMembers u memberReactions -> [] + CRReactionMembers u memberReactions -> ttyUser u $ viewReactionMembers memberReactions CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"] CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr @@ -848,6 +848,9 @@ viewItemReactions ChatItem {reactions} = [" " <> viewReactions reactions | viewReaction CIReactionCount {reaction = MREmoji (MREmojiChar emoji), userReacted, totalReacted} = plain [emoji, ' '] <> (if userReacted then styled Italic else plain) (show totalReacted) +viewReactionMembers :: [MemberReaction] -> [StyledString] +viewReactionMembers memberReactions = [sShow (length memberReactions) <> " member(s) reacted"] + directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString] directQuote _ CIQuote {content = qmc, chatDir = quoteDir} = quoteText qmc $ if toMsgDirection (msgDirection @d') == quoteMsgDirection quoteDir then ">>" else ">" @@ -1227,7 +1230,7 @@ viewUserServers UserOperatorServers {operator, smpServers, xftpServers} = viewServers p srvs | maybe True (\ServerOperator {enabled} -> enabled) operator = [" " <> protocolName p <> " servers" <> maybe "" ((" " <>) . viewRoles) operator] - <> map (plain . (" " <> ) . viewServer) srvs + <> map (plain . (" " <>) . viewServer) srvs | otherwise = [] where viewServer UserServer {server, preset, tested, enabled} = safeDecodeUtf8 (strEncode server) <> serverInfo @@ -1280,7 +1283,7 @@ viewOperator op@ServerOperator {tradeName, legalName, serverDomains, conditionsA viewOpIdTag op <> tradeName <> maybe "" parens legalName - <> (", domains: " <> T.intercalate ", " serverDomains) + <> (", domains: " <> T.intercalate ", " serverDomains) <> (", servers: " <> viewOpEnabled op) <> (", conditions: " <> viewOpConditions conditionsAcceptance) diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index bdd3b53829..a1d9951088 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -3738,6 +3738,9 @@ testSetGroupMessageReactions = cath ##> "/tail #team 1" cath <# "#team alice> hi" cath <## " 👍 2 🚀 1" + itemId' <- lastItemId alice + alice ##> ("/_reaction members 1 #1 " <> itemId' <> " {\"type\": \"emoji\", \"emoji\": \"👍\"}") + alice <## "2 member(s) reacted" bob ##> "-1 #team hi" bob <## "removed 👍" alice <# "#team bob> > alice hi"