From b49f0d211beb100f5f64ee6b48e9dd40eee90333 Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 16 May 2023 19:37:45 +0200 Subject: [PATCH 1/2] cli: amend help messages (#2447) * cli: amend help messages * print servers on multiple lines * correction * fix tests --- src/Simplex/Chat/Help.hs | 3 ++- src/Simplex/Chat/View.hs | 31 +++++++++++++++---------------- tests/ChatTests/Direct.hs | 18 ++++++++++++------ 3 files changed, 29 insertions(+), 23 deletions(-) diff --git a/src/Simplex/Chat/Help.hs b/src/Simplex/Chat/Help.hs index 1f77617af1..8997f150d6 100644 --- a/src/Simplex/Chat/Help.hs +++ b/src/Simplex/Chat/Help.hs @@ -270,7 +270,8 @@ settingsInfo = [ green "Chat settings:", indent <> highlight "/incognito on/off " <> " - enable/disable incognito mode", indent <> highlight "/network " <> " - show / set network access options", - indent <> highlight "/smp " <> " - show / set custom SMP servers", + indent <> highlight "/smp " <> " - show / set configured SMP servers", + indent <> highlight "/xftp " <> " - show / set configured XFTP servers", indent <> highlight "/info " <> " - information about contact connection", indent <> highlight "/info # " <> " - information about member connection", indent <> highlight "/(un)mute " <> " - (un)mute contact, the last messages can be printed with /tail command", diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 6937fe8180..dfd5d73302 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -49,7 +49,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, taggedObjectJSON) -import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtocolServer (..), ProtocolTypeI, SProtocolType (..)) +import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType, ProtocolServer (..), ProtoServerWithAuth, ProtocolTypeI, SProtocolType (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.Transport.Client (TransportHost (..)) import Simplex.Messaging.Util (bshow, tshow) @@ -829,18 +829,17 @@ viewUserPrivacy User {userId} User {userId = userId', localDisplayName = n', sho "profile is " <> if isJust viewPwdHash then "hidden" else "visible" ] --- TODO make more generic messages or split viewUserServers :: AUserProtoServers -> Bool -> [StyledString] -viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers}) testView = - if testView - then [customServers] - else - [ customServers, - "", - "use " <> highlight (srvCmd <> " test ") <> " to test " <> pName <> " server connection", - "use " <> highlight (srvCmd <> " set ") <> " to switch to custom " <> pName <> " servers", - "use " <> highlight (srvCmd <> " default") <> " to remove custom " <> pName <> " servers and use default" - ] +viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers, presetServers}) testView = + customServers <> + if testView + then [] + else + [ "", + "use " <> highlight (srvCmd <> " test ") <> " to test " <> pName <> " server connection", + "use " <> highlight (srvCmd <> " ") <> " to configure " <> pName <> " servers", + "use " <> highlight (srvCmd <> " default") <> " to remove configured " <> pName <> " servers and use presets" + ] <> case p of SPSMP -> ["(chat option " <> highlight' "-s" <> " (" <> highlight' "--server" <> ") has precedence over saved SMP servers for chat session)"] SPXFTP -> ["(chat option " <> highlight' "-xftp-servers" <> " has precedence over saved XFTP servers for chat session)"] @@ -849,8 +848,8 @@ viewUserServers (AUPS UserProtoServers {serverProtocol = p, protoServers}) testV pName = protocolName p customServers = if null protoServers - then "no custom SMP servers saved" - else viewServers protoServers + then ("no " <> pName <> " servers saved, using presets: ") : viewServers id presetServers + else viewServers (\ServerCfg {server} -> server) protoServers protocolName :: ProtocolTypeI p => SProtocolType p -> StyledString protocolName = plain . map toUpper . T.unpack . decodeLatin1 . strEncode @@ -918,8 +917,8 @@ viewConnectionStats ConnectionStats {rcvServers, sndServers} = ["receiving messages via: " <> viewServerHosts rcvServers | not $ null rcvServers] <> ["sending messages via: " <> viewServerHosts sndServers | not $ null sndServers] -viewServers :: ProtocolTypeI p => NonEmpty (ServerCfg p) -> StyledString -viewServers = plain . intercalate ", " . map (B.unpack . strEncode . (\ServerCfg {server} -> server)) . L.toList +viewServers :: ProtocolTypeI p => (a -> ProtoServerWithAuth p) -> NonEmpty a -> [StyledString] +viewServers f = map (plain . B.unpack . strEncode . f) . L.toList viewServerHosts :: [SMPServer] -> StyledString viewServerHosts = plain . intercalate ", " . map showSMPServer diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 67f6171a1d..1990012818 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -518,7 +518,8 @@ testGetSetSMPServers = alice #$> ("/smp smp://1234-w==:password@smp1.example.im", id, "ok") alice #$> ("/smp", id, "smp://1234-w==:password@smp1.example.im") alice #$> ("/smp smp://2345-w==@smp2.example.im;smp://3456-w==@smp3.example.im:5224", id, "ok") - alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im, smp://3456-w==@smp3.example.im:5224") + alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im") + alice <## "smp://3456-w==@smp3.example.im:5224" alice #$> ("/smp default", id, "ok") alice #$> ("/smp", id, "smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7001") @@ -547,7 +548,8 @@ testGetSetXFTPServers = alice #$> ("/xftp xftp://1234-w==:password@xftp1.example.im", id, "ok") alice #$> ("/xftp", id, "xftp://1234-w==:password@xftp1.example.im") alice #$> ("/xftp xftp://2345-w==@xftp2.example.im;xftp://3456-w==@xftp3.example.im:5224", id, "ok") - alice #$> ("/xftp", id, "xftp://2345-w==@xftp2.example.im, xftp://3456-w==@xftp3.example.im:5224") + alice #$> ("/xftp", id, "xftp://2345-w==@xftp2.example.im") + alice <## "xftp://3456-w==@xftp3.example.im:5224" alice #$> ("/xftp default", id, "ok") alice #$> ("/xftp", id, "xftp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:7002") @@ -1129,7 +1131,8 @@ testCreateUserDefaultServers = testChat2 aliceProfile bobProfile $ \alice _ -> do alice #$> ("/smp smp://2345-w==@smp2.example.im;smp://3456-w==@smp3.example.im:5224", id, "ok") - alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im, smp://3456-w==@smp3.example.im:5224") + alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im") + alice <## "smp://3456-w==@smp3.example.im:5224" alice ##> "/create user alisa" showActiveUser alice "alisa" @@ -1139,7 +1142,8 @@ testCreateUserDefaultServers = -- with same_smp=off alice ##> "/user alice" showActiveUser alice "alice (Alice)" - alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im, smp://3456-w==@smp3.example.im:5224") + alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im") + alice <## "smp://3456-w==@smp3.example.im:5224" alice ##> "/create user same_smp=off alisa2" showActiveUser alice "alisa2" @@ -1151,12 +1155,14 @@ testCreateUserSameServers = testChat2 aliceProfile bobProfile $ \alice _ -> do alice #$> ("/smp smp://2345-w==@smp2.example.im;smp://3456-w==@smp3.example.im:5224", id, "ok") - alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im, smp://3456-w==@smp3.example.im:5224") + alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im") + alice <## "smp://3456-w==@smp3.example.im:5224" alice ##> "/create user same_smp=on alisa" showActiveUser alice "alisa" - alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im, smp://3456-w==@smp3.example.im:5224") + alice #$> ("/smp", id, "smp://2345-w==@smp2.example.im") + alice <## "smp://3456-w==@smp3.example.im:5224" testDeleteUser :: HasCallStack => FilePath -> IO () testDeleteUser = 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 2/2] 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)