core: apiGetReactionMembers api implementation (#5263)

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),

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

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)
 

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"