IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'master' into master-ios

Browse Source
This commit is contained in:
Evgeny Poberezkin
2023-05-17 00:23:36 +01:00
parent 2a9f98e43f 922e95756a
commit b8b4ef39e9
6 changed files with 66 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
src/Simplex/Chat.hs
View File

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

6
src/Simplex/Chat/Controller.hs
View File

@@ -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

3
src/Simplex/Chat/Help.hs
View File

@@ -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 <contact> " <> " - information about contact connection",
indent <> highlight "/info #<group> <member> " <> " - information about member connection",
indent <> highlight "/(un)mute <contact> " <> " - (un)mute contact, the last messages can be printed with /tail command",

26
src/Simplex/Chat/Protocol.hs
View File

@@ -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

38
src/Simplex/Chat/View.hs
View File

@@ -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)
@@ -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)
@@ -829,18 +832,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 <srv>") <> " to test " <> pName <> " server connection",
"use " <> highlight (srvCmd <> " set <srv1[,srv2,...]>") <> " 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 <srv>") <> " to test " <> pName <> " server connection",
"use " <> highlight (srvCmd <> " <srv1[,srv2,...]>") <> " 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 +851,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 +920,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

18
tests/ChatTests/Direct.hs
View File

@@ -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 =