Revert "core: direct messages in group (#2994)"
This reverts commit 5fddf64adb.
This commit is contained in:
spaced4ndy
parent
75f18bc5f0
commit
01f99baaac
@ -111,7 +111,6 @@ library
|
||||
Simplex.Chat.Migrations.M20230827_file_encryption
|
||||
Simplex.Chat.Migrations.M20230829_connections_chat_vrange
|
||||
Simplex.Chat.Migrations.M20230903_connections_to_subscribe
|
||||
Simplex.Chat.Migrations.M20230904_item_direct_group_member_id
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
|
||||
@ -540,8 +540,8 @@ processChatCommand = \case
|
||||
memStatuses -> pure $ Just $ map (uncurry MemberDeliveryStatus) memStatuses
|
||||
_ -> pure Nothing
|
||||
pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses}
|
||||
APISendMessage sendRef live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case sendRef of
|
||||
SRDirect chatId -> do
|
||||
APISendMessage (ChatRef cType chatId) live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {contactId, localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
assertDirectAllowed user MDSnd ct XMsgNew_
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
@ -567,7 +567,7 @@ processChatCommand = \case
|
||||
(fileSize, fileMode) <- checkSndFile mc file 1
|
||||
case fileMode of
|
||||
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
||||
SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ SDDirect ct
|
||||
SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ CGContact ct
|
||||
where
|
||||
smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled
|
||||
@ -590,38 +590,36 @@ processChatCommand = \case
|
||||
pure (fileInvitation, ciFile, ft)
|
||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
|
||||
prepareMsg fInv_ timed_ = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Nothing)
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
Just quotedItemId -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
withStore $ \db -> getDirectChatItem db user chatId quotedItemId
|
||||
(origQmc, qd, sent) <- quoteData qci
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing, msgScope = Nothing}
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing}
|
||||
qmc = quoteContent origQmc file
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Just quotedItem)
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
where
|
||||
quoteData :: ChatItem c d -> m (MsgContent, CIQDirection 'CTDirect, Bool)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote
|
||||
quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
|
||||
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
|
||||
quoteData _ = throwChatError CEInvalidQuote
|
||||
SRGroup chatId directMemberId -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user chatId
|
||||
directMember <- forM directMemberId $ \dmId -> withStore $ \db -> getGroupMember db user chatId dmId
|
||||
assertGroupSendAllowed gInfo directMember
|
||||
send gInfo directMember
|
||||
CTGroup -> do
|
||||
g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
send g
|
||||
where
|
||||
send gInfo@GroupInfo {groupId, membership, localDisplayName = gName} directMember
|
||||
send g@(Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms)
|
||||
| isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice
|
||||
| not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles
|
||||
| otherwise = do
|
||||
ms <- getReceivingMembers user gInfo directMember
|
||||
(fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo ms (length ms)
|
||||
(fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms)
|
||||
timed_ <- sndGroupCITimed live gInfo itemTTL
|
||||
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership directMember
|
||||
(msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership
|
||||
(msg@SndMessage {sharedMsgId}, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer)
|
||||
mapM_ (sendGroupFileInline ms sharedMsgId) ft_
|
||||
ci <- saveSndChatItem' user (CDGroupSnd gInfo directMember) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
|
||||
ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
|
||||
withStore' $ \db ->
|
||||
forM_ sentToMembers $ \GroupMember {groupMemberId} ->
|
||||
createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew
|
||||
@ -630,12 +628,12 @@ processChatCommand = \case
|
||||
setActive $ ActiveG gName
|
||||
pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f))
|
||||
setupSndFileTransfer :: GroupInfo -> [GroupMember] -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
|
||||
setupSndFileTransfer gInfo ms n = forM file_ $ \file -> do
|
||||
setupSndFileTransfer :: Group -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
|
||||
setupSndFileTransfer g@(Group gInfo _) n = forM file_ $ \file -> do
|
||||
(fileSize, fileMode) <- checkSndFile mc file $ fromIntegral n
|
||||
case fileMode of
|
||||
SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline
|
||||
SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ SDGroup gInfo ms
|
||||
SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ CGGroup g
|
||||
where
|
||||
smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled
|
||||
@ -659,44 +657,25 @@ processChatCommand = \case
|
||||
void . withStore' $ \db -> createSndGroupInlineFT db m conn ft
|
||||
sendMemberFileInline m conn ft sharedMsgId
|
||||
processMember _ = pure ()
|
||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> Maybe GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
|
||||
prepareMsg fInv_ timed_ membership directMember = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live) (Just msgScope)), Nothing)
|
||||
prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
|
||||
prepareMsg fInv_ timed_ membership = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing)
|
||||
Just quotedItemId -> do
|
||||
CChatItem _ qci@ChatItem {chatDir = quoteChatDir, meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
withStore $ \db -> getGroupChatItem db user chatId quotedItemId
|
||||
let qMsgScope = directMemberToMsgScope $ ciDirDirectMember quoteChatDir
|
||||
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership qMsgScope
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId, msgScope = Just qMsgScope}
|
||||
(origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId}
|
||||
qmc = quoteContent origQmc file
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just $ chatItemId' qci, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live) (Just msgScope)), Just quotedItem)
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
|
||||
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
|
||||
where
|
||||
msgScope = directMemberToMsgScope directMember
|
||||
quoteData :: ChatItem c d -> GroupMember -> MessageScope -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ _ =
|
||||
throwChatError CEInvalidQuote
|
||||
quoteData ChatItem {chatDir = qChatDir@(CIGroupSnd _), content = CISndMsgContent qmc} membership' qMsgScope =
|
||||
checkDirDirectMember qChatDir $ pure (qmc, CIQGroupSnd qMsgScope, True, membership')
|
||||
quoteData ChatItem {chatDir = qChatDir@(CIGroupRcv m _), content = CIRcvMsgContent qmc} _ qMsgScope =
|
||||
checkDirDirectMember qChatDir $ pure (qmc, CIQGroupRcv (Just m) qMsgScope, False, m)
|
||||
quoteData _ _ _ =
|
||||
throwChatError CEInvalidQuote
|
||||
-- can quote:
|
||||
-- - group message to group (Nothing, Nothing)
|
||||
-- - group message to direct member (Nothing, Just)
|
||||
-- - direct message to the same direct member (Just, Just, same Id)
|
||||
-- can't quote:
|
||||
-- - direct message to group (Just, Nothing)
|
||||
-- - direct message to another direct member (Just, Just, different Id)
|
||||
checkDirDirectMember :: CIDirection 'CTGroup d -> m a -> m a
|
||||
checkDirDirectMember quoteChatDir a = case (ciDirDirectMember quoteChatDir, directMember) of
|
||||
(Nothing, Nothing) -> a
|
||||
(Nothing, Just _) -> a
|
||||
(Just _, Nothing) -> throwChatError CEInvalidQuote
|
||||
(Just GroupMember {groupMemberId = dirDirectMemId}, Just GroupMember {groupMemberId = directMemId})
|
||||
| directMemId == dirDirectMemId -> a
|
||||
| otherwise -> throwChatError CEInvalidQuote
|
||||
quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote
|
||||
quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership')
|
||||
quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m)
|
||||
quoteData _ _ = throwChatError CEInvalidQuote
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
where
|
||||
quoteContent :: forall d. MsgContent -> Maybe (CIFile d) -> MsgContent
|
||||
quoteContent qmc ciFile_
|
||||
@ -721,8 +700,8 @@ processChatCommand = \case
|
||||
qText = msgContentText qmc
|
||||
qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_
|
||||
qTextOrFile = if T.null qText then qFileName else qText
|
||||
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> SendDirection -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n sendDirection = do
|
||||
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do
|
||||
let fileName = takeFileName filePath
|
||||
fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
|
||||
fInv = xftpFileInvitation fileName fileSize fileDescr
|
||||
@ -731,20 +710,19 @@ processChatCommand = \case
|
||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n)
|
||||
-- TODO CRSndFileStart event for XFTP
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
let contactOrGroup = sendDirToContactOrGroup sendDirection
|
||||
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv (AgentSndFileId aFileId) chSize
|
||||
let fileSource = Just $ CryptoFile filePath cfArgs
|
||||
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
|
||||
case sendDirection of
|
||||
SDDirect Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr
|
||||
SDGroup _ ms -> forM_ ms $ \m -> saveMemberFD ft fileDescr m `catchChatError` (toView . CRChatError (Just user))
|
||||
pure (fInv, ciFile, ft)
|
||||
case contactOrGroup of
|
||||
CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr
|
||||
CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user))
|
||||
where
|
||||
-- we are not sending files to pending members, same as with inline files
|
||||
saveMemberFD ft fileDescr m@GroupMember {activeConn = Just conn@Connection {connStatus}} =
|
||||
saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} =
|
||||
when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $
|
||||
withStore' $ \db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr
|
||||
saveMemberFD _ _ _ = pure ()
|
||||
saveMemberFD _ = pure ()
|
||||
pure (fInv, ciFile, ft)
|
||||
unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c)
|
||||
unzipMaybe3 (Just (a, b, c)) = (Just a, Just b, Just c)
|
||||
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
|
||||
@ -772,18 +750,17 @@ processChatCommand = \case
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
|
||||
CTGroup -> do
|
||||
aci <- withStore $ \db -> getAChatItem db user (ChatRef CTGroup chatId) itemId
|
||||
case aci of
|
||||
AChatItem _ _ (GroupChat gInfo) ci@ChatItem {chatDir = CIGroupSnd directMember, meta = CIMeta {itemSharedMsgId = Just sharedMsgId, editable = True}, content = CISndMsgContent oldMC} -> do
|
||||
let GroupInfo {groupId, localDisplayName = gName} = gInfo
|
||||
ChatItem {meta = CIMeta {itemTimed, itemLive}} = ci
|
||||
changed = mc /= oldMC
|
||||
Group gInfo@GroupInfo {groupId, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
cci <- withStore $ \db -> getGroupChatItem db user chatId itemId
|
||||
case cci of
|
||||
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
|
||||
case (ciContent, itemSharedMsgId, editable) of
|
||||
(CISndMsgContent oldMC, Just itemSharedMId, True) -> do
|
||||
let changed = mc /= oldMC
|
||||
if changed || fromMaybe False itemLive
|
||||
then do
|
||||
(ms, directMember') <- getReceivingMembers' user gInfo directMember
|
||||
assertGroupSendAllowed gInfo directMember'
|
||||
let msg = XMsgUpdate sharedMsgId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)
|
||||
(SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms msg
|
||||
(SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive))
|
||||
ci' <- withStore' $ \db -> do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
when changed $
|
||||
@ -794,6 +771,7 @@ processChatCommand = \case
|
||||
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
|
||||
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of
|
||||
@ -810,25 +788,22 @@ processChatCommand = \case
|
||||
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
|
||||
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
CTGroup -> do
|
||||
aci <- withStore $ \db -> getAChatItem db user (ChatRef CTGroup chatId) itemId
|
||||
case (mode, aci) of
|
||||
(CIDMInternal, AChatItem _ md (GroupChat gInfo) ci) -> do
|
||||
let cci = CChatItem md ci
|
||||
deleteGroupCI user gInfo cci True False Nothing =<< liftIO getCurrentTime
|
||||
(CIDMBroadcast, AChatItem _ _ (GroupChat gInfo) ci@ChatItem {chatDir = CIGroupSnd directMember, meta = CIMeta {itemSharedMsgId = Just sharedMsgId, editable = True}}) -> do
|
||||
assertUserMembershipStatus gInfo -- can delete messages sent earlier in any role
|
||||
(ms, _) <- getReceivingMembers' user gInfo directMember
|
||||
(SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel sharedMsgId Nothing
|
||||
let cci = CChatItem SMDSnd ci
|
||||
delGroupChatItem user gInfo cci msgId Nothing
|
||||
_ -> throwChatError CEInvalidChatItemDelete
|
||||
Group gInfo ms <- withStore $ \db -> getGroup db user chatId
|
||||
ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId
|
||||
case (mode, msgDir, itemSharedMsgId, editable) of
|
||||
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
|
||||
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
|
||||
assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier
|
||||
(SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId Nothing
|
||||
delGroupChatItem user gInfo ci msgId Nothing
|
||||
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do
|
||||
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db user gId
|
||||
ci@(CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user gId itemId
|
||||
case (chatDir, itemSharedMsgId) of
|
||||
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId} MSGroup, Just itemSharedMId) -> do
|
||||
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
|
||||
when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete
|
||||
assertUserGroupRole gInfo $ max GRAdmin memberRole
|
||||
(SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId $ Just memberId
|
||||
@ -854,15 +829,13 @@ processChatCommand = \case
|
||||
pure $ CRChatItemReaction user add r
|
||||
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
|
||||
CTGroup ->
|
||||
withStore (\db -> getAChatItem db user (ChatRef CTGroup chatId) itemId) >>= \case
|
||||
(AChatItem _ md (GroupChat g@GroupInfo {membership}) ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do
|
||||
withStore (\db -> (,) <$> getGroup db user chatId <*> getGroupChatItem db user chatId itemId) >>= \case
|
||||
(Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do
|
||||
unless (groupFeatureAllowed SGFReactions g) $
|
||||
throwChatError $ CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)
|
||||
unless (ciReactionAllowed ci) $
|
||||
throwChatError $ CECommandError "reaction not allowed - chat item has no content"
|
||||
let GroupMember {memberId = itemMemberId} = chatItemMember g ci
|
||||
directMember = ciDirDirectMember chatDir
|
||||
(ms, _) <- getReceivingMembers' user g directMember
|
||||
rs <- withStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True
|
||||
checkReactionAllowed rs
|
||||
(SndMessage {msgId}, _) <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add)
|
||||
@ -871,7 +844,7 @@ processChatCommand = \case
|
||||
setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt
|
||||
liftIO $ getGroupCIReactions db g itemMemberId itemSharedMId
|
||||
let ci' = CChatItem md ci {reactions}
|
||||
r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction (CIGroupSnd directMember) ci' createdAt reaction
|
||||
r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction CIGroupSnd ci' createdAt reaction
|
||||
pure $ CRChatItemReaction user add r
|
||||
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
|
||||
@ -1235,7 +1208,7 @@ processChatCommand = \case
|
||||
case memberConnId m of
|
||||
Just connId -> do
|
||||
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force
|
||||
createInternalChatItem user (CDGroupSnd g Nothing) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing
|
||||
createInternalChatItem user (CDGroupSnd g) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing
|
||||
pure $ CRGroupMemberRatchetSyncStarted user g m cStats
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
APIGetContactCode contactId -> withUser $ \user -> do
|
||||
@ -1395,8 +1368,8 @@ processChatCommand = \case
|
||||
RejectContact cName -> withUser $ \User {userId} -> do
|
||||
connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName
|
||||
processChatCommand $ APIRejectContact connReqId
|
||||
SendMessage sendName msg -> sendTextMessage sendName msg False
|
||||
SendLiveMessage sendName msg -> sendTextMessage sendName msg True
|
||||
SendMessage chatName msg -> sendTextMessage chatName msg False
|
||||
SendLiveMessage chatName msg -> sendTextMessage chatName msg True
|
||||
SendMessageBroadcast msg -> withUser $ \user -> do
|
||||
contacts <- withStore' (`getUserContacts` user)
|
||||
let cts = filter (\ct -> isReady ct && directOrUsed ct) contacts
|
||||
@ -1416,7 +1389,7 @@ processChatCommand = \case
|
||||
contactId <- withStore $ \db -> getContactIdByName db user cName
|
||||
quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
|
||||
let mc = MCText msg
|
||||
processChatCommand . APISendMessage (SRDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
|
||||
processChatCommand . APISendMessage (ChatRef CTDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
|
||||
DeleteMessage chatName deletedMsg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg
|
||||
@ -1430,10 +1403,10 @@ processChatCommand = \case
|
||||
editedItemId <- getSentChatItemIdByText user chatRef editedMsg
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APIUpdateChatItem chatRef editedItemId False mc
|
||||
UpdateLiveMessage sendName chatItemId live msg -> withUser $ \user -> do
|
||||
sendRef <- getSendRef user sendName
|
||||
UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
let mc = MCText msg
|
||||
processChatCommand $ APIUpdateChatItem (sendToChatRef sendRef) chatItemId live mc
|
||||
processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc
|
||||
ReactToMessage add reaction chatName msg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatItemId <- getChatItemIdByText user chatRef msg
|
||||
@ -1518,7 +1491,7 @@ processChatCommand = \case
|
||||
_ -> throwChatError $ CEGroupCantResendInvitation gInfo cName
|
||||
_ -> do
|
||||
(msg, _) <- sendGroupMessage user gInfo members $ XGrpMemRole mId memRole
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndGroupEvent gEvent)
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent gEvent)
|
||||
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole}
|
||||
APIRemoveMember groupId memberId -> withUser $ \user -> do
|
||||
@ -1534,7 +1507,7 @@ processChatCommand = \case
|
||||
withStore' $ \db -> deleteGroupMember db user m
|
||||
_ -> do
|
||||
(msg, _) <- sendGroupMessage user gInfo members $ XGrpMemDel mId
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile))
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile))
|
||||
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
deleteMemberConnection user m
|
||||
-- undeleted "member connected" chat item will prevent deletion of member record
|
||||
@ -1544,7 +1517,7 @@ processChatCommand = \case
|
||||
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId
|
||||
withChatLock "leaveGroup" . procCmd $ do
|
||||
(msg, _) <- sendGroupMessage user gInfo members XGrpLeave
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndGroupEvent SGEUserLeft)
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft)
|
||||
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
-- TODO delete direct connections that were unused
|
||||
deleteGroupLinkIfExists user gInfo
|
||||
@ -1627,13 +1600,11 @@ processChatCommand = \case
|
||||
ShowGroupLink gName -> withUser $ \user -> do
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIGetGroupLink groupId
|
||||
SendGroupMessageQuote gName cName directMemberName quotedMsg msg -> withUser $ \user -> do
|
||||
SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
directMemberId <- forM directMemberName $ \dmn -> withStore $ \db -> getGroupMemberIdByName db user groupId dmn
|
||||
quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg
|
||||
let sendRef = SRGroup groupId directMemberId
|
||||
mc = MCText msg
|
||||
processChatCommand . APISendMessage sendRef False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
|
||||
let mc = MCText msg
|
||||
processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
|
||||
LastChats count_ -> withUser' $ \user -> do
|
||||
chats <- withStore' $ \db -> getChatPreviews db user False
|
||||
pure $ CRChats $ maybe id take count_ chats
|
||||
@ -1666,19 +1637,19 @@ processChatCommand = \case
|
||||
processChatCommand $ APIGetChatItemInfo chatRef itemId
|
||||
ShowLiveItems on -> withUser $ \_ ->
|
||||
asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_
|
||||
SendFile sendName f -> withUser $ \user -> do
|
||||
sendRef <- getSendRef user sendName
|
||||
processChatCommand . APISendMessage sendRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCFile "")
|
||||
SendImage sendName f -> withUser $ \user -> do
|
||||
sendRef <- getSendRef user sendName
|
||||
SendFile chatName f -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCFile "")
|
||||
SendImage chatName f -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
filePath <- toFSFilePath f
|
||||
unless (any (`isSuffixOf` map toLower f) imageExtensions) $ throwChatError CEFileImageType {filePath}
|
||||
fileSize <- getFileSize filePath
|
||||
unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
|
||||
-- TODO include file description for preview
|
||||
processChatCommand . APISendMessage sendRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCImage "" fixedImagePreview)
|
||||
ForwardFile sendName fileId -> forwardFile sendName fileId SendFile
|
||||
ForwardImage sendName fileId -> forwardFile sendName fileId SendImage
|
||||
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCImage "" fixedImagePreview)
|
||||
ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
|
||||
ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
|
||||
SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
|
||||
ReceiveFile fileId encrypted rcvInline_ filePath_ -> withUser $ \_ ->
|
||||
withChatLock "receiveFile" . procCmd $ do
|
||||
@ -1702,7 +1673,7 @@ processChatCommand = \case
|
||||
(_, RcvFileTransfer {xftpRcvFile = f}) <- withStore (`getRcvFileTransferById` fileId)
|
||||
unless (isJust f) $ throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP"
|
||||
liftIO $ Just <$> CF.randomArgs
|
||||
CancelFile fileId -> withUser $ \user ->
|
||||
CancelFile fileId -> withUser $ \user@User {userId} ->
|
||||
withChatLock "cancelFile" . procCmd $
|
||||
withStore (\db -> getFileTransfer db user fileId) >>= \case
|
||||
FTSnd ftm@FileTransferMeta {xftpSndFile, cancelled} fts
|
||||
@ -1712,22 +1683,20 @@ processChatCommand = \case
|
||||
| otherwise -> do
|
||||
fileAgentConnIds <- cancelSndFile user ftm fts True
|
||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||
sendXFileCancel
|
||||
ci' <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
pure $ CRSndFileCancelled user ci' ftm fts
|
||||
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
|
||||
withStore (\db -> getChatRefByFileId db user fileId) >>= \case
|
||||
ChatRef CTDirect contactId -> do
|
||||
contact <- withStore $ \db -> getContact db user contactId
|
||||
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
|
||||
ChatRef CTGroup groupId -> do
|
||||
Group gInfo ms <- withStore $ \db -> getGroup db user groupId
|
||||
void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
|
||||
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
|
||||
ci <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
pure $ CRSndFileCancelled user ci ftm fts
|
||||
where
|
||||
fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} =
|
||||
s == FSCancelled || (s == FSComplete && isNothing xftpSndFile)
|
||||
sendXFileCancel :: m ()
|
||||
sendXFileCancel = do
|
||||
ci <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
case ci of
|
||||
(AChatItem _ _ (DirectChat ct) ChatItem {chatDir = CIDirectSnd, meta = CIMeta {itemSharedMsgId = Just sharedMsgId}}) ->
|
||||
void $ sendDirectContactMessage ct (XFileCancel sharedMsgId)
|
||||
(AChatItem _ _ (GroupChat gInfo) ChatItem {chatDir = CIGroupSnd directMember, meta = CIMeta {itemSharedMsgId = Just sharedMsgId}}) -> do
|
||||
(ms, _) <- getReceivingMembers' user gInfo directMember
|
||||
void $ sendGroupMessage user gInfo ms (XFileCancel sharedMsgId)
|
||||
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
|
||||
FTRcv ftr@RcvFileTransfer {cancelled, fileStatus, xftpRcvFile}
|
||||
| cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled"
|
||||
| rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete"
|
||||
@ -1842,15 +1811,6 @@ processChatCommand = \case
|
||||
CTDirect -> withStore $ \db -> getContactIdByName db user name
|
||||
CTGroup -> withStore $ \db -> getGroupIdByName db user name
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
getSendRef :: User -> SendName -> m SendRef
|
||||
getSendRef user sendName = case sendName of
|
||||
SNDirect name -> SRDirect <$> withStore (\db -> getContactIdByName db user name)
|
||||
SNGroup name directMemberName -> do
|
||||
(gId, dmId) <- withStore $ \db -> do
|
||||
gId <- getGroupIdByName db user name
|
||||
dmId <- forM directMemberName $ \dmn -> getGroupMemberIdByName db user gId dmn
|
||||
pure (gId, dmId)
|
||||
pure $ SRGroup gId dmId
|
||||
checkChatStopped :: m ChatResponse -> m ChatResponse
|
||||
checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped)
|
||||
setStoreChanged :: m ()
|
||||
@ -1983,29 +1943,15 @@ processChatCommand = \case
|
||||
assertUserGroupRole g GROwner
|
||||
g' <- withStore $ \db -> updateGroupProfile db user g p'
|
||||
(msg, _) <- sendGroupMessage user g' ms (XGrpInfo p')
|
||||
let cd = CDGroupSnd g' Nothing
|
||||
let cd = CDGroupSnd g'
|
||||
unless (sameGroupProfileInfo p p') $ do
|
||||
ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p')
|
||||
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat g') ci)
|
||||
createGroupFeatureChangedItems user cd CISndGroupFeature g g'
|
||||
pure $ CRGroupUpdated user g g' Nothing
|
||||
assertGroupSendAllowed :: GroupInfo -> Maybe GroupMember -> m ()
|
||||
assertGroupSendAllowed
|
||||
gInfo@GroupInfo {membership = GroupMember {memberRole = userRole}}
|
||||
(Just GroupMember {memberRole = directMemberRole, activeConn = Just Connection {peerChatVRange}}) = do
|
||||
unless (isCompatibleRange peerChatVRange groupPrivateMessagesVRange) $ throwChatError CEPeerChatVRangeIncompatible
|
||||
if
|
||||
| userRole >= GRAdmin || directMemberRole >= GRAdmin -> assertUserMembershipStatus gInfo
|
||||
| not (groupFeatureAllowed SGFDirectMessages gInfo) -> throwChatError $ CECommandError "direct messages not allowed"
|
||||
| otherwise -> assertUserGroupRole gInfo GRAuthor
|
||||
assertGroupSendAllowed _ (Just GroupMember {activeConn = Nothing}) = throwChatError CEGroupMemberNotActive
|
||||
assertGroupSendAllowed gInfo Nothing = assertUserGroupRole gInfo GRAuthor
|
||||
assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m ()
|
||||
assertUserGroupRole g@GroupInfo {membership} requiredRole = do
|
||||
when (memberRole (membership :: GroupMember) < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole
|
||||
assertUserMembershipStatus g
|
||||
assertUserMembershipStatus :: GroupInfo -> m ()
|
||||
assertUserMembershipStatus g@GroupInfo {membership} = do
|
||||
when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
|
||||
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
|
||||
@ -2050,14 +1996,14 @@ processChatCommand = \case
|
||||
withServerProtocol p action = case userProtocol p of
|
||||
Just Dict -> action
|
||||
_ -> throwChatError $ CEServerProtocol $ AProtocolType p
|
||||
forwardFile :: SendName -> FileTransferId -> (SendName -> FilePath -> ChatCommand) -> m ChatResponse
|
||||
forwardFile sendName fileId sendCommand = withUser $ \user -> do
|
||||
forwardFile :: ChatName -> FileTransferId -> (ChatName -> FilePath -> ChatCommand) -> m ChatResponse
|
||||
forwardFile chatName fileId sendCommand = withUser $ \user -> do
|
||||
withStore (\db -> getFileTransfer db user fileId) >>= \case
|
||||
FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> forward filePath
|
||||
FTSnd {fileTransferMeta = FileTransferMeta {filePath}} -> forward filePath
|
||||
_ -> throwChatError CEFileNotReceived {fileId}
|
||||
where
|
||||
forward = processChatCommand . sendCommand sendName
|
||||
forward = processChatCommand . sendCommand chatName
|
||||
getGroupAndMemberId :: User -> GroupName -> ContactName -> m (GroupId, GroupMemberId)
|
||||
getGroupAndMemberId user gName groupMemberName =
|
||||
withStore $ \db -> do
|
||||
@ -2073,10 +2019,10 @@ processChatCommand = \case
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg content
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
setActive $ ActiveG localDisplayName
|
||||
sendTextMessage sendName msg live = withUser $ \user -> do
|
||||
sendRef <- getSendRef user sendName
|
||||
sendTextMessage chatName msg live = withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
let mc = MCText msg
|
||||
processChatCommand . APISendMessage sendRef live Nothing $ ComposedMessage Nothing Nothing mc
|
||||
processChatCommand . APISendMessage chatRef live Nothing $ ComposedMessage Nothing Nothing mc
|
||||
sndContactCITimed :: Bool -> Contact -> Maybe Int -> m (Maybe CITimed)
|
||||
sndContactCITimed live = sndCITimed_ live . contactTimedTTL
|
||||
sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> m (Maybe CITimed)
|
||||
@ -2148,26 +2094,6 @@ processChatCommand = \case
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
|
||||
|
||||
getReceivingMembers :: ChatMonad m => User -> GroupInfo -> Maybe GroupMember -> m [GroupMember]
|
||||
getReceivingMembers user gInfo directMember = do
|
||||
ms <- case directMember of
|
||||
Nothing -> withStore' $ \db -> getGroupMembers db user gInfo
|
||||
Just dm -> pure [dm]
|
||||
pure $ filter memberCurrent ms
|
||||
|
||||
-- use in contexts where directMember is retrieved via chat item direction:
|
||||
-- when reading chat item member is loaded w/t connection
|
||||
getReceivingMembers' :: ChatMonad m => User -> GroupInfo -> Maybe GroupMember -> m ([GroupMember], Maybe GroupMember)
|
||||
getReceivingMembers' user gInfo@GroupInfo {groupId} directMember = do
|
||||
(ms, dm) <- case directMember of
|
||||
Nothing -> do
|
||||
ms <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
pure (ms, Nothing)
|
||||
Just GroupMember {groupMemberId} -> do
|
||||
dm <- withStore $ \db -> getGroupMember db user groupId groupMemberId
|
||||
pure ([dm], Just dm)
|
||||
pure (filter memberCurrent ms, dm)
|
||||
|
||||
assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m ()
|
||||
assertDirectAllowed user dir ct event =
|
||||
unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $
|
||||
@ -2386,7 +2312,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
)
|
||||
|
||||
receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> Maybe CryptoFileArgs -> m ()
|
||||
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} cfArgs = do
|
||||
receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} cfArgs =
|
||||
when fileDescrComplete $ do
|
||||
rd <- parseFileDescription fileDescrText
|
||||
aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs
|
||||
@ -2823,21 +2749,25 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
|
||||
SFDONE sndDescr rfds -> do
|
||||
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
|
||||
ci <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
case (rfds, sfts, ci) of
|
||||
(rfd : extraRFDs, [sft], AChatItem _ _ (DirectChat ct) ChatItem {chatDir = CIDirectSnd, meta = CIMeta {itemSharedMsgId = Just sharedMsgId, itemDeleted = Nothing}}) -> do
|
||||
checkStart ci
|
||||
ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <-
|
||||
withStore $ \db -> getChatItemByFileId db user fileId
|
||||
case (msgId_, itemDeleted) of
|
||||
(Just sharedMsgId, Nothing) -> do
|
||||
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
|
||||
-- TODO either update database status or move to SFPROG
|
||||
toView $ CRSndFileProgressXFTP user ci ft 1 1
|
||||
case (rfds, sfts, d, cInfo) of
|
||||
(rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do
|
||||
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
|
||||
msgDeliveryId <- sendFileDescription sft rfd sharedMsgId $ sendDirectContactMessage ct
|
||||
withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId
|
||||
withAgent (`xftpDeleteSndFileInternal` aFileId)
|
||||
(_, _, AChatItem _ _ (GroupChat gInfo) ChatItem {chatDir = CIGroupSnd directMember, meta = CIMeta {itemSharedMsgId = Just sharedMsgId, itemDeleted = Nothing}}) -> do
|
||||
checkStart ci
|
||||
(ms, _) <- getReceivingMembers' user gInfo directMember
|
||||
(_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do
|
||||
ms <- withStore' $ \db -> getGroupMembers db user g
|
||||
let rfdsMemberFTs = zip rfds $ memberFTs ms
|
||||
extraRFDs = drop (length rfdsMemberFTs) rfds
|
||||
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
|
||||
forM_ rfdsMemberFTs $ \mt -> sendToMember gInfo mt `catchChatError` (toView . CRChatError (Just user))
|
||||
forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user))
|
||||
ci' <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
|
||||
getChatItemByFileId db user fileId
|
||||
@ -2853,16 +2783,11 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
| (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) = Just (groupMemberId, conn)
|
||||
| otherwise = Nothing
|
||||
useMember _ = Nothing
|
||||
sendToMember :: GroupInfo -> (ValidFileDescription 'FRecipient, (Connection, SndFileTransfer)) -> m ()
|
||||
sendToMember GroupInfo {groupId} (rfd, (conn, sft)) =
|
||||
sendToMember :: (ValidFileDescription 'FRecipient, (Connection, SndFileTransfer)) -> m ()
|
||||
sendToMember (rfd, (conn, sft)) =
|
||||
void $ sendFileDescription sft rfd sharedMsgId $ \msg' -> sendDirectMessage conn msg' $ GroupId groupId
|
||||
_ -> throwChatError $ CEInternalError "invalid XFTP file transfer"
|
||||
where
|
||||
checkStart :: AChatItem -> m ()
|
||||
checkStart ci = do
|
||||
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
|
||||
-- TODO either update database status or move to SFPROG
|
||||
toView $ CRSndFileProgressXFTP user ci ft 1 1
|
||||
_ -> pure ()
|
||||
_ -> pure () -- TODO error?
|
||||
SFERR e
|
||||
| temporaryAgentError e ->
|
||||
throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e
|
||||
@ -3198,7 +3123,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile groupLinkId
|
||||
(_msg, _) <- sendDirectContactMessage ct $ XGrpInv groupInv
|
||||
-- we could link chat item with sent group invitation message (_msg)
|
||||
createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
||||
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
||||
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
|
||||
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
|
||||
CONF confId _ connInfo -> do
|
||||
@ -3287,10 +3212,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
let m' = m {activeConn = Just conn'} :: GroupMember
|
||||
updateChatLock "groupMessage" event
|
||||
case event of
|
||||
XMsgNew mc -> newGroupContentMessage gInfo m' mc msg msgMeta
|
||||
XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo m' sharedMsgId fileDescr msgMeta
|
||||
XMsgNew mc -> canSend m' $ newGroupContentMessage gInfo m' mc msg msgMeta
|
||||
XMsgFileDescr sharedMsgId fileDescr -> canSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr msgMeta
|
||||
XMsgFileCancel sharedMsgId -> cancelGroupMessageFile gInfo m' sharedMsgId msgMeta
|
||||
XMsgUpdate sharedMsgId mContent ttl live -> groupMessageUpdate gInfo m' sharedMsgId mContent msg msgMeta ttl live
|
||||
XMsgUpdate sharedMsgId mContent ttl live -> canSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg msgMeta ttl live
|
||||
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg msgMeta
|
||||
XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg msgMeta
|
||||
-- TODO discontinue XFile
|
||||
@ -3314,6 +3239,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
fromMaybe (sendRcptsSmallGroups user) sendRcpts
|
||||
&& hasDeliveryReceipt (toCMEventTag event)
|
||||
&& currentMemCount <= smallGroupsRcptsMemLimit
|
||||
where
|
||||
canSend mem a
|
||||
| memberRole (mem :: GroupMember) <= GRObserver = messageError "member is not allowed to send messages"
|
||||
| otherwise = a
|
||||
RCVD msgMeta msgRcpt ->
|
||||
withAckMessage' agentConnId conn msgMeta $
|
||||
groupMsgReceived gInfo m conn msgMeta msgRcpt
|
||||
@ -3324,8 +3253,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
SWITCH qd phase cStats -> do
|
||||
toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
|
||||
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
|
||||
QDRcv -> createInternalChatItem user (CDGroupSnd gInfo Nothing) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing
|
||||
QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
|
||||
QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing
|
||||
QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
|
||||
RSYNC rss cryptoErr_ cStats ->
|
||||
case (rss, connectionCode, cryptoErr_) of
|
||||
(RSRequired, _, Just cryptoErr) -> processErr cryptoErr
|
||||
@ -3335,7 +3264,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
let m' = m {activeConn = Just (conn {connectionCode = Nothing} :: Connection)} :: GroupMember
|
||||
ratchetSyncEventItem m'
|
||||
toView $ CRGroupMemberVerificationReset user gInfo m'
|
||||
createInternalChatItem user (CDGroupRcv gInfo m' MSGroup) (CIRcvConnEvent RCEVerificationCodeReset) Nothing
|
||||
createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent RCEVerificationCodeReset) Nothing
|
||||
_ -> ratchetSyncEventItem m
|
||||
where
|
||||
processErr cryptoErr = do
|
||||
@ -3349,10 +3278,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
|
||||
_ -> do
|
||||
toView $ CRGroupMemberRatchetSync user gInfo m (RatchetSyncProgress rss cStats)
|
||||
createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvDecryptionError mde n) Nothing
|
||||
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvDecryptionError mde n) Nothing
|
||||
ratchetSyncEventItem m' = do
|
||||
toView $ CRGroupMemberRatchetSync user gInfo m' (RatchetSyncProgress rss cStats)
|
||||
createInternalChatItem user (CDGroupRcv gInfo m' MSGroup) (CIRcvConnEvent $ RCERatchetSync rss) Nothing
|
||||
createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent $ RCERatchetSync rss) Nothing
|
||||
OK ->
|
||||
-- [async agent commands] continuation on receiving OK
|
||||
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction, cmdId} ->
|
||||
@ -3649,11 +3578,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
memberConnectedChatItem :: GroupInfo -> GroupMember -> m ()
|
||||
memberConnectedChatItem gInfo m =
|
||||
-- ts should be broker ts but we don't have it for CON
|
||||
createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvGroupEvent RGEMemberConnected) Nothing
|
||||
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEMemberConnected) Nothing
|
||||
|
||||
groupDescriptionChatItem :: GroupInfo -> GroupMember -> Text -> m ()
|
||||
groupDescriptionChatItem gInfo m descr =
|
||||
createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvMsgContent $ MCText descr) Nothing
|
||||
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing
|
||||
|
||||
notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> m ()
|
||||
notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} ct_ = do
|
||||
@ -3691,7 +3620,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
newContentMessage ct@Contact {localDisplayName = c, contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
let ExtMsgContent content fInv_ _ _ _ = mcExtMsgContent mc
|
||||
let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc
|
||||
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
|
||||
-- case content of
|
||||
-- MCText "hello 111" ->
|
||||
@ -3703,7 +3632,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
|
||||
setActive $ ActiveC c
|
||||
else do
|
||||
let ExtMsgContent _ _ itemTTL live_ _ = mcExtMsgContent mc
|
||||
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
|
||||
timed_ = rcvContactCITimed ct itemTTL
|
||||
live = fromMaybe False live_
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
|
||||
@ -3731,16 +3660,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
processFDMessage fileId fileDescr
|
||||
|
||||
groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> MsgMeta -> m ()
|
||||
groupMessageFileDescription gInfo@GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId fileDescr _msgMeta = do
|
||||
cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
|
||||
case cci of
|
||||
CChatItem SMDRcv ChatItem {chatDir = CIGroupRcv m' msgScope, file = Just CIFile {fileId}} ->
|
||||
if sameMemberId memberId m'
|
||||
then do
|
||||
assertMemberSendAllowed gInfo m' msgScope directMsgProhibitedErr
|
||||
groupMessageFileDescription GroupInfo {groupId} _m sharedMsgId fileDescr _msgMeta = do
|
||||
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
processFDMessage fileId fileDescr
|
||||
else messageError "x.msg.file.descr: message of another member"
|
||||
_ -> messageError "x.msg.file.descr: group member attempted invalid file send"
|
||||
|
||||
processFDMessage :: FileTransferId -> FileDescr -> m ()
|
||||
processFDMessage fileId fileDescr = do
|
||||
@ -3861,14 +3783,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
where
|
||||
updateChatItemReaction = do
|
||||
cr_ <- withStore $ \db -> do
|
||||
CChatItem md ci@ChatItem {chatDir} <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId
|
||||
if directMemberCIUpdateAllowed ci m && ciReactionAllowed ci
|
||||
CChatItem md ci <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId
|
||||
if ciReactionAllowed ci
|
||||
then liftIO $ do
|
||||
setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs
|
||||
reactions <- getGroupCIReactions db g itemMemberId sharedMsgId
|
||||
let ci' = CChatItem md ci {reactions}
|
||||
msgScope = directMemberToMsgScope $ ciDirDirectMember chatDir
|
||||
r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m msgScope) ci' brokerTs reaction
|
||||
r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction
|
||||
pure $ Just $ CRChatItemReaction user add r
|
||||
else pure Nothing
|
||||
mapM_ toView cr_
|
||||
@ -3876,12 +3797,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool
|
||||
reactionAllowed add reaction rs = (reaction `elem` rs) /= add && not (add && length rs >= maxMsgReactions)
|
||||
|
||||
directMemberCIUpdateAllowed :: ChatItem 'CTGroup d -> GroupMember -> Bool
|
||||
directMemberCIUpdateAllowed ChatItem {chatDir} GroupMember {groupMemberId} =
|
||||
case ciDirDirectMember chatDir of
|
||||
Just GroupMember {groupMemberId = directMemberId} -> groupMemberId == directMemberId
|
||||
Nothing -> True
|
||||
|
||||
catchCINotFound :: m a -> (SharedMsgId -> m a) -> m a
|
||||
catchCINotFound f handle =
|
||||
f `catchChatError` \case
|
||||
@ -3889,11 +3804,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
e -> throwError e
|
||||
|
||||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
|
||||
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
assertMemberSendAllowed gInfo m msgScope $ rejected GFDirectMessages >> directMsgProhibitedErr
|
||||
processMessage
|
||||
where
|
||||
processMessage
|
||||
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
|
||||
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
|
||||
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
|
||||
| otherwise = do
|
||||
@ -3901,29 +3812,24 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- check if message moderation event was received ahead of message
|
||||
let timed_ = rcvGroupCITimed gInfo itemTTL
|
||||
live = fromMaybe False live_
|
||||
case msgScope_ of
|
||||
Nothing -> processGroupScopeMsg timed_ live
|
||||
Just MSGroup -> processGroupScopeMsg timed_ live
|
||||
Just MSDirect -> createItem timed_ live
|
||||
processGroupScopeMsg timed_ live =
|
||||
withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration timed_ live ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
|
||||
Nothing -> createItem timed_ live
|
||||
where
|
||||
rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False
|
||||
ExtMsgContent content fInv_ itemTTL live_ msgScope_ = mcExtMsgContent mc
|
||||
msgScope = fromMaybe MSGroup msgScope_
|
||||
ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc
|
||||
applyModeration timed_ live CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, createdByMsgId, moderatedAt}
|
||||
| moderatorRole < GRAdmin || moderatorRole < memberRole =
|
||||
createItem timed_ live
|
||||
| groupFeatureAllowed SGFFullDelete gInfo = do
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m MSGroup) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False
|
||||
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo (CChatItem SMDRcv ci) moderator moderatedAt
|
||||
toView $ CRNewChatItem user ci'
|
||||
| otherwise = do
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m MSGroup) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False
|
||||
cr <- markGroupCIDeleted user gInfo (CChatItem SMDRcv ci) createdByMsgId False (Just moderator) moderatedAt
|
||||
toView cr
|
||||
createItem timed_ live = do
|
||||
@ -3935,39 +3841,24 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText
|
||||
setActive $ ActiveG g
|
||||
newChatItem ciContent ciFile_ timed_ live = do
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m msgScope) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
|
||||
groupMsgToView gInfo m ci {reactions} msgMeta
|
||||
pure ci
|
||||
|
||||
assertMemberSendAllowed :: GroupInfo -> GroupMember -> MessageScope -> m () -> m ()
|
||||
assertMemberSendAllowed
|
||||
gInfo@GroupInfo {membership = GroupMember {memberRole = userRole}}
|
||||
m@GroupMember {memberRole}
|
||||
MSDirect
|
||||
directMessagesProhibitedAction
|
||||
| userRole >= GRAdmin || memberRole >= GRAdmin = assertMemberStatus m
|
||||
| not (groupFeatureAllowed SGFDirectMessages gInfo) = directMessagesProhibitedAction
|
||||
| otherwise = assertMemberGroupRole m GRAuthor
|
||||
assertMemberSendAllowed _ m MSGroup _ =
|
||||
assertMemberGroupRole m GRAuthor
|
||||
|
||||
directMsgProhibitedErr :: m ()
|
||||
directMsgProhibitedErr = throwChatError $ CECommandError "direct messages not allowed"
|
||||
|
||||
assertMemberGroupRole :: GroupMember -> GroupMemberRole -> m ()
|
||||
assertMemberGroupRole member requiredRole = do
|
||||
when (memberRole (member :: GroupMember) < requiredRole) $ messageError "member is not allowed to send messages (member role)"
|
||||
assertMemberStatus member
|
||||
|
||||
assertMemberStatus :: GroupMember -> m ()
|
||||
assertMemberStatus member =
|
||||
when (memberRemoved member) $ messageError "member is not allowed to send messages (member removed)"
|
||||
|
||||
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId, localDisplayName = g} GroupMember {groupMemberId, memberId} sharedMsgId mc RcvMessage {msgId} msgMeta _ttl_ live_ =
|
||||
updateRcvChatItem `catchCINotFound` \_ ->
|
||||
withStore' (`deleteMessage` msgId)
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId, localDisplayName = g} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
|
||||
updateRcvChatItem `catchCINotFound` \_ -> do
|
||||
-- This patches initial sharedMsgId into chat item when locally deleted chat item
|
||||
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
|
||||
-- Chat item and update message which created it will have different sharedMsgId in this case...
|
||||
let timed_ = rcvGroupCITimed gInfo ttl_
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateGroupChatItem db user groupId ci content live Nothing
|
||||
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
|
||||
setActive $ ActiveG g
|
||||
where
|
||||
MsgMeta {broker = (_, brokerTs)} = msgMeta
|
||||
content = CIRcvMsgContent mc
|
||||
@ -3975,10 +3866,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
updateRcvChatItem = do
|
||||
cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
|
||||
case cci of
|
||||
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m' msgScope, meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} ->
|
||||
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} ->
|
||||
if sameMemberId memberId m'
|
||||
then do
|
||||
assertMemberSendAllowed gInfo m' msgScope directMsgProhibitedErr
|
||||
let changed = mc /= oldMC
|
||||
if changed || fromMaybe False itemLive
|
||||
then do
|
||||
@ -3998,13 +3888,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
let msgMemberId = fromMaybe memberId sndMemberId_
|
||||
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case
|
||||
Right ci@(CChatItem _ ChatItem {chatDir}) -> case chatDir of
|
||||
CIGroupRcv mem msgScope
|
||||
CIGroupRcv mem
|
||||
| sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView
|
||||
| msgScope == MSGroup -> deleteMsg mem ci
|
||||
| otherwise -> messageError "x.msg.del: private message of another member"
|
||||
CIGroupSnd directMember
|
||||
| isNothing directMember -> deleteMsg membership ci
|
||||
| otherwise -> messageError "x.msg.del: private message sent by user"
|
||||
| otherwise -> deleteMsg mem ci
|
||||
CIGroupSnd -> deleteMsg membership ci
|
||||
Left e
|
||||
| msgMemberId == memberId -> messageError $ "x.msg.del: message not found, " <> tshow e
|
||||
| senderRole < GRAdmin -> messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e
|
||||
@ -4047,7 +3934,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
|
||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m MSGroup) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
let g = groupName' gInfo
|
||||
whenGroupNtfs user gInfo $ do
|
||||
@ -4156,11 +4043,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
|
||||
xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> MsgMeta -> m ()
|
||||
xFileCancelGroup g@GroupInfo {groupId} mem@GroupMember {groupMemberId, memberId} sharedMsgId msgMeta = do
|
||||
checkIntegrityCreateItem (CDGroupRcv g mem MSGroup) msgMeta
|
||||
checkIntegrityCreateItem (CDGroupRcv g mem) msgMeta
|
||||
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
CChatItem msgDir ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
|
||||
case (msgDir, chatDir) of
|
||||
(SMDRcv, CIGroupRcv m _) -> do
|
||||
(SMDRcv, CIGroupRcv m) -> do
|
||||
if sameMemberId memberId m
|
||||
then do
|
||||
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
|
||||
@ -4173,7 +4060,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
|
||||
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
|
||||
xFileAcptInvGroup g@GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName msgMeta = do
|
||||
checkIntegrityCreateItem (CDGroupRcv g m MSGroup) msgMeta
|
||||
checkIntegrityCreateItem (CDGroupRcv g m) msgMeta
|
||||
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
assertSMPAcceptNotProhibited ci
|
||||
@ -4204,7 +4091,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
|
||||
groupMsgToView :: GroupInfo -> GroupMember -> ChatItem 'CTGroup 'MDRcv -> MsgMeta -> m ()
|
||||
groupMsgToView gInfo m ci msgMeta = do
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo m MSGroup) msgMeta
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta
|
||||
toView $ CRNewChatItem user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
|
||||
|
||||
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
@ -4280,7 +4167,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
forM_ allGroupFeatures $ \(AGF f) -> do
|
||||
let p = getGroupPreference f fullGroupPreferences
|
||||
(_, param) = groupFeatureState p
|
||||
createInternalChatItem user (CDGroupRcv g m MSGroup) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing
|
||||
createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing
|
||||
|
||||
xInfoProbe :: Contact -> Probe -> m ()
|
||||
xInfoProbe c2 probe =
|
||||
@ -4443,7 +4330,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
then messageError "x.grp.mem.new error: member already exists"
|
||||
else do
|
||||
newMember@GroupMember {groupMemberId} <- withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile)
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile)
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
|
||||
|
||||
@ -4527,7 +4414,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
| senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions"
|
||||
| otherwise = do
|
||||
withStore' $ \db -> updateGroupMemberRole db user member memRole
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent gEvent)
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent)
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole}
|
||||
|
||||
@ -4562,7 +4449,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
messageError "x.grp.mem.del with insufficient member permissions"
|
||||
| otherwise = a
|
||||
deleteMemberItem gEvent = do
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent gEvent)
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent)
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
|
||||
sameMemberId :: MemberId -> GroupMember -> Bool
|
||||
@ -4573,7 +4460,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
deleteMemberConnection user m
|
||||
-- member record is not deleted to allow creation of "member left" chat item
|
||||
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent RGEMemberLeft)
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEMemberLeft)
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft}
|
||||
|
||||
@ -4586,7 +4473,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
pure members
|
||||
-- member records are not deleted to keep history
|
||||
deleteMembersConnections user ms
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent RGEGroupDeleted)
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEGroupDeleted)
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m
|
||||
|
||||
@ -4596,7 +4483,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
| otherwise = unless (p == p') $ do
|
||||
g' <- withStore $ \db -> updateGroupProfile db user g p'
|
||||
toView $ CRGroupUpdated user g g' (Just m)
|
||||
let cd = CDGroupRcv g' m MSGroup
|
||||
let cd = CDGroupRcv g' m
|
||||
unless (sameGroupProfileInfo p p') $ do
|
||||
ci <- saveRcvChatItem user cd msg msgMeta (CIRcvGroupEvent $ RGEGroupUpdated p')
|
||||
groupMsgToView g' m ci msgMeta
|
||||
@ -4611,7 +4498,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
|
||||
groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> m ()
|
||||
groupMsgReceived gInfo m conn@Connection {connId} msgMeta msgRcpts = do
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo m MSGroup) msgMeta
|
||||
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta
|
||||
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
|
||||
withStore $ \db -> createSndMsgDeliveryEvent db connId agentMsgId $ MDSSndRcvd msgRcptStatus
|
||||
updateGroupItemStatus gInfo m conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete
|
||||
@ -5324,7 +5211,7 @@ chatCommandP =
|
||||
"/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)),
|
||||
"/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)),
|
||||
"/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal),
|
||||
"/_send " *> (APISendMessage <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))),
|
||||
"/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))),
|
||||
"/_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),
|
||||
@ -5448,7 +5335,8 @@ chatCommandP =
|
||||
"/set link role #" *> (GroupLinkMemberRole <$> displayName <*> memberRole),
|
||||
"/delete link #" *> (DeleteGroupLink <$> displayName),
|
||||
"/show link #" *> (ShowGroupLink <$> displayName),
|
||||
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <*> optional (" >@" *> displayName) <*> optional (" @" *> displayName) <* A.space <*> quotedMsg <*> msgTextP),
|
||||
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> msgTextP),
|
||||
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* char_ '@' <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> msgTextP),
|
||||
"/_contacts " *> (APIListContacts <$> A.decimal),
|
||||
"/contacts" $> ListContacts,
|
||||
"/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
|
||||
@ -5456,8 +5344,8 @@ chatCommandP =
|
||||
"/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP),
|
||||
("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
|
||||
("/connect" <|> "/c") *> (AddContact <$> incognitoP),
|
||||
SendMessage <$> sendNameP <* A.space <*> msgTextP,
|
||||
"/live " *> (SendLiveMessage <$> sendNameP <*> (A.space *> msgTextP <|> pure "")),
|
||||
SendMessage <$> chatNameP <* A.space <*> msgTextP,
|
||||
"/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")),
|
||||
(">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv),
|
||||
(">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd),
|
||||
("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> textP),
|
||||
@ -5472,10 +5360,10 @@ chatCommandP =
|
||||
"/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)),
|
||||
"/show " *> (ShowChatItem . Just <$> A.decimal),
|
||||
"/item info " *> (ShowChatItemInfo <$> chatNameP <* A.space <*> msgTextP),
|
||||
("/file " <|> "/f ") *> (SendFile <$> sendNameP' <* A.space <*> filePath),
|
||||
("/image " <|> "/img ") *> (SendImage <$> sendNameP' <* A.space <*> filePath),
|
||||
("/fforward " <|> "/ff ") *> (ForwardFile <$> sendNameP' <* A.space <*> A.decimal),
|
||||
("/image_forward " <|> "/imgf ") *> (ForwardImage <$> sendNameP' <* A.space <*> A.decimal),
|
||||
("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> filePath),
|
||||
("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> filePath),
|
||||
("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal),
|
||||
("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal),
|
||||
("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath),
|
||||
("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False) <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)),
|
||||
"/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False)),
|
||||
@ -5586,13 +5474,6 @@ chatCommandP =
|
||||
chatNameP = ChatName <$> chatTypeP <*> displayName
|
||||
chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayName
|
||||
chatRefP = ChatRef <$> chatTypeP <*> A.decimal
|
||||
sendNameP =
|
||||
(A.char '@' $> SNDirect <*> displayName)
|
||||
<|> (A.char '#' $> SNGroup <*> displayName <*> optional (" @" *> displayName))
|
||||
sendNameP' = sendNameP <|> (SNDirect <$> displayName)
|
||||
sendRefP =
|
||||
(A.char '@' $> SRDirect <*> A.decimal)
|
||||
<|> (A.char '#' $> SRGroup <*> A.decimal <*> optional (" @" *> A.decimal))
|
||||
msgCountP = A.space *> A.decimal <|> pure 10
|
||||
ciTTLDecimal = ("none" $> Nothing) <|> (Just <$> A.decimal)
|
||||
ciTTL =
|
||||
|
||||
@ -67,7 +67,7 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId'
|
||||
sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
|
||||
sendComposedMessage' cc ctId quotedItemId msgContent = do
|
||||
let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent}
|
||||
sendChatCmd cc (APISendMessage (SRDirect ctId) False Nothing cm) >>= \case
|
||||
sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case
|
||||
CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
|
||||
r -> putStrLn $ "unexpected send message response: " <> show r
|
||||
|
||||
|
||||
@ -34,7 +34,6 @@ import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time (NominalDiffTime)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Version (showVersion)
|
||||
@ -242,7 +241,7 @@ data ChatCommand
|
||||
| APIGetChat ChatRef ChatPagination (Maybe String)
|
||||
| APIGetChatItems ChatPagination (Maybe String)
|
||||
| APIGetChatItemInfo ChatRef ChatItemId
|
||||
| APISendMessage {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage}
|
||||
| APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage}
|
||||
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
|
||||
| APIDeleteChatItem ChatRef ChatItemId CIDeleteMode
|
||||
| APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId
|
||||
@ -353,14 +352,14 @@ data ChatCommand
|
||||
| AddressAutoAccept (Maybe AutoAccept)
|
||||
| AcceptContact IncognitoEnabled ContactName
|
||||
| RejectContact ContactName
|
||||
| SendMessage SendName Text
|
||||
| SendLiveMessage SendName Text
|
||||
| SendMessage ChatName Text
|
||||
| SendLiveMessage ChatName Text
|
||||
| SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: Text, message :: Text}
|
||||
| SendMessageBroadcast Text -- UserId (not used in UI)
|
||||
| DeleteMessage ChatName Text
|
||||
| DeleteMemberMessage GroupName ContactName Text
|
||||
| EditMessage {chatName :: ChatName, editedMsg :: Text, message :: Text}
|
||||
| UpdateLiveMessage {sendName :: SendName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text}
|
||||
| UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text}
|
||||
| ReactToMessage {add :: Bool, reaction :: MsgReaction, chatName :: ChatName, reactToMessage :: Text}
|
||||
| APINewGroup UserId GroupProfile
|
||||
| NewGroup GroupProfile
|
||||
@ -382,17 +381,17 @@ data ChatCommand
|
||||
| GroupLinkMemberRole GroupName GroupMemberRole
|
||||
| DeleteGroupLink GroupName
|
||||
| ShowGroupLink GroupName
|
||||
| SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, directMemberName :: Maybe ContactName, quotedMsg :: Text, message :: Text}
|
||||
| SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: Text, message :: Text}
|
||||
| LastChats (Maybe Int) -- UserId (not used in UI)
|
||||
| LastMessages (Maybe ChatName) Int (Maybe String) -- UserId (not used in UI)
|
||||
| LastChatItemId (Maybe ChatName) Int -- UserId (not used in UI)
|
||||
| ShowChatItem (Maybe ChatItemId) -- UserId (not used in UI)
|
||||
| ShowChatItemInfo ChatName Text
|
||||
| ShowLiveItems Bool
|
||||
| SendFile SendName FilePath
|
||||
| SendImage SendName FilePath
|
||||
| ForwardFile SendName FileTransferId
|
||||
| ForwardImage SendName FileTransferId
|
||||
| SendFile ChatName FilePath
|
||||
| SendImage ChatName FilePath
|
||||
| ForwardFile ChatName FileTransferId
|
||||
| ForwardImage ChatName FileTransferId
|
||||
| SendFileDescription ChatName FilePath
|
||||
| ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
|
||||
| SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Bool}
|
||||
@ -613,37 +612,6 @@ instance ToJSON ChatResponse where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"
|
||||
|
||||
data SendRef
|
||||
= SRDirect ContactId
|
||||
| SRGroup GroupId (Maybe GroupMemberId)
|
||||
deriving (Eq, Show)
|
||||
|
||||
sendToChatRef :: SendRef -> ChatRef
|
||||
sendToChatRef = \case
|
||||
SRDirect cId -> ChatRef CTDirect cId
|
||||
SRGroup gId _ -> ChatRef CTGroup gId
|
||||
|
||||
data SendName
|
||||
= SNDirect ContactName
|
||||
| SNGroup GroupName (Maybe ContactName)
|
||||
deriving (Eq, Show)
|
||||
|
||||
sendNameStr :: SendName -> String
|
||||
sendNameStr = \case
|
||||
SNDirect cName -> "@" <> T.unpack cName
|
||||
SNGroup gName (Just cName) -> "#" <> T.unpack gName <> " @" <> T.unpack cName
|
||||
SNGroup gName Nothing -> "#" <> T.unpack gName
|
||||
|
||||
data SendDirection
|
||||
= SDDirect Contact
|
||||
| SDGroup GroupInfo [GroupMember]
|
||||
deriving (Eq, Show)
|
||||
|
||||
sendDirToContactOrGroup :: SendDirection -> ContactOrGroup
|
||||
sendDirToContactOrGroup = \case
|
||||
SDDirect c -> CGContact c
|
||||
SDGroup g _ -> CGGroup g
|
||||
|
||||
newtype UserPwd = UserPwd {unUserPwd :: Text}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@ -959,7 +927,6 @@ data ChatErrorType
|
||||
| CEAgentCommandError {message :: String}
|
||||
| CEInvalidFileDescription {message :: String}
|
||||
| CEConnectionIncognitoChangeProhibited
|
||||
| CEPeerChatVRangeIncompatible
|
||||
| CEInternalError {message :: String}
|
||||
| CEException {message :: String}
|
||||
deriving (Show, Exception, Generic)
|
||||
|
||||
@ -50,6 +50,16 @@ data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
|
||||
data ChatName = ChatName ChatType Text
|
||||
deriving (Show)
|
||||
|
||||
chatTypeStr :: ChatType -> String
|
||||
chatTypeStr = \case
|
||||
CTDirect -> "@"
|
||||
CTGroup -> "#"
|
||||
CTContactRequest -> "<@"
|
||||
CTContactConnection -> ":"
|
||||
|
||||
chatNameStr :: ChatName -> String
|
||||
chatNameStr (ChatName cType name) = chatTypeStr cType <> T.unpack name
|
||||
|
||||
data ChatRef = ChatRef ChatType Int64
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
@ -138,16 +148,16 @@ instance MsgDirectionI d => ToJSON (ChatItem c d) where
|
||||
data CIDirection (c :: ChatType) (d :: MsgDirection) where
|
||||
CIDirectSnd :: CIDirection 'CTDirect 'MDSnd
|
||||
CIDirectRcv :: CIDirection 'CTDirect 'MDRcv
|
||||
CIGroupSnd :: Maybe GroupMember -> CIDirection 'CTGroup 'MDSnd
|
||||
CIGroupRcv :: GroupMember -> MessageScope -> CIDirection 'CTGroup 'MDRcv
|
||||
CIGroupSnd :: CIDirection 'CTGroup 'MDSnd
|
||||
CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv
|
||||
|
||||
deriving instance Show (CIDirection c d)
|
||||
|
||||
data JSONCIDirection
|
||||
= JCIDirectSnd
|
||||
| JCIDirectRcv
|
||||
| JCIGroupSnd {directMember :: Maybe GroupMember}
|
||||
| JCIGroupRcv {groupMember :: GroupMember, messageScope :: MessageScope}
|
||||
| JCIGroupSnd
|
||||
| JCIGroupRcv {groupMember :: GroupMember}
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance ToJSON JSONCIDirection where
|
||||
@ -162,19 +172,8 @@ jsonCIDirection :: CIDirection c d -> JSONCIDirection
|
||||
jsonCIDirection = \case
|
||||
CIDirectSnd -> JCIDirectSnd
|
||||
CIDirectRcv -> JCIDirectRcv
|
||||
CIGroupSnd dm -> JCIGroupSnd dm
|
||||
CIGroupRcv m ms -> JCIGroupRcv m ms
|
||||
|
||||
ciDirDirectMember :: CIDirection 'CTGroup d -> Maybe GroupMember
|
||||
ciDirDirectMember = \case
|
||||
CIGroupSnd dm -> dm
|
||||
CIGroupRcv _ MSGroup -> Nothing
|
||||
CIGroupRcv m MSDirect -> Just m
|
||||
|
||||
directMemberToMsgScope :: Maybe GroupMember -> MessageScope
|
||||
directMemberToMsgScope = \case
|
||||
Nothing -> MSGroup
|
||||
Just _ -> MSDirect
|
||||
CIGroupSnd -> JCIGroupSnd
|
||||
CIGroupRcv m -> JCIGroupRcv m
|
||||
|
||||
data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int}
|
||||
deriving (Show, Generic)
|
||||
@ -209,8 +208,8 @@ timedDeleteAt' CITimed {deleteAt} = deleteAt
|
||||
|
||||
chatItemMember :: GroupInfo -> ChatItem 'CTGroup d -> GroupMember
|
||||
chatItemMember GroupInfo {membership} ChatItem {chatDir} = case chatDir of
|
||||
CIGroupSnd _ -> membership
|
||||
CIGroupRcv m _ -> m
|
||||
CIGroupSnd -> membership
|
||||
CIGroupRcv m -> m
|
||||
|
||||
ciReactionAllowed :: ChatItem c d -> Bool
|
||||
ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False
|
||||
@ -239,22 +238,22 @@ chatItemDeletedState ChatItem {meta = CIMeta {itemDeleted}, content} =
|
||||
data ChatDirection (c :: ChatType) (d :: MsgDirection) where
|
||||
CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd
|
||||
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
|
||||
CDGroupSnd :: GroupInfo -> Maybe GroupMember -> ChatDirection 'CTGroup 'MDSnd
|
||||
CDGroupRcv :: GroupInfo -> GroupMember -> MessageScope -> ChatDirection 'CTGroup 'MDRcv
|
||||
CDGroupSnd :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd
|
||||
CDGroupRcv :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv
|
||||
|
||||
toCIDirection :: ChatDirection c d -> CIDirection c d
|
||||
toCIDirection = \case
|
||||
CDDirectSnd _ -> CIDirectSnd
|
||||
CDDirectRcv _ -> CIDirectRcv
|
||||
CDGroupSnd _ dm -> CIGroupSnd dm
|
||||
CDGroupRcv _ m ms -> CIGroupRcv m ms
|
||||
CDGroupSnd _ -> CIGroupSnd
|
||||
CDGroupRcv _ m -> CIGroupRcv m
|
||||
|
||||
toChatInfo :: ChatDirection c d -> ChatInfo c
|
||||
toChatInfo = \case
|
||||
CDDirectSnd c -> DirectChat c
|
||||
CDDirectRcv c -> DirectChat c
|
||||
CDGroupSnd g _ -> GroupChat g
|
||||
CDGroupRcv g _ _ -> GroupChat g
|
||||
CDGroupSnd g -> GroupChat g
|
||||
CDGroupRcv g _ -> GroupChat g
|
||||
|
||||
data NewChatItem d = NewChatItem
|
||||
{ createdByMsgId :: Maybe MessageId,
|
||||
@ -434,39 +433,29 @@ instance ToJSON (JSONCIReaction c d) where
|
||||
data CIQDirection (c :: ChatType) where
|
||||
CIQDirectSnd :: CIQDirection 'CTDirect
|
||||
CIQDirectRcv :: CIQDirection 'CTDirect
|
||||
CIQGroupSnd :: MessageScope -> CIQDirection 'CTGroup
|
||||
CIQGroupRcv :: Maybe GroupMember -> MessageScope -> CIQDirection 'CTGroup -- member can be Nothing in case MsgRef has memberId that the user is not notified about yet
|
||||
CIQGroupSnd :: CIQDirection 'CTGroup
|
||||
CIQGroupRcv :: Maybe GroupMember -> CIQDirection 'CTGroup -- member can be Nothing in case MsgRef has memberId that the user is not notified about yet
|
||||
|
||||
deriving instance Show (CIQDirection c)
|
||||
|
||||
data JSONCIQDirection
|
||||
= JCIQDirectSnd
|
||||
| JCIQDirectRcv
|
||||
| JCIQGroupSnd {messageScope :: MessageScope}
|
||||
| JCIQGroupRcv {groupMember :: Maybe GroupMember, messageScope :: MessageScope}
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance ToJSON JSONCIQDirection where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIQ"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIQ"
|
||||
|
||||
instance ToJSON (CIQDirection c) where
|
||||
toJSON = J.toJSON . jsonCIQDirection
|
||||
toEncoding = J.toEncoding . jsonCIQDirection
|
||||
|
||||
jsonCIQDirection :: CIQDirection c -> JSONCIQDirection
|
||||
jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection
|
||||
jsonCIQDirection = \case
|
||||
CIQDirectSnd -> JCIQDirectSnd
|
||||
CIQDirectRcv -> JCIQDirectRcv
|
||||
CIQGroupSnd ms -> JCIQGroupSnd ms
|
||||
CIQGroupRcv m ms -> JCIQGroupRcv m ms
|
||||
CIQDirectSnd -> Just JCIDirectSnd
|
||||
CIQDirectRcv -> Just JCIDirectRcv
|
||||
CIQGroupSnd -> Just JCIGroupSnd
|
||||
CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m
|
||||
CIQGroupRcv Nothing -> Nothing
|
||||
|
||||
quoteMsgDirection :: CIQDirection c -> MsgDirection
|
||||
quoteMsgDirection = \case
|
||||
CIQDirectSnd -> MDSnd
|
||||
CIQDirectRcv -> MDRcv
|
||||
CIQGroupSnd _ -> MDSnd
|
||||
CIQGroupRcv _ _ -> MDRcv
|
||||
CIQGroupSnd -> MDSnd
|
||||
CIQGroupRcv _ -> MDRcv
|
||||
|
||||
data CIFile (d :: MsgDirection) = CIFile
|
||||
{ fileId :: Int64,
|
||||
|
||||
@ -1,24 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20230904_item_direct_group_member_id where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20230904_item_direct_group_member_id :: Query
|
||||
m20230904_item_direct_group_member_id =
|
||||
[sql|
|
||||
ALTER TABLE chat_items ADD COLUMN item_direct_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL;
|
||||
ALTER TABLE chat_items ADD COLUMN quoted_message_scope TEXT;
|
||||
|
||||
CREATE INDEX idx_chat_items_item_direct_group_member_id ON chat_items(item_direct_group_member_id);
|
||||
|]
|
||||
|
||||
down_m20230904_item_direct_group_member_id :: Query
|
||||
down_m20230904_item_direct_group_member_id =
|
||||
[sql|
|
||||
DROP INDEX idx_chat_items_item_direct_group_member_id;
|
||||
|
||||
ALTER TABLE chat_items DROP COLUMN quoted_message_scope;
|
||||
ALTER TABLE chat_items DROP COLUMN item_direct_group_member_id;
|
||||
|]
|
||||
@ -392,9 +392,7 @@ CREATE TABLE chat_items(
|
||||
timed_delete_at TEXT,
|
||||
item_live INTEGER,
|
||||
item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
|
||||
item_deleted_ts TEXT,
|
||||
item_direct_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL,
|
||||
quoted_message_scope TEXT
|
||||
item_deleted_ts TEXT
|
||||
);
|
||||
CREATE TABLE chat_item_messages(
|
||||
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE,
|
||||
@ -715,6 +713,3 @@ CREATE INDEX idx_chat_items_user_id_item_status ON chat_items(
|
||||
item_status
|
||||
);
|
||||
CREATE INDEX idx_connections_to_subscribe ON connections(to_subscribe);
|
||||
CREATE INDEX idx_chat_items_item_direct_group_member_id ON chat_items(
|
||||
item_direct_group_member_id
|
||||
);
|
||||
|
||||
@ -44,7 +44,7 @@ import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
|
||||
import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON)
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
import Simplex.Messaging.Version hiding (version)
|
||||
|
||||
@ -58,10 +58,6 @@ supportedChatVRange = mkVersionRange 1 currentChatVersion
|
||||
groupNoDirectVRange :: VersionRange
|
||||
groupNoDirectVRange = mkVersionRange 2 currentChatVersion
|
||||
|
||||
-- version range that supports private messages from members in a group
|
||||
groupPrivateMessagesVRange :: VersionRange
|
||||
groupPrivateMessagesVRange = mkVersionRange 2 currentChatVersion
|
||||
|
||||
data ConnectionEntity
|
||||
= RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact}
|
||||
| RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember}
|
||||
@ -162,28 +158,11 @@ instance ToJSON SharedMsgId where
|
||||
toJSON = strToJSON
|
||||
toEncoding = strToJEncoding
|
||||
|
||||
data MessageScope = MSGroup | MSDirect
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance FromJSON MessageScope where
|
||||
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MS"
|
||||
|
||||
instance ToJSON MessageScope where
|
||||
toJSON = J.genericToJSON . enumJSON $ dropPrefix "MS"
|
||||
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MS"
|
||||
|
||||
instance ToField MessageScope where
|
||||
toField = toField . encodeJSON
|
||||
|
||||
instance FromField MessageScope where
|
||||
fromField = fromTextField_ decodeJSON
|
||||
|
||||
data MsgRef = MsgRef
|
||||
{ msgId :: Maybe SharedMsgId,
|
||||
sentAt :: UTCTime,
|
||||
sent :: Bool,
|
||||
memberId :: Maybe MemberId, -- must be present in all group message references, both referencing sent and received
|
||||
msgScope :: Maybe MessageScope
|
||||
memberId :: Maybe MemberId -- must be present in all group message references, both referencing sent and received
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
@ -468,13 +447,7 @@ msgContentTag = \case
|
||||
MCFile {} -> MCFile_
|
||||
MCUnknown {tag} -> MCUnknown_ tag
|
||||
|
||||
data ExtMsgContent = ExtMsgContent
|
||||
{ content :: MsgContent,
|
||||
file :: Maybe FileInvitation,
|
||||
ttl :: Maybe Int,
|
||||
live :: Maybe Bool,
|
||||
scope :: Maybe MessageScope
|
||||
}
|
||||
data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool}
|
||||
deriving (Eq, Show)
|
||||
|
||||
parseMsgContainer :: J.Object -> JT.Parser MsgContainer
|
||||
@ -483,10 +456,10 @@ parseMsgContainer v =
|
||||
<|> (v .: "forward" >>= \f -> (if f then MCForward else MCSimple) <$> mc)
|
||||
<|> MCSimple <$> mc
|
||||
where
|
||||
mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live" <*> v .:? "scope"
|
||||
mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live"
|
||||
|
||||
extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent
|
||||
extMsgContent mc file = ExtMsgContent mc file Nothing Nothing Nothing
|
||||
extMsgContent mc file = ExtMsgContent mc file Nothing Nothing
|
||||
|
||||
justTrue :: Bool -> Maybe Bool
|
||||
justTrue True = Just True
|
||||
@ -530,7 +503,7 @@ msgContainerJSON = \case
|
||||
MCSimple mc -> o $ msgContent mc
|
||||
where
|
||||
o = JM.fromList
|
||||
msgContent (ExtMsgContent c file ttl live scope) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) ["content" .= c]
|
||||
msgContent (ExtMsgContent c file ttl live) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) ["content" .= c]
|
||||
|
||||
instance ToJSON MsgContent where
|
||||
toJSON = \case
|
||||
|
||||
@ -25,7 +25,6 @@ module Simplex.Chat.Store.Messages
|
||||
createRcvMsgDeliveryEvent,
|
||||
createPendingGroupMessage,
|
||||
getPendingGroupMessages,
|
||||
deleteMessage,
|
||||
deletePendingGroupMessage,
|
||||
deleteOldMessages,
|
||||
updateChatTs,
|
||||
@ -290,10 +289,6 @@ getPendingGroupMessages db groupMemberId =
|
||||
pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) =
|
||||
PendingGroupMessage {msgId, cmEventTag, msgBody, introId_}
|
||||
|
||||
deleteMessage :: DB.Connection -> MessageId -> IO ()
|
||||
deleteMessage db msgId = do
|
||||
DB.execute db "DELETE FROM messages WHERE message_id = ?" (Only msgId)
|
||||
|
||||
deletePendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> IO ()
|
||||
deletePendingGroupMessage db groupMemberId messageId =
|
||||
DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId)
|
||||
@ -302,7 +297,7 @@ deleteOldMessages :: DB.Connection -> UTCTime -> IO ()
|
||||
deleteOldMessages db createdAtCutoff = do
|
||||
DB.execute db "DELETE FROM messages WHERE created_at <= ?" (Only createdAtCutoff)
|
||||
|
||||
type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId, Maybe MessageScope)
|
||||
type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId)
|
||||
|
||||
updateChatTs :: DB.Connection -> User -> ChatDirection c d -> UTCTime -> IO ()
|
||||
updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirection of
|
||||
@ -325,15 +320,14 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon
|
||||
createdByMsgId = if msgId == 0 then Nothing else Just msgId
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = case quotedItem of
|
||||
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} -> do
|
||||
let (quotedSent, quotedMemberId, quotedMsgScope) = case chatDir of
|
||||
CIQDirectSnd -> (Just True, Nothing, Nothing)
|
||||
CIQDirectRcv -> (Just False, Nothing, Nothing)
|
||||
CIQGroupSnd messageScope -> (Just True, Nothing, Just messageScope)
|
||||
CIQGroupRcv (Just GroupMember {memberId}) messageScope -> (Just False, Just memberId, Just messageScope)
|
||||
CIQGroupRcv Nothing messageScope -> (Just False, Nothing, Just messageScope)
|
||||
(quotedSharedMsgId, Just sentAt, Just content, quotedSent, quotedMemberId, quotedMsgScope)
|
||||
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} ->
|
||||
uncurry (quotedSharedMsgId,Just sentAt,Just content,,) $ case chatDir of
|
||||
CIQDirectSnd -> (Just True, Nothing)
|
||||
CIQDirectRcv -> (Just False, Nothing)
|
||||
CIQGroupSnd -> (Just True, Nothing)
|
||||
CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId)
|
||||
CIQGroupRcv Nothing -> (Just False, Nothing)
|
||||
|
||||
createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c))
|
||||
createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent timed live itemTs createdAt = do
|
||||
@ -344,20 +338,19 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} shar
|
||||
quotedMsg = cmToQuotedMsg chatMsgEvent
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = case quotedMsg of
|
||||
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId, msgScope}, content} -> do
|
||||
let (quotedSent, quotedMemberId, quotedMsgScope) = case chatDirection of
|
||||
CDDirectRcv _ -> (Just $ not sent, Nothing, Nothing)
|
||||
CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ _ ->
|
||||
(Just $ Just userMemberId == memberId, memberId, msgScope)
|
||||
(sharedMsgId, Just sentAt, Just content, quotedSent, quotedMemberId, quotedMsgScope)
|
||||
Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId}, content} ->
|
||||
uncurry (sharedMsgId,Just sentAt,Just content,,) $ case chatDirection of
|
||||
CDDirectRcv _ -> (Just $ not sent, Nothing)
|
||||
CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ ->
|
||||
(Just $ Just userMemberId == memberId, memberId)
|
||||
|
||||
createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItemNoMsg db user chatDirection ciContent =
|
||||
createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False
|
||||
where
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing)
|
||||
|
||||
createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO ChatItemId
|
||||
createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs createdAt = do
|
||||
@ -366,12 +359,12 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
|
||||
[sql|
|
||||
INSERT INTO chat_items (
|
||||
-- user and IDs
|
||||
user_id, created_by_msg_id, contact_id, group_id, group_member_id, item_direct_group_member_id,
|
||||
user_id, created_by_msg_id, contact_id, group_id, group_member_id,
|
||||
-- meta
|
||||
item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at,
|
||||
-- quote
|
||||
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, quoted_message_scope
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((userId, msgId_) :. idsRow :. itemRow :. quoteRow)
|
||||
ciId <- insertedRowId db
|
||||
@ -380,16 +373,12 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q
|
||||
where
|
||||
itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime)
|
||||
itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed
|
||||
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64)
|
||||
idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64)
|
||||
idsRow = case chatDirection of
|
||||
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
|
||||
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing)
|
||||
CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} messageScope -> case messageScope of
|
||||
MSGroup -> (Nothing, Just groupId, Just groupMemberId, Nothing)
|
||||
MSDirect -> (Nothing, Just groupId, Just groupMemberId, Just groupMemberId)
|
||||
CDGroupSnd GroupInfo {groupId} directMember -> case directMember of
|
||||
Nothing -> (Nothing, Just groupId, Nothing, Nothing)
|
||||
Just GroupMember {groupMemberId} -> (Nothing, Just groupId, Nothing, Just groupMemberId)
|
||||
CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
||||
CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing)
|
||||
CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId)
|
||||
CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing)
|
||||
|
||||
ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime)
|
||||
ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt)
|
||||
@ -399,21 +388,19 @@ insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime ->
|
||||
insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts)
|
||||
|
||||
getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c)
|
||||
getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId, msgScope}, content} =
|
||||
getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} =
|
||||
case chatDirection of
|
||||
CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent)
|
||||
CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} _directMember ->
|
||||
CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} ->
|
||||
case memberId of
|
||||
Just mId
|
||||
| mId == userMemberId -> (`ciQuote` CIQGroupSnd messageScope) <$> getUserGroupChatItemId_ groupId
|
||||
| mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender) messageScope) <$> getGroupChatItemId_ groupId mId
|
||||
| mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId
|
||||
| mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId
|
||||
| otherwise -> getGroupChatItemQuote_ groupId mId
|
||||
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing messageScope
|
||||
_ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing
|
||||
where
|
||||
ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c
|
||||
ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content
|
||||
messageScope :: MessageScope
|
||||
messageScope = fromMaybe MSGroup msgScope
|
||||
getDirectChatItemQuote_ :: Int64 -> Bool -> IO (CIQuote 'CTDirect)
|
||||
getDirectChatItemQuote_ contactId userSent = do
|
||||
fmap ciQuoteDirect . maybeFirstRow fromOnly $
|
||||
@ -460,8 +447,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
|
||||
[":user_id" := userId, ":group_id" := groupId, ":member_id" := mId, ":msg_id" := msgId]
|
||||
where
|
||||
ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup
|
||||
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing messageScope
|
||||
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId $ CIQGroupRcv (Just $ toGroupMember userContactId memberRow) messageScope
|
||||
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
|
||||
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
|
||||
|
||||
getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat]
|
||||
getChatPreviews db user withPCC = do
|
||||
@ -569,7 +556,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
|
||||
p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
|
||||
-- quoted ChatItem
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, i.quoted_message_scope,
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
|
||||
-- quoted GroupMember
|
||||
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
||||
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
|
||||
@ -577,11 +564,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||
-- deleted by GroupMember
|
||||
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category,
|
||||
dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
|
||||
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences,
|
||||
-- direct GroupMember
|
||||
dirm.group_member_id, dirm.group_id, dirm.member_id, dirm.member_role, dirm.member_category,
|
||||
dirm.member_status, dirm.invited_by, dirm.local_display_name, dirm.contact_id, dirm.contact_profile_id, dirp.contact_profile_id,
|
||||
dirp.display_name, dirp.full_name, dirp.image, dirp.contact_link, dirp.local_alias, dirp.preferences
|
||||
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences
|
||||
FROM groups g
|
||||
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
|
||||
JOIN group_members mu ON mu.group_id = g.group_id
|
||||
@ -607,8 +590,6 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
|
||||
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id)
|
||||
LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id
|
||||
LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id)
|
||||
LEFT JOIN group_members dirm ON dirm.group_member_id = i.item_direct_group_member_id
|
||||
LEFT JOIN contact_profiles dirp ON dirp.contact_profile_id = COALESCE(dirm.member_profile_id, dirm.contact_profile_id)
|
||||
WHERE g.user_id = ? AND mu.contact_id = ?
|
||||
ORDER BY i.item_ts DESC
|
||||
|]
|
||||
@ -986,7 +967,9 @@ toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect)
|
||||
toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent
|
||||
where
|
||||
direction sent = if sent then CIQDirectSnd else CIQDirectRcv
|
||||
toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir =
|
||||
|
||||
toQuote :: QuoteRow -> Maybe (CIQDirection c) -> Maybe (CIQuote c)
|
||||
toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir =
|
||||
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent)
|
||||
|
||||
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
||||
@ -1030,60 +1013,37 @@ toDirectChatItemList currentTs (((Just itemId, Just itemTs, Just msgDir, Just it
|
||||
either (const []) (: []) $ toDirectChatItem currentTs (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow)
|
||||
toDirectChatItemList _ _ = []
|
||||
|
||||
type GroupQuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MessageScope)
|
||||
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
|
||||
|
||||
type GroupQuoteMemberRow = GroupQuoteRow :. MaybeGroupMemberRow
|
||||
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow
|
||||
|
||||
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteMemberRow :. MaybeGroupMemberRow :. MaybeGroupMemberRow
|
||||
|
||||
toGroupQuote :: GroupQuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup)
|
||||
toGroupQuote qr@(_, _, _, _, quotedSent, msgScope) quotedMember_ =
|
||||
toQuote qr $ direction quotedSent quotedMember_
|
||||
toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup)
|
||||
toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_
|
||||
where
|
||||
direction (Just True) _ = Just $ CIQGroupSnd messageScope
|
||||
direction (Just False) (Just member) = Just $ CIQGroupRcv (Just member) messageScope
|
||||
direction (Just False) Nothing = Just $ CIQGroupRcv Nothing messageScope
|
||||
direction (Just True) _ = Just CIQGroupSnd
|
||||
direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member
|
||||
direction (Just False) Nothing = Just $ CIQGroupRcv Nothing
|
||||
direction _ _ = Nothing
|
||||
messageScope = fromMaybe MSGroup msgScope
|
||||
toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _, _) dir =
|
||||
CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent)
|
||||
|
||||
-- this function can be changed so it never fails, not only avoid failure on invalid json
|
||||
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteMemberRow :. MaybeGroupMemberRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
|
||||
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_) = do
|
||||
toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup)
|
||||
toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do
|
||||
chatItem $ fromRight invalid $ dbParseACIContent itemContentText
|
||||
where
|
||||
member_ = toMaybeGroupMember userContactId memberRow_
|
||||
quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
|
||||
deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_
|
||||
directMember_ = toMaybeGroupMember userContactId directMemberRow_
|
||||
invalid = ACIContent msgDir $ CIInvalidJSON itemContentText
|
||||
chatItem itemContent = case (itemContent, itemStatus, member_, fileStatus_) of
|
||||
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) ->
|
||||
Right $ cItem SMDSnd (CIGroupSnd directMember_) ciStatus ciContent (maybeCIFile fileStatus)
|
||||
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus)
|
||||
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) ->
|
||||
Right $ cItem SMDSnd (CIGroupSnd directMember_) ciStatus ciContent Nothing
|
||||
-- read of group chat item can be refactored so that direct member is not read for rcv items:
|
||||
-- if item_direct_group_member_id is equal to group_member_id, then message scope is direct
|
||||
Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing
|
||||
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) ->
|
||||
case directMember_ of
|
||||
Just directMember
|
||||
| sameMember member directMember ->
|
||||
Right $ cItem SMDRcv (CIGroupRcv member MSDirect) ciStatus ciContent (maybeCIFile fileStatus)
|
||||
| otherwise -> badItem
|
||||
Nothing ->
|
||||
Right $ cItem SMDRcv (CIGroupRcv member MSGroup) ciStatus ciContent (maybeCIFile fileStatus)
|
||||
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus)
|
||||
(ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) ->
|
||||
case directMember_ of
|
||||
Just directMember
|
||||
| sameMember member directMember ->
|
||||
Right $ cItem SMDRcv (CIGroupRcv member MSDirect) ciStatus ciContent Nothing
|
||||
| otherwise -> badItem
|
||||
Nothing ->
|
||||
Right $ cItem SMDRcv (CIGroupRcv member MSGroup) ciStatus ciContent Nothing
|
||||
Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent Nothing
|
||||
_ -> badItem
|
||||
sameMember :: GroupMember -> GroupMember -> Bool
|
||||
sameMember GroupMember {groupMemberId = gmId1} GroupMember {groupMemberId = gmId2} = gmId1 == gmId2
|
||||
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
|
||||
maybeCIFile fileStatus =
|
||||
case (fileId_, fileName_, fileSize_, fileProtocol_) of
|
||||
@ -1108,8 +1068,8 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
toGroupChatItemList :: UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup]
|
||||
toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_) =
|
||||
either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_)
|
||||
toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) =
|
||||
either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_)
|
||||
toGroupChatItemList _ _ _ = []
|
||||
|
||||
getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
|
||||
@ -1524,7 +1484,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
||||
m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id,
|
||||
p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences,
|
||||
-- quoted ChatItem
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, i.quoted_message_scope,
|
||||
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent,
|
||||
-- quoted GroupMember
|
||||
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category,
|
||||
rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id,
|
||||
@ -1532,11 +1492,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
||||
-- deleted by GroupMember
|
||||
dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category,
|
||||
dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id,
|
||||
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences,
|
||||
-- direct GroupMember
|
||||
dirm.group_member_id, dirm.group_id, dirm.member_id, dirm.member_role, dirm.member_category,
|
||||
dirm.member_status, dirm.invited_by, dirm.local_display_name, dirm.contact_id, dirm.contact_profile_id, dirp.contact_profile_id,
|
||||
dirp.display_name, dirp.full_name, dirp.image, dirp.contact_link, dirp.local_alias, dirp.preferences
|
||||
dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences
|
||||
FROM chat_items i
|
||||
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id
|
||||
LEFT JOIN group_members m ON m.group_member_id = i.group_member_id
|
||||
@ -1546,8 +1502,6 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
|
||||
LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id)
|
||||
LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id
|
||||
LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id)
|
||||
LEFT JOIN group_members dirm ON dirm.group_member_id = i.item_direct_group_member_id
|
||||
LEFT JOIN contact_profiles dirp ON dirp.contact_profile_id = COALESCE(dirm.member_profile_id, dirm.contact_profile_id)
|
||||
WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ?
|
||||
|]
|
||||
(userId, groupId, itemId)
|
||||
|
||||
@ -79,7 +79,6 @@ import Simplex.Chat.Migrations.M20230814_indexes
|
||||
import Simplex.Chat.Migrations.M20230827_file_encryption
|
||||
import Simplex.Chat.Migrations.M20230829_connections_chat_vrange
|
||||
import Simplex.Chat.Migrations.M20230903_connections_to_subscribe
|
||||
import Simplex.Chat.Migrations.M20230904_item_direct_group_member_id
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@ -158,8 +157,7 @@ schemaMigrations =
|
||||
("20230814_indexes", m20230814_indexes, Just down_m20230814_indexes),
|
||||
("20230827_file_encryption", m20230827_file_encryption, Just down_m20230827_file_encryption),
|
||||
("20230829_connections_chat_vrange", m20230829_connections_chat_vrange, Just down_m20230829_connections_chat_vrange),
|
||||
("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe),
|
||||
("20230904_item_direct_group_member_id", m20230904_item_direct_group_member_id, Just down_m20230904_item_direct_group_member_id)
|
||||
("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@ -73,19 +73,19 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
|
||||
Right SendMessageBroadcast {} -> True
|
||||
_ -> False
|
||||
startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO ()
|
||||
startLiveMessage (Right (SendLiveMessage sendName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do
|
||||
startLiveMessage (Right (SendLiveMessage chatName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do
|
||||
whenM (isNothing <$> readTVarIO liveMessageState) $ do
|
||||
let s = T.unpack msg
|
||||
int = case cType of SCTGroup -> 5000000; _ -> 3000000 :: Int
|
||||
liveThreadId <- mkWeakThreadId =<< runLiveMessage int `forkFinally` const (atomically $ writeTVar liveMessageState Nothing)
|
||||
promptThreadId <- mkWeakThreadId =<< forkIO blinkLivePrompt
|
||||
atomically $ do
|
||||
let lm = LiveMessage {sendName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId}
|
||||
let lm = LiveMessage {chatName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId}
|
||||
writeTVar liveMessageState (Just lm)
|
||||
modifyTVar termState $ \ts -> ts {inputString = s, inputPosition = length s, inputPrompt = liveInputPrompt lm}
|
||||
where
|
||||
liveInputPrompt LiveMessage {sendName = n, livePrompt} =
|
||||
"> " <> sendNameStr n <> " [" <> (if livePrompt then "LIVE" else " ") <> "] "
|
||||
liveInputPrompt LiveMessage {chatName = n, livePrompt} =
|
||||
"> " <> chatNameStr n <> " [" <> (if livePrompt then "LIVE" else " ") <> "] "
|
||||
runLiveMessage :: Int -> IO ()
|
||||
runLiveMessage int = do
|
||||
threadDelay int
|
||||
@ -123,8 +123,8 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
|
||||
startLiveMessage _ _ = pure ()
|
||||
|
||||
sendUpdatedLiveMessage :: ChatController -> String -> LiveMessage -> Bool -> IO ChatResponse
|
||||
sendUpdatedLiveMessage cc sentMsg LiveMessage {sendName, chatItemId} live = do
|
||||
let cmd = UpdateLiveMessage sendName chatItemId live $ T.pack sentMsg
|
||||
sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do
|
||||
let cmd = UpdateLiveMessage chatName chatItemId live $ T.pack sentMsg
|
||||
either (CRChatCmdError Nothing) id <$> runExceptT (processChatCommand cmd) `runReaderT` cc
|
||||
|
||||
runTerminalInput :: ChatTerminal -> ChatController -> IO ()
|
||||
@ -174,14 +174,14 @@ receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@C
|
||||
let s = inputString ts
|
||||
lm_ <- readTVar liveMessageState
|
||||
case lm_ of
|
||||
Just LiveMessage {sendName}
|
||||
Just LiveMessage {chatName}
|
||||
| live -> do
|
||||
writeTVar termState ts' {previousInput}
|
||||
writeTBQueue inputQ $ "/live " <> sendNameStr sendName
|
||||
writeTBQueue inputQ $ "/live " <> chatNameStr chatName
|
||||
| otherwise ->
|
||||
writeTVar termState ts' {inputPrompt = "> ", previousInput}
|
||||
where
|
||||
previousInput = sendNameStr sendName <> " " <> s
|
||||
previousInput = chatNameStr chatName <> " " <> s
|
||||
_
|
||||
| live -> when (isSend s) $ do
|
||||
writeTVar termState ts' {previousInput = s}
|
||||
|
||||
@ -55,7 +55,7 @@ data AutoCompleteState = ACState
|
||||
}
|
||||
|
||||
data LiveMessage = LiveMessage
|
||||
{ sendName :: SendName,
|
||||
{ chatName :: ChatName,
|
||||
chatItemId :: ChatItemId,
|
||||
livePrompt :: Bool,
|
||||
sentMsg :: String,
|
||||
|
||||
@ -330,12 +330,12 @@ data GroupSummary = GroupSummary
|
||||
|
||||
instance ToJSON GroupSummary where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
data ContactOrGroup = CGContact Contact | CGGroup GroupInfo
|
||||
data ContactOrGroup = CGContact Contact | CGGroup Group
|
||||
|
||||
contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId)
|
||||
contactAndGroupIds = \case
|
||||
CGContact Contact {contactId} -> (Just contactId, Nothing)
|
||||
CGGroup GroupInfo {groupId} -> (Nothing, Just groupId)
|
||||
CGGroup (Group GroupInfo {groupId} _) -> (Nothing, Just groupId)
|
||||
|
||||
-- TODO when more settings are added we should create another type to allow partial setting updates (with all Maybe properties)
|
||||
data ChatSettings = ChatSettings
|
||||
|
||||
@ -322,35 +322,14 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||
testViewChat :: AChat -> [StyledString]
|
||||
testViewChat (AChat _ Chat {chatInfo, chatItems}) = [sShow $ map toChatView chatItems]
|
||||
where
|
||||
toChatView :: CChatItem c -> ((Int, String, Text), Maybe (Int, String, Text), Maybe String)
|
||||
toChatView ci@(CChatItem dir ChatItem {chatDir, quotedItem, file}) =
|
||||
(item, qItem, fPath)
|
||||
toChatView :: CChatItem c -> ((Int, Text), Maybe (Int, Text), Maybe String)
|
||||
toChatView ci@(CChatItem dir ChatItem {quotedItem, file}) =
|
||||
((msgDirectionInt $ toMsgDirection dir, testViewItem ci (chatInfoMembership chatInfo)), qItem, fPath)
|
||||
where
|
||||
item =
|
||||
( msgDirectionInt $ toMsgDirection dir,
|
||||
directMemberName,
|
||||
testViewItem ci (chatInfoMembership chatInfo)
|
||||
)
|
||||
directMemberName = case chatDir of
|
||||
CIGroupSnd (Just GroupMember {localDisplayName = n}) -> T.unpack n
|
||||
CIGroupRcv GroupMember {localDisplayName = n} MSDirect -> T.unpack n
|
||||
_ -> ""
|
||||
qItem = case quotedItem of
|
||||
Nothing -> Nothing
|
||||
Just CIQuote {chatDir = quoteDir, content} ->
|
||||
Just
|
||||
( msgDirectionInt $ quoteMsgDirection quoteDir,
|
||||
qMsgScope,
|
||||
msgContentText content
|
||||
)
|
||||
where
|
||||
qMsgScope = case quoteDir of
|
||||
CIQGroupSnd ms -> msgScopeText ms
|
||||
CIQGroupRcv _ ms -> msgScopeText ms
|
||||
_ -> ""
|
||||
msgScopeText ms = case ms of
|
||||
MSGroup -> "group"
|
||||
MSDirect -> "direct"
|
||||
Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content)
|
||||
fPath = case file of
|
||||
Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp
|
||||
_ -> Nothing
|
||||
@ -401,7 +380,7 @@ viewUsersList = mapMaybe userInfo . sortOn ldn
|
||||
muted :: ChatInfo c -> CIDirection c d -> Bool
|
||||
muted chat chatDir = case (chat, chatDir) of
|
||||
(DirectChat Contact {chatSettings = DisableNtfs}, CIDirectRcv) -> True
|
||||
(GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _ _) -> True
|
||||
(GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _) -> True
|
||||
_ -> False
|
||||
|
||||
viewGroupSubscribed :: GroupInfo -> [StyledString]
|
||||
@ -424,9 +403,8 @@ viewChats ts tz = concatMap chatPreview . reverse
|
||||
where
|
||||
chatName = case chat of
|
||||
DirectChat ct -> [" " <> ttyToContact' ct]
|
||||
GroupChat g -> [" " <> ttyToGroup' g]
|
||||
GroupChat g -> [" " <> ttyToGroup g]
|
||||
_ -> []
|
||||
ttyToGroup' g@GroupInfo {localDisplayName = n} = membershipIncognito g <> ttyTo ("#" <> n <> " ")
|
||||
|
||||
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString]
|
||||
viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file} doShow ts tz =
|
||||
@ -448,20 +426,20 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file}
|
||||
where
|
||||
quote = maybe [] (directQuote chatDir) quotedItem
|
||||
GroupChat g -> case chatDir of
|
||||
CIGroupSnd directMember -> case content of
|
||||
CIGroupSnd -> case content of
|
||||
CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc
|
||||
CISndGroupInvitation {} -> showSndItemProhibited to
|
||||
_ -> showSndItem to
|
||||
where
|
||||
to = ttyToGroup g directMember
|
||||
CIGroupRcv m msgScope -> case content of
|
||||
to = ttyToGroup g
|
||||
CIGroupRcv m -> case content of
|
||||
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvGroupInvitation {} -> showRcvItemProhibited from
|
||||
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m msgScope) quote meta [plainContent content] False
|
||||
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
|
||||
_ -> showRcvItem from
|
||||
where
|
||||
from = ttyFromGroup g m msgScope
|
||||
from = ttyFromGroup g m
|
||||
where
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
_ -> []
|
||||
@ -553,18 +531,18 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive}
|
||||
where
|
||||
quote = maybe [] (directQuote chatDir) quotedItem
|
||||
GroupChat g -> case chatDir of
|
||||
CIGroupRcv m msgScope -> case content of
|
||||
CIGroupRcv m -> case content of
|
||||
CIRcvMsgContent mc
|
||||
| itemLive == Just True && not liveItems -> []
|
||||
| otherwise -> viewReceivedUpdatedMessage from quote mc ts tz meta
|
||||
_ -> []
|
||||
where
|
||||
from = if itemEdited then ttyFromGroupEdited g m msgScope else ttyFromGroup g m msgScope
|
||||
CIGroupSnd directMember -> case content of
|
||||
from = if itemEdited then ttyFromGroupEdited g m else ttyFromGroup g m
|
||||
CIGroupSnd -> case content of
|
||||
CISndMsgContent mc -> hideLive meta $ viewSentMessage to quote mc ts tz meta
|
||||
_ -> []
|
||||
where
|
||||
to = if itemEdited then ttyToGroupEdited g directMember else ttyToGroup g directMember
|
||||
to = if itemEdited then ttyToGroupEdited g else ttyToGroup g
|
||||
where
|
||||
quote = maybe [] (groupQuote g) quotedItem
|
||||
_ -> []
|
||||
@ -589,8 +567,7 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem
|
||||
GroupChat g -> case ciMsgContent deletedContent of
|
||||
Just mc ->
|
||||
let m = chatItemMember g ci
|
||||
msgScope = directMemberToMsgScope $ ciDirDirectMember chatDir
|
||||
in viewReceivedMessage (ttyFromGroupDeleted g m msgScope deletedText_) [] mc ts tz meta
|
||||
in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta
|
||||
_ -> prohibited
|
||||
_ -> prohibited
|
||||
where
|
||||
@ -609,14 +586,14 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md
|
||||
where
|
||||
from = ttyFromContact c
|
||||
reactionMsg mc = quoteText mc $ if toMsgDirection md == MDSnd then ">>" else ">"
|
||||
(GroupChat g, CIGroupRcv m messageScope) -> case ciMsgContent content of
|
||||
(GroupChat g, CIGroupRcv m) -> case ciMsgContent content of
|
||||
Just mc -> view from $ reactionMsg mc
|
||||
_ -> []
|
||||
where
|
||||
from = ttyFromGroup g m messageScope
|
||||
from = ttyFromGroup g m
|
||||
reactionMsg mc = quoteText mc . ttyQuotedMember . Just $ sentByMember' g itemDir
|
||||
(_, CIDirectSnd) -> [sentText]
|
||||
(_, CIGroupSnd _) -> [sentText]
|
||||
(_, CIGroupSnd) -> [sentText]
|
||||
where
|
||||
view from msg
|
||||
| showReactions = viewReceivedReaction from msg reactionText ts tz sentAt
|
||||
@ -644,13 +621,13 @@ groupQuote g CIQuote {content = qmc, chatDir = quoteDir} = quoteText qmc . ttyQu
|
||||
|
||||
sentByMember :: GroupInfo -> CIQDirection 'CTGroup -> Maybe GroupMember
|
||||
sentByMember GroupInfo {membership} = \case
|
||||
CIQGroupSnd _ -> Just membership
|
||||
CIQGroupRcv m _ -> m
|
||||
CIQGroupSnd -> Just membership
|
||||
CIQGroupRcv m -> m
|
||||
|
||||
sentByMember' :: GroupInfo -> CIDirection 'CTGroup d -> GroupMember
|
||||
sentByMember' GroupInfo {membership} = \case
|
||||
CIGroupSnd _ -> membership
|
||||
CIGroupRcv m _ -> m
|
||||
CIGroupSnd -> membership
|
||||
CIGroupRcv m -> m
|
||||
|
||||
quoteText :: MsgContent -> StyledString -> [StyledString]
|
||||
quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc
|
||||
@ -1342,9 +1319,8 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
uploadingFile :: StyledString -> AChatItem -> [StyledString]
|
||||
uploadingFile status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd}) =
|
||||
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyContact c]
|
||||
uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd directMember}) =
|
||||
let forMember = maybe "" (\GroupMember {localDisplayName = m} -> styled (colored Blue) $ " @" <> m <> " (direct)") directMember
|
||||
in [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g <> forMember]
|
||||
uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd}) =
|
||||
[status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g]
|
||||
uploadingFile status _ = [status <> " uploading file"] -- shouldn't happen
|
||||
|
||||
sndFile :: SndFileTransfer -> StyledString
|
||||
@ -1376,7 +1352,7 @@ savingFile' :: Bool -> AChatItem -> [StyledString]
|
||||
savingFile' testView (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath cfArgs_)}, chatDir}) =
|
||||
let from = case (chat, chatDir) of
|
||||
(DirectChat Contact {localDisplayName = c}, CIDirectRcv) -> " from " <> ttyContact c
|
||||
(_, CIGroupRcv GroupMember {localDisplayName = m} _) -> " from " <> ttyContact m
|
||||
(_, CIGroupRcv GroupMember {localDisplayName = m}) -> " from " <> ttyContact m
|
||||
_ -> ""
|
||||
in ["saving file " <> sShow fileId <> from <> " to " <> plain filePath] <> cfArgsStr
|
||||
where
|
||||
@ -1390,7 +1366,7 @@ savingFile' _ _ = ["saving file"] -- shouldn't happen
|
||||
receivingFile_' :: StyledString -> AChatItem -> [StyledString]
|
||||
receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) =
|
||||
[status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact c]
|
||||
receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv GroupMember {localDisplayName = m} _}) =
|
||||
receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv GroupMember {localDisplayName = m}}) =
|
||||
[status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact m]
|
||||
receivingFile_' status _ = [status <> " receiving file"] -- shouldn't happen
|
||||
|
||||
@ -1606,7 +1582,7 @@ viewChatError logLevel = \case
|
||||
CEXFTPSndFile fileId aFileId e -> ["error sending XFTP file " <> sShow fileId <> ", agent file id " <> sShow aFileId <> ": " <> sShow e | logLevel == CLLError]
|
||||
CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"]
|
||||
CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."]
|
||||
CEInvalidQuote -> ["invalid message reply"]
|
||||
CEInvalidQuote -> ["cannot reply to this message"]
|
||||
CEInvalidChatItemUpdate -> ["cannot update this item"]
|
||||
CEInvalidChatItemDelete -> ["cannot delete this item"]
|
||||
CEHasCurrentCall -> ["call already in progress"]
|
||||
@ -1621,7 +1597,6 @@ viewChatError logLevel = \case
|
||||
CEAgentCommandError e -> ["agent command error: " <> plain e]
|
||||
CEInvalidFileDescription e -> ["invalid file description: " <> plain e]
|
||||
CEConnectionIncognitoChangeProhibited -> ["incognito mode change prohibited"]
|
||||
CEPeerChatVRangeIncompatible -> ["peer chat protocol version range incompatible"]
|
||||
CEInternalError e -> ["internal chat error: " <> plain e]
|
||||
CEException e -> ["exception: " <> plain e]
|
||||
-- e -> ["chat error: " <> sShow e]
|
||||
@ -1762,24 +1737,19 @@ ttyFullGroup :: GroupInfo -> StyledString
|
||||
ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName}} =
|
||||
ttyGroup g <> optFullName g fullName
|
||||
|
||||
ttyFromGroup :: GroupInfo -> GroupMember -> MessageScope -> StyledString
|
||||
ttyFromGroup g m ms = membershipIncognito g <> ttyFrom (fromGroup_ g m ms)
|
||||
ttyFromGroup :: GroupInfo -> GroupMember -> StyledString
|
||||
ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m)
|
||||
|
||||
ttyFromGroupEdited :: GroupInfo -> GroupMember -> MessageScope -> StyledString
|
||||
ttyFromGroupEdited g m ms = membershipIncognito g <> ttyFrom (fromGroup_ g m ms <> "[edited] ")
|
||||
ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString
|
||||
ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ")
|
||||
|
||||
ttyFromGroupDeleted :: GroupInfo -> GroupMember -> MessageScope -> Maybe Text -> StyledString
|
||||
ttyFromGroupDeleted g m ms deletedText_ =
|
||||
membershipIncognito g <> ttyFrom (fromGroup_ g m ms <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
|
||||
ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Maybe Text -> StyledString
|
||||
ttyFromGroupDeleted g m deletedText_ =
|
||||
membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
|
||||
|
||||
fromGroup_ :: GroupInfo -> GroupMember -> MessageScope -> Text
|
||||
fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} ms =
|
||||
"#" <> g <> " " <> m <> fromGroupScope ms <> "> "
|
||||
|
||||
fromGroupScope :: MessageScope -> Text
|
||||
fromGroupScope = \case
|
||||
MSGroup -> ""
|
||||
MSDirect -> " (direct)"
|
||||
fromGroup_ :: GroupInfo -> GroupMember -> Text
|
||||
fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} =
|
||||
"#" <> g <> " " <> m <> "> "
|
||||
|
||||
ttyFrom :: Text -> StyledString
|
||||
ttyFrom = styled $ colored Yellow
|
||||
@ -1787,18 +1757,13 @@ ttyFrom = styled $ colored Yellow
|
||||
ttyTo :: Text -> StyledString
|
||||
ttyTo = styled $ colored Cyan
|
||||
|
||||
ttyToGroup :: GroupInfo -> Maybe GroupMember -> StyledString
|
||||
ttyToGroup g@GroupInfo {localDisplayName = n} dirMem =
|
||||
membershipIncognito g <> ttyTo ("#" <> n <> toDirectMember dirMem <> " ")
|
||||
ttyToGroup :: GroupInfo -> StyledString
|
||||
ttyToGroup g@GroupInfo {localDisplayName = n} =
|
||||
membershipIncognito g <> ttyTo ("#" <> n <> " ")
|
||||
|
||||
ttyToGroupEdited :: GroupInfo -> Maybe GroupMember -> StyledString
|
||||
ttyToGroupEdited g@GroupInfo {localDisplayName = n} dirMem =
|
||||
membershipIncognito g <> ttyTo ("#" <> n <> toDirectMember dirMem <> " [edited] ")
|
||||
|
||||
toDirectMember :: Maybe GroupMember -> Text
|
||||
toDirectMember = \case
|
||||
Nothing -> ""
|
||||
Just GroupMember {localDisplayName = m} -> " @" <> m <> " (direct)"
|
||||
ttyToGroupEdited :: GroupInfo -> StyledString
|
||||
ttyToGroupEdited g@GroupInfo {localDisplayName = n} =
|
||||
membershipIncognito g <> ttyTo ("#" <> n <> " [edited] ")
|
||||
|
||||
ttyFilePath :: FilePath -> StyledString
|
||||
ttyFilePath = plain
|
||||
|
||||
@ -8,9 +8,8 @@ import ChatTests.Utils
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Monad (when)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..))
|
||||
import Simplex.Chat.Controller (ChatConfig (..))
|
||||
import Simplex.Chat.Protocol (supportedChatVRange)
|
||||
import Simplex.Chat.Store (agentStoreFile, chatStoreFile)
|
||||
import Simplex.Chat.Types (GroupMemberRole (..))
|
||||
@ -82,21 +81,6 @@ chatGroupTests = do
|
||||
testNoDirect4 _1 _0 _1 False False False -- False False True
|
||||
testNoDirect4 _1 _1 _0 False False False
|
||||
testNoDirect4 _1 _1 _1 False False False
|
||||
describe "group direct messages" $ do
|
||||
it "should send group direct messages" testGroupDirectMessages
|
||||
it "should create group direct messages chat items" testGroupDirectMessagesItems
|
||||
it "should send group direct quotes" testGroupDirectQuotes
|
||||
it "should create group direct quotes chat items" testGroupDirectQuotesItems
|
||||
it "should send group direct XFTP files" testGroupDirectFilesXFTP
|
||||
it "should send group direct SMP files" testGroupDirectFilesSMP
|
||||
it "should cancel sent group direct XFTP file" testGroupDirectCancelFileXFTP
|
||||
it "should send group direct quotes with files" testGroupDirectQuotesFiles
|
||||
it "should update group direct message" testGroupDirectUpdate
|
||||
it "should delete group direct message" testGroupDirectDelete
|
||||
it "should send group direct live message" testGroupDirectLiveMessage
|
||||
it "should send group direct message reactions" testGroupDirectReactions
|
||||
it "should prohibit group direct messages based on preference" testGroupDirectProhibitPreference
|
||||
it "should prohibit group direct messages if peer version doesn't support" testGroupDirectProhibitNotSupported
|
||||
where
|
||||
_0 = supportedChatVRange -- don't create direct connections
|
||||
_1 = groupCreateDirectVRange
|
||||
@ -820,7 +804,7 @@ testGroupMessageQuotedReply =
|
||||
(bob <# "#team alice> hello! how are you?")
|
||||
(cath <# "#team alice> hello! how are you?")
|
||||
threadDelay 1000000
|
||||
bob `send` "> #team >@alice (hello) hello, all good, you?"
|
||||
bob `send` "> #team @alice (hello) hello, all good, you?"
|
||||
bob <# "#team > alice hello! how are you?"
|
||||
bob <## " hello, all good, you?"
|
||||
concurrently_
|
||||
@ -835,7 +819,7 @@ testGroupMessageQuotedReply =
|
||||
bob #$> ("/_get chat #1 count=2", chat', [((0, "hello! how are you?"), Nothing), ((1, "hello, all good, you?"), Just (0, "hello! how are you?"))])
|
||||
alice #$> ("/_get chat #1 count=2", chat', [((1, "hello! how are you?"), Nothing), ((0, "hello, all good, you?"), Just (1, "hello! how are you?"))])
|
||||
cath #$> ("/_get chat #1 count=2", chat', [((0, "hello! how are you?"), Nothing), ((0, "hello, all good, you?"), Just (0, "hello! how are you?"))])
|
||||
bob `send` "> #team >@bob (hello, all good) will tell more"
|
||||
bob `send` "> #team bob (hello, all good) will tell more"
|
||||
bob <# "#team > bob hello, all good, you?"
|
||||
bob <## " will tell more"
|
||||
concurrently_
|
||||
@ -851,7 +835,7 @@ testGroupMessageQuotedReply =
|
||||
alice #$> ("/_get chat #1 count=1", chat', [((0, "will tell more"), Just (0, "hello, all good, you?"))])
|
||||
cath #$> ("/_get chat #1 count=1", chat', [((0, "will tell more"), Just (0, "hello, all good, you?"))])
|
||||
threadDelay 1000000
|
||||
cath `send` "> #team >@bob (hello) hi there!"
|
||||
cath `send` "> #team bob (hello) hi there!"
|
||||
cath <# "#team > bob hello, all good, you?"
|
||||
cath <## " hi there!"
|
||||
concurrently_
|
||||
@ -907,7 +891,7 @@ testGroupMessageUpdate =
|
||||
|
||||
threadDelay 1000000
|
||||
-- alice, bob: msg id 6, cath: msg id 5
|
||||
bob `send` "> #team >@alice (hey) hi alice"
|
||||
bob `send` "> #team @alice (hey) hi alice"
|
||||
bob <# "#team > alice hey 👋"
|
||||
bob <## " hi alice"
|
||||
concurrently_
|
||||
@ -934,7 +918,7 @@ testGroupMessageUpdate =
|
||||
alice #$> ("/_update item #1 " <> msgItemId2 <> " text updating bob's message", id, "cannot update this item")
|
||||
|
||||
threadDelay 1000000
|
||||
cath `send` "> #team >@alice (greetings) greetings!"
|
||||
cath `send` "> #team @alice (greetings) greetings!"
|
||||
cath <# "#team > alice greetings 🤝"
|
||||
cath <## " greetings!"
|
||||
concurrently_
|
||||
@ -1010,6 +994,7 @@ testGroupMessageEditHistory =
|
||||
|
||||
alice ##> ("/_update item #1 " <> aliceItemId <> " text hey there")
|
||||
alice <# "#team [edited] hey there"
|
||||
bob <# "#team alice> [edited] hey there"
|
||||
|
||||
alice ##> "/item info #team hey"
|
||||
alice <##. "sent at: "
|
||||
@ -1019,7 +1004,10 @@ testGroupMessageEditHistory =
|
||||
alice .<## ": hey 👋"
|
||||
alice .<## ": hello!"
|
||||
bob ##> "/item info #team hey"
|
||||
bob <## "message not found by text: hey"
|
||||
bob <##. "sent at: "
|
||||
bob <##. "received at: "
|
||||
bob <## "message history:"
|
||||
bob .<## ": hey there"
|
||||
|
||||
testGroupMessageDelete :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMessageDelete =
|
||||
@ -1043,7 +1031,7 @@ testGroupMessageDelete =
|
||||
|
||||
threadDelay 1000000
|
||||
-- alice: msg id 5, bob: msg id 6, cath: msg id 5
|
||||
bob `send` "> #team >@alice (hello) hi alic"
|
||||
bob `send` "> #team @alice (hello) hi alic"
|
||||
bob <# "#team > alice hello!"
|
||||
bob <## " hi alic"
|
||||
concurrently_
|
||||
@ -1072,10 +1060,14 @@ testGroupMessageDelete =
|
||||
bob ##> ("/_update item #1 " <> msgItemId3 <> " text hi alice")
|
||||
bob <# "#team [edited] > alice hello!"
|
||||
bob <## " hi alice"
|
||||
concurrently_
|
||||
(alice <# "#team bob> [edited] hi alice")
|
||||
( do
|
||||
cath <# "#team bob> [edited] > alice hello!"
|
||||
cath <## " hi alice"
|
||||
)
|
||||
|
||||
alice #$> ("/_get chat #1 count=1", chat', [((0, "connected"), Nothing)])
|
||||
alice #$> ("/_get chat #1 count=1", chat', [((0, "hi alice"), Nothing)])
|
||||
bob #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((1, "hi alice"), Just (0, "hello!"))])
|
||||
cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alice"), Just (0, "hello!"))])
|
||||
|
||||
@ -2694,534 +2686,3 @@ testNoGroupDirectConns4Members hostVRange mem2VRange mem3VRange mem4VRange noCon
|
||||
cc1 <## ("no contact " <> name2)
|
||||
cc2 ##> ("@" <> name1 <> " hi")
|
||||
cc2 <## ("no contact " <> name1)
|
||||
|
||||
testGroupDirectMessages :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectMessages =
|
||||
testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
connectUsers alice dan
|
||||
addMember "team" alice dan GRMember
|
||||
dan ##> "/j team"
|
||||
concurrentlyN_
|
||||
[ alice <## "#team: dan joined the group",
|
||||
do
|
||||
dan <## "#team: you joined the group"
|
||||
dan
|
||||
<### [ "#team: member bob (Bob) is connected",
|
||||
"#team: member cath (Catherine) is connected"
|
||||
],
|
||||
aliceAddedDan bob,
|
||||
aliceAddedDan cath
|
||||
]
|
||||
|
||||
alice #> "#team hi"
|
||||
bob <# "#team alice> hi"
|
||||
cath <# "#team alice> hi"
|
||||
dan <# "#team alice> hi"
|
||||
|
||||
alice `send` "#team @bob hi bob"
|
||||
alice <# "#team @bob (direct) hi bob"
|
||||
bob <# "#team alice (direct)> hi bob"
|
||||
|
||||
bob `send` "#team @alice hi alice"
|
||||
bob <# "#team @alice (direct) hi alice"
|
||||
alice <# "#team bob (direct)> hi alice"
|
||||
|
||||
dan #> "#team hello"
|
||||
alice <# "#team dan> hello"
|
||||
bob <# "#team dan> hello"
|
||||
cath <# "#team dan> hello"
|
||||
|
||||
bob `send` "#team @cath hi cath"
|
||||
bob <# "#team @cath (direct) hi cath"
|
||||
cath <# "#team bob (direct)> hi cath"
|
||||
|
||||
cath `send` "#team @bob hello bob"
|
||||
cath <# "#team @bob (direct) hello bob"
|
||||
bob <# "#team cath (direct)> hello bob"
|
||||
where
|
||||
aliceAddedDan :: HasCallStack => TestCC -> IO ()
|
||||
aliceAddedDan cc = do
|
||||
cc <## "#team: alice added dan (Daniel) to the group (connecting...)"
|
||||
cc <## "#team: new member dan is connected"
|
||||
|
||||
testGroupDirectMessagesItems :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectMessagesItems =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
|
||||
alice #> "#team hi"
|
||||
bob <# "#team alice> hi"
|
||||
cath <# "#team alice> hi"
|
||||
threadDelay 1000000
|
||||
|
||||
alice `send` "#team @bob hi bob"
|
||||
alice <# "#team @bob (direct) hi bob"
|
||||
bob <# "#team alice (direct)> hi bob"
|
||||
threadDelay 1000000
|
||||
|
||||
bob `send` "#team @alice hi alice"
|
||||
bob <# "#team @alice (direct) hi alice"
|
||||
alice <# "#team bob (direct)> hi alice"
|
||||
threadDelay 1000000
|
||||
|
||||
alice #$> ("/_get chat #1 count=4", mapChat, [(0, "", "connected"), (1, "", "hi"), (1, "bob", "hi bob"), (0, "bob", "hi alice")])
|
||||
bob #$> ("/_get chat #1 count=4", mapChat, [(0, "", "connected"), (0, "", "hi"), (0, "alice", "hi bob"), (1, "alice", "hi alice")])
|
||||
cath #$> ("/_get chat #1 count=2", mapChat, [(0, "", "connected"), (0, "", "hi")])
|
||||
where
|
||||
mapChat = map (\(a, _, _) -> a) . chat'''
|
||||
|
||||
testGroupDirectQuotes :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectQuotes =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
|
||||
alice #> "#team 1-g-a"
|
||||
bob <# "#team alice> 1-g-a"
|
||||
cath <# "#team alice> 1-g-a"
|
||||
|
||||
bob #> "#team 2-g-b"
|
||||
alice <# "#team bob> 2-g-b"
|
||||
cath <# "#team bob> 2-g-b"
|
||||
|
||||
cath #> "#team 3-g-c"
|
||||
alice <# "#team cath> 3-g-c"
|
||||
bob <# "#team cath> 3-g-c"
|
||||
|
||||
alice `send` "#team @bob 4-p-ab"
|
||||
alice <# "#team @bob (direct) 4-p-ab"
|
||||
bob <# "#team alice (direct)> 4-p-ab"
|
||||
|
||||
bob `send` "#team @alice 5-p-ba"
|
||||
bob <# "#team @alice (direct) 5-p-ba"
|
||||
alice <# "#team bob (direct)> 5-p-ba"
|
||||
|
||||
alice `send` "#team @cath 6-p-ac"
|
||||
alice <# "#team @cath (direct) 6-p-ac"
|
||||
cath <# "#team alice (direct)> 6-p-ac"
|
||||
|
||||
cath `send` "#team @alice 7-p-ca"
|
||||
cath <# "#team @alice (direct) 7-p-ca"
|
||||
alice <# "#team cath (direct)> 7-p-ca"
|
||||
|
||||
-- quotes
|
||||
|
||||
alice `send` "> #team @bob (1-g-a) 8-pq-ab"
|
||||
alice <# "#team @bob (direct) > alice 1-g-a"
|
||||
alice <## " 8-pq-ab"
|
||||
bob <# "#team alice (direct)> > alice 1-g-a"
|
||||
bob <## " 8-pq-ab"
|
||||
|
||||
alice `send` "> #team @bob (2-g-b) 9-pq-ab"
|
||||
alice <# "#team @bob (direct) > bob 2-g-b"
|
||||
alice <## " 9-pq-ab"
|
||||
bob <# "#team alice (direct)> > bob 2-g-b"
|
||||
bob <## " 9-pq-ab"
|
||||
|
||||
alice `send` "> #team >@cath @bob (3-g-c) 10-pq-ab"
|
||||
alice <# "#team @bob (direct) > cath 3-g-c"
|
||||
alice <## " 10-pq-ab"
|
||||
bob <# "#team alice (direct)> > cath 3-g-c"
|
||||
bob <## " 10-pq-ab"
|
||||
|
||||
alice `send` "> #team @bob (4-p-ab) 11-pq-ab"
|
||||
alice <# "#team @bob (direct) > alice 4-p-ab"
|
||||
alice <## " 11-pq-ab"
|
||||
bob <# "#team alice (direct)> > alice 4-p-ab"
|
||||
bob <## " 11-pq-ab"
|
||||
|
||||
alice `send` "> #team >@bob @bob (5-p-ba) 12-pq-ab"
|
||||
alice <# "#team @bob (direct) > bob 5-p-ba"
|
||||
alice <## " 12-pq-ab"
|
||||
bob <# "#team alice (direct)> > bob 5-p-ba"
|
||||
bob <## " 12-pq-ab"
|
||||
|
||||
alice `send` "> #team @bob (6-p-ac) 13-pq-ab"
|
||||
alice <## "> #team @bob (6-p-ac) 13-pq-ab"
|
||||
alice <## "invalid message reply"
|
||||
|
||||
alice `send` "> #team @bob (7-p-ca) 14-pq-ab"
|
||||
alice <## "> #team @bob (7-p-ca) 14-pq-ab"
|
||||
alice <## "invalid message reply"
|
||||
|
||||
alice `send` "> #team (4-p-ab) 15-gq-a"
|
||||
alice <## "> #team (4-p-ab) 15-gq-a"
|
||||
alice <## "invalid message reply"
|
||||
|
||||
alice `send` "> #team (5-p-ba) 16-gq-a"
|
||||
alice <## "> #team (5-p-ba) 16-gq-a"
|
||||
alice <## "invalid message reply"
|
||||
|
||||
testGroupDirectQuotesItems :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectQuotesItems =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
|
||||
alice #> "#team 1-g-a"
|
||||
bob <# "#team alice> 1-g-a"
|
||||
cath <# "#team alice> 1-g-a"
|
||||
|
||||
alice `send` "#team @bob 2-p-ab"
|
||||
alice <# "#team @bob (direct) 2-p-ab"
|
||||
bob <# "#team alice (direct)> 2-p-ab"
|
||||
|
||||
bob `send` "#team @alice 3-p-ba"
|
||||
bob <# "#team @alice (direct) 3-p-ba"
|
||||
alice <# "#team bob (direct)> 3-p-ba"
|
||||
threadDelay 1000000
|
||||
|
||||
-- quotes
|
||||
|
||||
alice `send` "> #team @bob (1-g-a) 4-pq-ab"
|
||||
alice <# "#team @bob (direct) > alice 1-g-a"
|
||||
alice <## " 4-pq-ab"
|
||||
bob <# "#team alice (direct)> > alice 1-g-a"
|
||||
bob <## " 4-pq-ab"
|
||||
threadDelay 1000000
|
||||
|
||||
alice `send` "> #team @bob (2-p-ab) 5-pq-ab"
|
||||
alice <# "#team @bob (direct) > alice 2-p-ab"
|
||||
alice <## " 5-pq-ab"
|
||||
bob <# "#team alice (direct)> > alice 2-p-ab"
|
||||
bob <## " 5-pq-ab"
|
||||
threadDelay 1000000
|
||||
|
||||
alice `send` "> #team >@bob @bob (3-p-ba) 6-pq-ab"
|
||||
alice <# "#team @bob (direct) > bob 3-p-ba"
|
||||
alice <## " 6-pq-ab"
|
||||
bob <# "#team alice (direct)> > bob 3-p-ba"
|
||||
bob <## " 6-pq-ab"
|
||||
|
||||
alice
|
||||
#$> ( "/_get chat #1 count=3",
|
||||
mapChat,
|
||||
[ ((1, "bob", "4-pq-ab"), Just (1, "group", "1-g-a")),
|
||||
((1, "bob", "5-pq-ab"), Just (1, "direct", "2-p-ab")),
|
||||
((1, "bob", "6-pq-ab"), Just (0, "direct", "3-p-ba"))
|
||||
]
|
||||
)
|
||||
bob
|
||||
#$> ( "/_get chat #1 count=3",
|
||||
mapChat,
|
||||
[ ((0, "alice", "4-pq-ab"), Just (0, "group", "1-g-a")),
|
||||
((0, "alice", "5-pq-ab"), Just (0, "direct", "2-p-ab")),
|
||||
((0, "alice", "6-pq-ab"), Just (1, "direct", "3-p-ba"))
|
||||
]
|
||||
)
|
||||
where
|
||||
mapChat = map (\(a, b, _) -> (a, b)) . chat'''
|
||||
|
||||
testGroupDirectFilesXFTP :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectFilesXFTP =
|
||||
testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
withXFTPServer $ do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
|
||||
alice `send` "/f #team @bob ./tests/fixtures/test.pdf"
|
||||
alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf"
|
||||
alice <## "use /fc 1 to cancel sending"
|
||||
bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)"
|
||||
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)"
|
||||
|
||||
bob ##> "/fr 1 ./tests/tmp"
|
||||
bob
|
||||
<### [ "saving file 1 from alice to ./tests/tmp/test.pdf",
|
||||
"started receiving file 1 (test.pdf) from alice"
|
||||
]
|
||||
bob <## "completed receiving file 1 (test.pdf) from alice"
|
||||
|
||||
src <- B.readFile "./tests/fixtures/test.pdf"
|
||||
dest <- B.readFile "./tests/tmp/test.pdf"
|
||||
dest `shouldBe` src
|
||||
|
||||
cath <// 50000
|
||||
cath ##> "/fr 1 ./tests/tmp"
|
||||
cath <##. "chat db error: SEUserNotFoundByFileId"
|
||||
|
||||
alice `send` "/f #team @cath ./tests/fixtures/test.jpg"
|
||||
alice <# "/f #team @cath (direct) ./tests/fixtures/test.jpg"
|
||||
alice <## "use /fc 2 to cancel sending"
|
||||
cath <# "#team alice (direct)> sends file test.jpg (136.5 KiB / 139737 bytes)"
|
||||
cath <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
alice <## "completed uploading file 2 (test.jpg) for #team @cath (direct)"
|
||||
|
||||
cath ##> "/fr 1 ./tests/tmp"
|
||||
cath
|
||||
<### [ "saving file 1 from alice to ./tests/tmp/test.jpg",
|
||||
"started receiving file 1 (test.jpg) from alice"
|
||||
]
|
||||
cath <## "completed receiving file 1 (test.jpg) from alice"
|
||||
|
||||
src2 <- B.readFile "./tests/fixtures/test.jpg"
|
||||
dest2 <- B.readFile "./tests/tmp/test.jpg"
|
||||
dest2 `shouldBe` src2
|
||||
|
||||
bob <// 50000
|
||||
|
||||
alice #$> ("/_get chat #1 count=2", mapChat, [((1, "bob", ""), Just "./tests/fixtures/test.pdf"), ((1, "cath", ""), Just "./tests/fixtures/test.jpg")])
|
||||
bob #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.pdf")])
|
||||
cath #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.jpg")])
|
||||
where
|
||||
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
|
||||
mapChat = map (\(a, _, c) -> (a, c)) . chat'''
|
||||
|
||||
testGroupDirectFilesSMP :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectFilesSMP =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
|
||||
alice `send` "/f #team @bob ./tests/fixtures/test.pdf"
|
||||
alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf"
|
||||
alice <## "use /fc 1 to cancel sending"
|
||||
bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)"
|
||||
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
bob ##> "/fr 1 ./tests/tmp"
|
||||
bob <## "saving file 1 from alice to ./tests/tmp/test.pdf"
|
||||
concurrently_
|
||||
(alice <## "started sending file 1 (test.pdf) to bob")
|
||||
(bob <## "started receiving file 1 (test.pdf) from alice")
|
||||
concurrently_
|
||||
(alice <## "completed sending file 1 (test.pdf) to bob")
|
||||
(bob <## "completed receiving file 1 (test.pdf) from alice")
|
||||
|
||||
src <- B.readFile "./tests/fixtures/test.pdf"
|
||||
dest <- B.readFile "./tests/tmp/test.pdf"
|
||||
dest `shouldBe` src
|
||||
|
||||
cath <// 50000
|
||||
cath ##> "/fr 1 ./tests/tmp"
|
||||
cath <##. "chat db error: SEUserNotFoundByFileId"
|
||||
|
||||
alice `send` "/f #team @cath ./tests/fixtures/test.jpg"
|
||||
alice <# "/f #team @cath (direct) ./tests/fixtures/test.jpg"
|
||||
alice <## "use /fc 2 to cancel sending"
|
||||
cath <# "#team alice (direct)> sends file test.jpg (136.5 KiB / 139737 bytes)"
|
||||
cath <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
cath ##> "/fr 1 ./tests/tmp"
|
||||
cath <## "saving file 1 from alice to ./tests/tmp/test.jpg"
|
||||
concurrently_
|
||||
(alice <## "started sending file 2 (test.jpg) to cath")
|
||||
(cath <## "started receiving file 1 (test.jpg) from alice")
|
||||
concurrently_
|
||||
(alice <## "completed sending file 2 (test.jpg) to cath")
|
||||
(cath <## "completed receiving file 1 (test.jpg) from alice")
|
||||
|
||||
src2 <- B.readFile "./tests/fixtures/test.jpg"
|
||||
dest2 <- B.readFile "./tests/tmp/test.jpg"
|
||||
dest2 `shouldBe` src2
|
||||
|
||||
bob <// 50000
|
||||
|
||||
alice #$> ("/_get chat #1 count=2", mapChat, [((1, "bob", ""), Just "./tests/fixtures/test.pdf"), ((1, "cath", ""), Just "./tests/fixtures/test.jpg")])
|
||||
bob #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.pdf")])
|
||||
cath #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.jpg")])
|
||||
where
|
||||
mapChat = map (\(a, _, c) -> (a, c)) . chat'''
|
||||
|
||||
testGroupDirectCancelFileXFTP :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectCancelFileXFTP =
|
||||
testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
withXFTPServer $ do
|
||||
createGroup3 "team" alice bob cath
|
||||
|
||||
alice `send` "/f #team @bob ./tests/fixtures/test.pdf"
|
||||
alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf"
|
||||
alice <## "use /fc 1 to cancel sending"
|
||||
bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)"
|
||||
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)"
|
||||
|
||||
cath <// 50000
|
||||
|
||||
alice ##> "/fc 1"
|
||||
alice <## "cancelled sending file 1 (test.pdf) to bob"
|
||||
bob <## "alice cancelled sending file 1 (test.pdf)"
|
||||
|
||||
cath <// 50000
|
||||
|
||||
bob ##> "/fr 1 ./tests/tmp"
|
||||
bob <## "file cancelled: test.pdf"
|
||||
|
||||
cath ##> "/fr 1 ./tests/tmp"
|
||||
cath <##. "chat db error: SEUserNotFoundByFileId"
|
||||
where
|
||||
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
|
||||
|
||||
testGroupDirectQuotesFiles :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectQuotesFiles =
|
||||
testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
withXFTPServer $ do
|
||||
createGroup3 "team" alice bob cath
|
||||
threadDelay 1000000
|
||||
|
||||
bob `send` "#team @alice hi alice"
|
||||
bob <# "#team @alice (direct) hi alice"
|
||||
alice <# "#team bob (direct)> hi alice"
|
||||
threadDelay 1000000
|
||||
|
||||
msgItemId1 <- lastItemId alice
|
||||
alice ##> ("/_send #1 @2 json {\"filePath\": \"./tests/fixtures/test.pdf\", \"quotedItemId\": " <> msgItemId1 <> ", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}")
|
||||
alice <# "#team @bob (direct) > bob hi alice"
|
||||
alice <## " hey bob"
|
||||
alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf"
|
||||
alice <## "use /fc 1 to cancel sending"
|
||||
bob <# "#team alice (direct)> > bob hi alice"
|
||||
bob <## " hey bob"
|
||||
bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)"
|
||||
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)"
|
||||
|
||||
bob ##> "/fr 1 ./tests/tmp"
|
||||
bob
|
||||
<### [ "saving file 1 from alice to ./tests/tmp/test.pdf",
|
||||
"started receiving file 1 (test.pdf) from alice"
|
||||
]
|
||||
bob <## "completed receiving file 1 (test.pdf) from alice"
|
||||
|
||||
src <- B.readFile "./tests/fixtures/test.pdf"
|
||||
dest <- B.readFile "./tests/tmp/test.pdf"
|
||||
dest `shouldBe` src
|
||||
|
||||
cath <// 50000
|
||||
cath ##> "/fr 1 ./tests/tmp"
|
||||
cath <##. "chat db error: SEUserNotFoundByFileId"
|
||||
|
||||
alice
|
||||
#$> ( "/_get chat #1 count=2",
|
||||
chat''',
|
||||
[ ((0, "bob", "hi alice"), Nothing, Nothing),
|
||||
((1, "bob", "hey bob"), Just (0, "direct", "hi alice"), Just "./tests/fixtures/test.pdf")
|
||||
]
|
||||
)
|
||||
bob
|
||||
#$> ( "/_get chat #1 count=2",
|
||||
chat''',
|
||||
[ ((1, "alice", "hi alice"), Nothing, Nothing),
|
||||
((0, "alice", "hey bob"), Just (1, "direct", "hi alice"), Just "./tests/tmp/test.pdf")
|
||||
]
|
||||
)
|
||||
cath #$> ("/_get chat #1 count=1", chat''', [((0, "", "connected"), Nothing, Nothing)])
|
||||
where
|
||||
cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"}
|
||||
|
||||
testGroupDirectUpdate :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectUpdate =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
|
||||
alice `send` "#team @bob hi bob"
|
||||
alice <# "#team @bob (direct) hi bob"
|
||||
bob <# "#team alice (direct)> hi bob"
|
||||
|
||||
msgItemId1 <- lastItemId alice
|
||||
alice ##> ("/_update item #1 " <> msgItemId1 <> " text hey 👋")
|
||||
alice <# "#team @bob (direct) [edited] hey 👋"
|
||||
bob <# "#team alice (direct)> [edited] hey 👋"
|
||||
cath <// 50000
|
||||
|
||||
alice ##> "! #team (hey 👋) hello there"
|
||||
alice <# "#team @bob (direct) [edited] hello there"
|
||||
bob <# "#team alice (direct)> [edited] hello there"
|
||||
cath <// 50000
|
||||
|
||||
testGroupDirectDelete :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectDelete =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
|
||||
alice `send` "#team @bob hi bob"
|
||||
alice <# "#team @bob (direct) hi bob"
|
||||
bob <# "#team alice (direct)> hi bob"
|
||||
|
||||
msgItemId1 <- lastItemId alice
|
||||
alice #$> ("/_delete item #1 " <> msgItemId1 <> " broadcast", id, "message marked deleted")
|
||||
bob <# "#team alice (direct)> [marked deleted] hi bob"
|
||||
cath <// 50000
|
||||
|
||||
testGroupDirectLiveMessage :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectLiveMessage =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
|
||||
alice `send` "/live #team @bob hello"
|
||||
msgItemId1 <- lastItemId alice
|
||||
bob <#. "#team alice (direct)> [LIVE started]"
|
||||
alice ##> ("/_update item #1 " <> msgItemId1 <> " text hello there")
|
||||
alice <# "#team @bob (direct) [LIVE] hello there"
|
||||
bob <# "#team alice (direct)> [LIVE ended] hello there"
|
||||
cath <// 50000
|
||||
|
||||
testGroupDirectReactions :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectReactions =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
|
||||
alice `send` "#team @bob hi bob"
|
||||
alice <# "#team @bob (direct) hi bob"
|
||||
bob <# "#team alice (direct)> hi bob"
|
||||
|
||||
bob ##> "+1 #team hi"
|
||||
bob <## "added 👍"
|
||||
alice <# "#team bob (direct)> > alice hi bob"
|
||||
alice <## " + 👍"
|
||||
cath <// 50000
|
||||
|
||||
alice ##> "+^ #team hi"
|
||||
alice <## "added 🚀"
|
||||
bob <# "#team alice (direct)> > alice hi bob"
|
||||
bob <## " + 🚀"
|
||||
cath <// 50000
|
||||
|
||||
testGroupDirectProhibitPreference :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectProhibitPreference =
|
||||
testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
|
||||
createGroup3' "team" alice bob cath GRMember
|
||||
|
||||
alice ##> "/set direct #team off"
|
||||
alice <## "updated group preferences:"
|
||||
alice <## "Direct messages: off"
|
||||
directProhibited bob
|
||||
directProhibited cath
|
||||
|
||||
bob ##> "#team @cath hi cath"
|
||||
bob <## "bad chat command: direct messages not allowed"
|
||||
|
||||
cath ##> "#team @bob hi cath"
|
||||
cath <## "bad chat command: direct messages not allowed"
|
||||
|
||||
alice ##> "/mr team bob admin"
|
||||
alice <## "#team: you changed the role of bob from member to admin"
|
||||
concurrentlyN_
|
||||
[ bob <## "#team: alice changed your role from member to admin",
|
||||
cath <## "#team: alice changed the role of bob from member to admin"
|
||||
]
|
||||
|
||||
-- admin can send & can send to admin
|
||||
|
||||
bob `send` "#team @cath hi cath, as admin"
|
||||
bob <# "#team @cath (direct) hi cath, as admin"
|
||||
cath <# "#team bob (direct)> hi cath, as admin"
|
||||
|
||||
cath `send` "#team @bob hi bob, to admin"
|
||||
cath <# "#team @bob (direct) hi bob, to admin"
|
||||
bob <# "#team cath (direct)> hi bob, to admin"
|
||||
where
|
||||
directProhibited :: HasCallStack => TestCC -> IO ()
|
||||
directProhibited cc = do
|
||||
cc <## "alice updated group #team:"
|
||||
cc <## "updated group preferences:"
|
||||
cc <## "Direct messages: off"
|
||||
|
||||
testGroupDirectProhibitNotSupported :: HasCallStack => FilePath -> IO ()
|
||||
testGroupDirectProhibitNotSupported tmp =
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
withNewTestChatCfg tmp testCfg {chatVRange = mkVersionRange 1 1} "cath" cathProfile $ \cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
|
||||
bob ##> "#team @cath hi cath"
|
||||
bob <## "peer chat protocol version range incompatible"
|
||||
|
||||
@ -181,12 +181,7 @@ chatF :: String -> [((Int, String), Maybe String)]
|
||||
chatF = map (\(a, _, c) -> (a, c)) . chat''
|
||||
|
||||
chat'' :: String -> [((Int, String), Maybe (Int, String), Maybe String)]
|
||||
chat'' = map (\(a, b, c) -> (mapNoDirect a, mapNoDirect <$> b, c)) . chat'''
|
||||
where
|
||||
mapNoDirect (a1, _, a3) = (a1, a3)
|
||||
|
||||
chat''' :: String -> [((Int, String, String), Maybe (Int, String, String), Maybe String)]
|
||||
chat''' = read
|
||||
chat'' = read
|
||||
|
||||
chatFeatures :: [(Int, String)]
|
||||
chatFeatures = map (\(a, _, _) -> a) chatFeatures''
|
||||
@ -461,33 +456,27 @@ showName (TestCC ChatController {currentUser} _ _ _ _ _) = do
|
||||
pure . T.unpack $ localDisplayName <> optionalFullName localDisplayName fullName
|
||||
|
||||
createGroup2 :: HasCallStack => String -> TestCC -> TestCC -> IO ()
|
||||
createGroup2 gName cc1 cc2 = createGroup2' gName cc1 cc2 GRAdmin
|
||||
|
||||
createGroup2' :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO ()
|
||||
createGroup2' gName cc1 cc2 memberRole = do
|
||||
createGroup2 gName cc1 cc2 = do
|
||||
connectUsers cc1 cc2
|
||||
name2 <- userName cc2
|
||||
cc1 ##> ("/g " <> gName)
|
||||
cc1 <## ("group #" <> gName <> " is created")
|
||||
cc1 <## ("to add members use /a " <> gName <> " <name> or /create link #" <> gName)
|
||||
addMember gName cc1 cc2 memberRole
|
||||
addMember gName cc1 cc2 GRAdmin
|
||||
cc2 ##> ("/j " <> gName)
|
||||
concurrently_
|
||||
(cc1 <## ("#" <> gName <> ": " <> name2 <> " joined the group"))
|
||||
(cc2 <## ("#" <> gName <> ": you joined the group"))
|
||||
|
||||
createGroup3 :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> IO ()
|
||||
createGroup3 gName cc1 cc2 cc3 = createGroup3' gName cc1 cc2 cc3 GRAdmin
|
||||
|
||||
createGroup3' :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> GroupMemberRole -> IO ()
|
||||
createGroup3' gName cc1 cc2 cc3 memberRole = do
|
||||
createGroup2' gName cc1 cc2 memberRole
|
||||
createGroup3 gName cc1 cc2 cc3 = do
|
||||
createGroup2 gName cc1 cc2
|
||||
connectUsers cc1 cc3
|
||||
name1 <- userName cc1
|
||||
name3 <- userName cc3
|
||||
sName2 <- showName cc2
|
||||
sName3 <- showName cc3
|
||||
addMember gName cc1 cc3 memberRole
|
||||
addMember gName cc1 cc3 GRAdmin
|
||||
cc3 ##> ("/j " <> gName)
|
||||
concurrentlyN_
|
||||
[ cc1 <## ("#" <> gName <> ": " <> name3 <> " joined the group"),
|
||||
|
||||
@ -57,7 +57,7 @@ testConnReq = CRInvitationUri connReqData testE2ERatchetParams
|
||||
quotedMsg :: QuotedMsg
|
||||
quotedMsg =
|
||||
QuotedMsg
|
||||
(MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing Nothing)
|
||||
(MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing)
|
||||
$ MCText "hello there!"
|
||||
|
||||
(==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation
|
||||
@ -105,13 +105,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))
|
||||
it "x.msg.new simple text - timed message TTL" $
|
||||
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"ttl\":3600}}"
|
||||
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing Nothing))
|
||||
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing))
|
||||
it "x.msg.new simple text - live message" $
|
||||
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"live\":true}}"
|
||||
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True) Nothing))
|
||||
it "x.msg.new simple text - direct message scope" $
|
||||
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"scope\":\"direct\"}}"
|
||||
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing Nothing (Just MSDirect)))
|
||||
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True)))
|
||||
it "x.msg.new simple link" $
|
||||
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA", content = Nothing}) Nothing))
|
||||
@ -133,41 +130,27 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
|
||||
chatInitialVRange
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
(XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing)))
|
||||
it "x.msg.new quote - direct referenced message scope" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\",\"msgScope\":\"direct\"}}}}"
|
||||
##==## ChatMessage
|
||||
chatInitialVRange
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
( XMsgNew
|
||||
( MCQuote
|
||||
( QuotedMsg
|
||||
(MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing (Just MSDirect))
|
||||
$ MCText "hello there!"
|
||||
)
|
||||
(extMsgContent (MCText "hello to you too") Nothing)
|
||||
)
|
||||
)
|
||||
it "x.msg.new quote - timed message TTL" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"ttl\":3600}}"
|
||||
##==## ChatMessage
|
||||
chatInitialVRange
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing Nothing)))
|
||||
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing)))
|
||||
it "x.msg.new quote - live message" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"live\":true}}"
|
||||
##==## ChatMessage
|
||||
chatInitialVRange
|
||||
(Just $ SharedMsgId "\1\2\3\4")
|
||||
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True) Nothing)))
|
||||
(XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True))))
|
||||
it "x.msg.new forward" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}"
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing))
|
||||
it "x.msg.new forward - timed message TTL" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}"
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing Nothing))
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing))
|
||||
it "x.msg.new forward - live message" $
|
||||
"{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}"
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True) Nothing))
|
||||
##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True)))
|
||||
it "x.msg.new simple text with file" $
|
||||
"{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
|
||||
#==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user