core: use version from config, add tests (#3588)
* core: use version from config, add tests * comment * refactor
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
5a6670998c
commit
af22348bf8
@ -356,11 +356,12 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
|
||||
subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m ()
|
||||
subscribeUsers onlyNeeded users = do
|
||||
let (us, us') = partition activeUser users
|
||||
subscribe us
|
||||
subscribe us'
|
||||
vr <- chatVersionRange
|
||||
subscribe vr us
|
||||
subscribe vr us'
|
||||
where
|
||||
subscribe :: [User] -> m ()
|
||||
subscribe = mapM_ $ runExceptT . subscribeUserConnections onlyNeeded Agent.subscribeConnections
|
||||
subscribe :: VersionRange -> [User] -> m ()
|
||||
subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections
|
||||
|
||||
startFilesToReceive :: forall m. ChatMonad' m => [User] -> m ()
|
||||
startFilesToReceive users = do
|
||||
@ -437,7 +438,11 @@ parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
|
||||
|
||||
-- | Chat API commands interpreted in context of a local zone
|
||||
processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse
|
||||
processChatCommand = \case
|
||||
processChatCommand cmd = chatVersionRange >>= (`processChatCommand'` cmd)
|
||||
{-# INLINE processChatCommand #-}
|
||||
|
||||
processChatCommand' :: forall m. ChatMonad m => VersionRange -> ChatCommand -> m ChatResponse
|
||||
processChatCommand' vr = \case
|
||||
ShowActiveUser -> withUser' $ pure . CRActiveUser
|
||||
CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do
|
||||
forM_ profile $ \Profile {displayName} -> checkValidName displayName
|
||||
@ -607,7 +612,7 @@ processChatCommand = \case
|
||||
. M.assocs
|
||||
<$> withConnection st (readTVarIO . DB.slow)
|
||||
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do
|
||||
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db user pendingConnections pagination query)
|
||||
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user pendingConnections pagination query)
|
||||
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
|
||||
pure $ CRApiChats user previews
|
||||
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of
|
||||
@ -616,16 +621,16 @@ processChatCommand = \case
|
||||
directChat <- withStore (\db -> getDirectChat db user cId pagination search)
|
||||
pure $ CRApiChat user (AChat SCTDirect directChat)
|
||||
CTGroup -> do
|
||||
groupChat <- withStore (\db -> getGroupChat db user cId pagination search)
|
||||
groupChat <- withStore (\db -> getGroupChat db vr user cId pagination search)
|
||||
pure $ CRApiChat user (AChat SCTGroup groupChat)
|
||||
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIGetChatItems pagination search -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user pagination search
|
||||
chatItems <- withStore $ \db -> getAllChatItems db vr user pagination search
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do
|
||||
(aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db ->
|
||||
(,) <$> getAChatItem db user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
|
||||
(,) <$> getAChatItem db vr user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
|
||||
let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions
|
||||
memberDeliveryStatuses <- case (cType, dir) of
|
||||
(SCTGroup, SMDSnd) -> do
|
||||
@ -699,7 +704,7 @@ processChatCommand = \case
|
||||
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
|
||||
quoteData _ = throwChatError CEInvalidQuote
|
||||
CTGroup -> do
|
||||
g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId
|
||||
g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user chatId
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
send g
|
||||
where
|
||||
@ -804,7 +809,7 @@ processChatCommand = \case
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
|
||||
CTGroup -> do
|
||||
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db user chatId
|
||||
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db vr user chatId
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId
|
||||
case cci of
|
||||
@ -840,7 +845,7 @@ processChatCommand = \case
|
||||
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
|
||||
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
CTGroup -> do
|
||||
Group gInfo ms <- withStore $ \db -> getGroup db user chatId
|
||||
Group gInfo ms <- withStore $ \db -> getGroup db vr user chatId
|
||||
CChatItem msgDir ci@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
|
||||
@ -852,7 +857,7 @@ processChatCommand = \case
|
||||
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
|
||||
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db vr user gId
|
||||
CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId
|
||||
case (chatDir, itemSharedMsgId) of
|
||||
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
|
||||
@ -881,7 +886,7 @@ processChatCommand = \case
|
||||
pure $ CRChatItemReaction user add r
|
||||
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
|
||||
CTGroup ->
|
||||
withStore (\db -> (,) <$> getGroup db user chatId <*> getGroupChatItem db user chatId itemId) >>= \case
|
||||
withStore (\db -> (,) <$> getGroup db vr 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))
|
||||
@ -940,7 +945,7 @@ processChatCommand = \case
|
||||
ok user
|
||||
CTGroup -> do
|
||||
withStore $ \db -> do
|
||||
Group {groupInfo} <- getGroup db user chatId
|
||||
Group {groupInfo} <- getGroup db vr user chatId
|
||||
liftIO $ updateGroupUnreadChat db user groupInfo unreadChat
|
||||
ok user
|
||||
_ -> pure $ chatCmdError (Just user) "not supported"
|
||||
@ -965,7 +970,7 @@ processChatCommand = \case
|
||||
withStore' $ \db -> deletePendingContactConnection db userId chatId
|
||||
pure $ CRContactConnectionDeleted user conn
|
||||
CTGroup -> do
|
||||
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId
|
||||
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user chatId
|
||||
let isOwner = membership.memberRole == GROwner
|
||||
canDelete = isOwner || not (memberCurrent membership)
|
||||
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
|
||||
@ -1008,7 +1013,7 @@ processChatCommand = \case
|
||||
withStore' $ \db -> deleteContactCIs db user ct
|
||||
pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct)
|
||||
CTGroup -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user chatId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user chatId
|
||||
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
deleteFilesAndConns user filesInfo
|
||||
withStore' $ \db -> deleteGroupCIs db user gInfo
|
||||
@ -1152,7 +1157,7 @@ processChatCommand = \case
|
||||
user_ <- withStore' (`getUserByAConnId` agentConnId)
|
||||
connEntity_ <-
|
||||
pure user_ $>>= \user ->
|
||||
withStore (\db -> Just <$> getConnectionEntity db user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
|
||||
withStore (\db -> Just <$> getConnectionEntity db vr user agentConnId) `catchChatError` (\e -> toView (CRChatError (Just user) e) $> Nothing)
|
||||
pure CRNtfMessages {user_, connEntity_, msgTs = msgTs', ntfMessages = map ntfMsgInfo msgs}
|
||||
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
|
||||
ChatConfig {defaultServers} <- asks config
|
||||
@ -1215,7 +1220,7 @@ processChatCommand = \case
|
||||
ok user
|
||||
CTGroup -> do
|
||||
ms <- withStore $ \db -> do
|
||||
Group _ ms <- getGroup db user chatId
|
||||
Group _ ms <- getGroup db vr user chatId
|
||||
liftIO $ updateGroupSettings db user chatId chatSettings
|
||||
pure ms
|
||||
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
|
||||
@ -1240,10 +1245,10 @@ processChatCommand = \case
|
||||
connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct)
|
||||
pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile)
|
||||
APIGroupInfo gId -> withUser $ \user -> do
|
||||
(g, s) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> liftIO (getGroupSummary db user gId)
|
||||
(g, s) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> liftIO (getGroupSummary db user gId)
|
||||
pure $ CRGroupInfo user g s
|
||||
APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
|
||||
connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
|
||||
pure $ CRGroupMemberInfo user g m connectionStats
|
||||
APISwitchContact contactId -> withUser $ \user -> do
|
||||
@ -1254,7 +1259,7 @@ processChatCommand = \case
|
||||
pure $ CRContactSwitchStarted user ct connectionStats
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APISwitchGroupMember gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
|
||||
case memberConnId m of
|
||||
Just connId -> do
|
||||
connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId)
|
||||
@ -1268,7 +1273,7 @@ processChatCommand = \case
|
||||
pure $ CRContactSwitchAborted user ct connectionStats
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
|
||||
case memberConnId m of
|
||||
Just connId -> do
|
||||
connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
|
||||
@ -1283,7 +1288,7 @@ processChatCommand = \case
|
||||
pure $ CRContactRatchetSyncStarted user ct cStats
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> withChatLock "syncGroupMemberRatchet" $ do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
|
||||
case memberConnId m of
|
||||
Just connId -> do
|
||||
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force
|
||||
@ -1305,7 +1310,7 @@ processChatCommand = \case
|
||||
pure $ CRContactCode user ct' code
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do
|
||||
(g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
(g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
|
||||
case activeConn of
|
||||
Just conn@Connection {connId} -> do
|
||||
code <- getConnectionCode $ aConnId conn
|
||||
@ -1487,7 +1492,7 @@ processChatCommand = \case
|
||||
let chatRef = ChatRef CTDirect ctId
|
||||
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc
|
||||
Left _ ->
|
||||
withStore' (\db -> runExceptT $ getActiveMembersByName db user name) >>= \case
|
||||
withStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
|
||||
Right [(gInfo, member)] -> do
|
||||
let GroupInfo {localDisplayName = gName} = gInfo
|
||||
GroupMember {localDisplayName = mName} = member
|
||||
@ -1507,7 +1512,7 @@ processChatCommand = \case
|
||||
let mc = MCText msg
|
||||
case memberContactId m of
|
||||
Nothing -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user gId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user gId
|
||||
toView $ CRNoMemberContactCreating user gInfo m
|
||||
processChatCommand (APICreateMemberContact gId mId) >>= \case
|
||||
cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do
|
||||
@ -1567,13 +1572,13 @@ processChatCommand = \case
|
||||
gVar <- asks random
|
||||
-- [incognito] generate incognito profile for group membership
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
groupInfo <- withStore $ \db -> createNewGroup db gVar user gProfile incognitoProfile
|
||||
groupInfo <- withStore $ \db -> createNewGroup db vr gVar user gProfile incognitoProfile
|
||||
pure $ CRGroupCreated user groupInfo
|
||||
NewGroup incognito gProfile -> withUser $ \User {userId} ->
|
||||
processChatCommand $ APINewGroup userId incognito gProfile
|
||||
APIAddMember groupId contactId memRole -> withUser $ \user -> withChatLock "addMember" $ do
|
||||
-- TODO for large groups: no need to load all members to determine if contact is a member
|
||||
(group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db user contactId
|
||||
(group, contact) <- withStore $ \db -> (,) <$> getGroup db vr user groupId <*> getContact db user contactId
|
||||
assertDirectAllowed user MDSnd contact XGrpInv_
|
||||
let Group gInfo members = group
|
||||
Contact {localDisplayName = cName} = contact
|
||||
@ -1603,7 +1608,7 @@ processChatCommand = \case
|
||||
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
withChatLock "joinGroup" . procCmd $ do
|
||||
(invitation, ct) <- withStore $ \db -> do
|
||||
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db user groupId
|
||||
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db vr user groupId
|
||||
(inv,) <$> getContactViaMember db user fromMember
|
||||
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
|
||||
Contact {activeConn} = ct
|
||||
@ -1621,14 +1626,14 @@ processChatCommand = \case
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
where
|
||||
updateCIGroupInvitationStatus user = do
|
||||
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId
|
||||
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db vr user groupId
|
||||
case (cInfo, content) of
|
||||
(DirectChat ct, CIRcvGroupInvitation ciGroupInv memRole) -> do
|
||||
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole
|
||||
updateDirectChatItemView user ct itemId aciContent False Nothing
|
||||
_ -> pure () -- prohibited
|
||||
APIMemberRole groupId memberId memRole -> withUser $ \user -> do
|
||||
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId
|
||||
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId
|
||||
if memberId == groupMemberId' membership
|
||||
then changeMemberRole user gInfo members membership $ SGEUserRole memRole
|
||||
else case find ((== memberId) . groupMemberId') members of
|
||||
@ -1652,7 +1657,7 @@ processChatCommand = \case
|
||||
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
|
||||
Group gInfo members <- withStore $ \db -> getGroup db user groupId
|
||||
Group gInfo members <- withStore $ \db -> getGroup db vr user groupId
|
||||
case find ((== memberId) . groupMemberId') members of
|
||||
Nothing -> throwChatError CEGroupMemberNotFound
|
||||
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do
|
||||
@ -1671,7 +1676,7 @@ processChatCommand = \case
|
||||
deleteOrUpdateMemberRecord user m
|
||||
pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved}
|
||||
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId
|
||||
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId
|
||||
withChatLock "leaveGroup" . procCmd $ do
|
||||
(msg, _) <- sendGroupMessage user gInfo members XGrpLeave
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft)
|
||||
@ -1683,7 +1688,7 @@ processChatCommand = \case
|
||||
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
|
||||
pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}}
|
||||
APIListMembers groupId -> withUser $ \user ->
|
||||
CRGroupMembers user <$> withStore (\db -> getGroup db user groupId)
|
||||
CRGroupMembers user <$> withStore (\db -> getGroup db vr user groupId)
|
||||
AddMember gName cName memRole -> withUser $ \user -> do
|
||||
(groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName
|
||||
processChatCommand $ APIAddMember groupId contactId memRole
|
||||
@ -1705,23 +1710,23 @@ processChatCommand = \case
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIListMembers groupId
|
||||
APIListGroups userId contactId_ search_ -> withUserId userId $ \user ->
|
||||
CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db user contactId_ search_)
|
||||
CRGroupsList user <$> withStore' (\db -> getUserGroupsWithSummary db vr user contactId_ search_)
|
||||
ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
|
||||
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
|
||||
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
|
||||
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
|
||||
g <- withStore $ \db -> getGroup db user groupId
|
||||
g <- withStore $ \db -> getGroup db vr user groupId
|
||||
runUpdateGroupProfile user g p'
|
||||
UpdateGroupNames gName GroupProfile {displayName, fullName} ->
|
||||
updateGroupProfileByName gName $ \p -> p {displayName, fullName}
|
||||
ShowGroupProfile gName -> withUser $ \user ->
|
||||
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName)
|
||||
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db vr user gName)
|
||||
UpdateGroupDescription gName description ->
|
||||
updateGroupProfileByName gName $ \p -> p {description}
|
||||
ShowGroupDescription gName -> withUser $ \user ->
|
||||
CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db user gName)
|
||||
CRGroupDescription user <$> withStore (\db -> getGroupInfoByName db vr user gName)
|
||||
APICreateGroupLink groupId mRole -> withUser $ \user -> withChatLock "createGroupLink" $ do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
assertUserGroupRole gInfo GRAdmin
|
||||
when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole
|
||||
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
|
||||
@ -1731,22 +1736,22 @@ processChatCommand = \case
|
||||
withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode
|
||||
pure $ CRGroupLinkCreated user gInfo cReq mRole
|
||||
APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withChatLock "groupLinkMemberRole " $ do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
(groupLinkId, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
|
||||
assertUserGroupRole gInfo GRAdmin
|
||||
when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole'
|
||||
when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole'
|
||||
pure $ CRGroupLink user gInfo groupLink mRole'
|
||||
APIDeleteGroupLink groupId -> withUser $ \user -> withChatLock "deleteGroupLink" $ do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
deleteGroupLink' user gInfo
|
||||
pure $ CRGroupLinkDeleted user gInfo
|
||||
APIGetGroupLink groupId -> withUser $ \user -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
(_, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
|
||||
pure $ CRGroupLink user gInfo groupLink mRole
|
||||
APICreateMemberContact gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db vr user gId <*> getGroupMember db user gId gMemberId
|
||||
assertUserGroupRole g GRAuthor
|
||||
unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed"
|
||||
case memberConn m of
|
||||
@ -1762,7 +1767,7 @@ processChatCommand = \case
|
||||
pure $ CRNewMemberContact user ct g m
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do
|
||||
(g, m, ct, cReq) <- withStore $ \db -> getMemberContact db user contactId
|
||||
(g, m, ct, cReq) <- withStore $ \db -> getMemberContact db vr user contactId
|
||||
when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent"
|
||||
case memberConn m of
|
||||
Just mConn -> do
|
||||
@ -1794,7 +1799,7 @@ processChatCommand = \case
|
||||
processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
|
||||
LastChats count_ -> withUser' $ \user -> do
|
||||
let count = fromMaybe 5000 count_
|
||||
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db user False (PTLast count) clqNoFilters)
|
||||
(errs, previews) <- partitionEithers <$> withStore' (\db -> getChatPreviews db vr user False (PTLast count) clqNoFilters)
|
||||
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
|
||||
pure $ CRChats previews
|
||||
LastMessages (Just chatName) count search -> withUser $ \user -> do
|
||||
@ -1802,22 +1807,22 @@ processChatCommand = \case
|
||||
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
|
||||
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
|
||||
LastMessages Nothing count search -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast count) search
|
||||
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast count) search
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
LastChatItemId (Just chatName) index -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
|
||||
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp)
|
||||
LastChatItemId Nothing index -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast $ index + 1) Nothing
|
||||
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast $ index + 1) Nothing
|
||||
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe $ chatItems)
|
||||
ShowChatItem (Just itemId) -> withUser $ \user -> do
|
||||
chatItem <- withStore $ \db -> do
|
||||
chatRef <- getChatRefViaItemId db user itemId
|
||||
getAChatItem db user chatRef itemId
|
||||
getAChatItem db vr user chatRef itemId
|
||||
pure $ CRChatItems user Nothing ((: []) chatItem)
|
||||
ShowChatItem Nothing -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast 1) Nothing
|
||||
chatItems <- withStore $ \db -> getAllChatItems db vr user (CPLast 1) Nothing
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
ShowChatItemInfo chatName msg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
@ -1867,10 +1872,10 @@ processChatCommand = \case
|
||||
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
|
||||
Group gInfo ms <- withStore $ \db -> getGroup db vr user groupId
|
||||
void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
|
||||
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
|
||||
ci <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
pure $ CRSndFileCancelled user ci ftm fts
|
||||
where
|
||||
fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} =
|
||||
@ -1881,7 +1886,7 @@ processChatCommand = \case
|
||||
| otherwise -> case xftpRcvFile of
|
||||
Nothing -> do
|
||||
cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user)
|
||||
ci <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
pure $ CRRcvFileCancelled user ci ftr
|
||||
Just XFTPRcvFile {agentRcvFileId} -> do
|
||||
forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do
|
||||
@ -1894,10 +1899,10 @@ processChatCommand = \case
|
||||
updateCIFileStatus db user fileId CIFSRcvInvitation
|
||||
updateRcvFileStatus db fileId FSNew
|
||||
updateRcvFileAgentId db fileId Nothing
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
pure $ CRRcvFileCancelled user ci ftr
|
||||
FileStatus fileId -> withUser $ \user -> do
|
||||
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
case file of
|
||||
Just CIFile {fileProtocol = FPXFTP} ->
|
||||
pure $ CRFileTransferStatusXFTP user ci
|
||||
@ -2199,7 +2204,7 @@ processChatCommand = \case
|
||||
updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse
|
||||
updateGroupProfileByName gName update = withUser $ \user -> do
|
||||
g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db ->
|
||||
getGroupIdByName db user gName >>= getGroup db user
|
||||
getGroupIdByName db user gName >>= getGroup db vr user
|
||||
runUpdateGroupProfile user g $ update p
|
||||
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
|
||||
withCurrentCall ctId action = do
|
||||
@ -2314,15 +2319,16 @@ processChatCommand = \case
|
||||
ctId <- getContactIdByName db user name
|
||||
Contact {chatSettings} <- getContact db user ctId
|
||||
pure (ctId, chatSettings)
|
||||
CTGroup -> withStore $ \db -> do
|
||||
CTGroup ->
|
||||
withStore $ \db -> do
|
||||
gId <- getGroupIdByName db user name
|
||||
GroupInfo {chatSettings} <- getGroupInfo db user gId
|
||||
GroupInfo {chatSettings} <- getGroupInfo db vr user gId
|
||||
pure (gId, chatSettings)
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
|
||||
connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan
|
||||
connectPlan user (ACR SCMInvitation cReq) = do
|
||||
withStore' (\db -> getConnectionEntityByConnReq db user cReqSchemas) >>= \case
|
||||
withStore' (\db -> getConnectionEntityByConnReq db vr user cReqSchemas) >>= \case
|
||||
Nothing -> pure $ CPInvitationLink ILPOk
|
||||
Just (RcvDirectMsgConnection conn ct_) -> do
|
||||
let Connection {connStatus, contactConnInitiated} = conn
|
||||
@ -2351,7 +2357,7 @@ processChatCommand = \case
|
||||
withStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case
|
||||
Just _ -> pure $ CPContactAddress CAPOwnLink
|
||||
Nothing ->
|
||||
withStore' (\db -> getContactConnEntityByConnReqHash db user cReqHashes) >>= \case
|
||||
withStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case
|
||||
Nothing ->
|
||||
withStore' (\db -> getContactWithoutConnViaAddress db user cReqSchemas) >>= \case
|
||||
Nothing -> pure $ CPContactAddress CAPOk
|
||||
@ -2364,11 +2370,11 @@ processChatCommand = \case
|
||||
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
|
||||
-- group link
|
||||
Just _ ->
|
||||
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db user cReqSchemas) >>= \case
|
||||
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case
|
||||
Just g -> pure $ CPGroupLink (GLPOwnLink g)
|
||||
Nothing -> do
|
||||
connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db user cReqHashes
|
||||
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db user cReqHashes
|
||||
connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes
|
||||
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes
|
||||
case (gInfo_, connEnt_) of
|
||||
(Nothing, Nothing) -> pure $ CPGroupLink GLPOk
|
||||
(Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect
|
||||
@ -2598,6 +2604,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
unless (fileStatus == RFSNew) $ case fileStatus of
|
||||
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
|
||||
_ -> throwChatError $ CEFileAlreadyReceiving fName
|
||||
vr <- chatVersionRange
|
||||
case (xftpRcvFile, fileConnReq) of
|
||||
-- direct file protocol
|
||||
(Nothing, Just connReq) -> do
|
||||
@ -2605,14 +2612,14 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
dm <- directMessage $ XFileAcpt fName
|
||||
connIds <- joinAgentConnectionAsync user True connReq dm subMode
|
||||
filePath <- getRcvFilePath fileId filePath_ fName True
|
||||
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath subMode
|
||||
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnJoined filePath subMode
|
||||
-- XFTP
|
||||
(Just XFTPRcvFile {}, _) -> do
|
||||
filePath <- getRcvFilePath fileId filePath_ fName False
|
||||
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
|
||||
-- marking file as accepted and reading description in the same transaction
|
||||
-- to prevent race condition with appending description
|
||||
ci <- xftpAcceptRcvFT db user fileId filePath
|
||||
ci <- xftpAcceptRcvFT db vr user fileId filePath
|
||||
rfd <- getRcvFileDescrByRcvFileId db fileId
|
||||
pure (ci, rfd)
|
||||
receiveViaCompleteFD user fileId rfd cryptoArgs
|
||||
@ -2636,10 +2643,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
acceptFile cmdFunction send = do
|
||||
filePath <- getRcvFilePath fileId filePath_ fName True
|
||||
inline <- receiveInline
|
||||
vr <- chatVersionRange
|
||||
if
|
||||
| inline -> do
|
||||
-- accepting inline
|
||||
ci <- withStoreCtx (Just "acceptFile, acceptRcvInlineFT") $ \db -> acceptRcvInlineFT db user fileId filePath
|
||||
ci <- withStoreCtx (Just "acceptFile, acceptRcvInlineFT") $ \db -> acceptRcvInlineFT db vr user fileId filePath
|
||||
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
|
||||
send $ XFileAcptInv sharedMsgId Nothing fName
|
||||
pure ci
|
||||
@ -2648,7 +2656,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
-- accepting via a new connection
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode
|
||||
withStoreCtx (Just "acceptFile, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnNew filePath subMode
|
||||
withStoreCtx (Just "acceptFile, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db vr user fileId connIds ConnNew filePath subMode
|
||||
receiveInline :: m Bool
|
||||
receiveInline = do
|
||||
ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config
|
||||
@ -2669,10 +2677,11 @@ receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete}
|
||||
|
||||
startReceivingFile :: ChatMonad m => User -> FileTransferId -> m ()
|
||||
startReceivingFile user fileId = do
|
||||
vr <- chatVersionRange
|
||||
ci <- withStoreCtx (Just "startReceivingFile, updateRcvFileStatus ...") $ \db -> do
|
||||
liftIO $ updateRcvFileStatus db fileId FSConnected
|
||||
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileStart user ci
|
||||
|
||||
getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> Bool -> m FilePath
|
||||
@ -2788,14 +2797,14 @@ agentSubscriber = do
|
||||
|
||||
type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ()))
|
||||
|
||||
subscribeUserConnections :: forall m. ChatMonad m => Bool -> AgentBatchSubscribe m -> User -> m ()
|
||||
subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
|
||||
subscribeUserConnections :: forall m. ChatMonad m => VersionRange -> Bool -> AgentBatchSubscribe m -> User -> m ()
|
||||
subscribeUserConnections vr onlyNeeded agentBatchSubscribe user@User {userId} = do
|
||||
-- get user connections
|
||||
ce <- asks $ subscriptionEvents . config
|
||||
(conns, cts, ucs, gs, ms, sfts, rfts, pcs) <-
|
||||
if onlyNeeded
|
||||
then do
|
||||
(conns, entities) <- withStore' getConnectionsToSubscribe
|
||||
(conns, entities) <- withStore' (`getConnectionsToSubscribe` vr)
|
||||
let (cts, ucs, ms, sfts, rfts, pcs) = foldl' addEntity (M.empty, M.empty, M.empty, M.empty, M.empty, M.empty) entities
|
||||
pure (conns, cts, ucs, [], ms, sfts, rfts, pcs)
|
||||
else do
|
||||
@ -2845,7 +2854,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
|
||||
getContactConns :: m ([ConnId], Map ConnId Contact)
|
||||
getContactConns = do
|
||||
cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts
|
||||
let connIds = catMaybes $ map contactConnId (filter contactActive cts)
|
||||
let connIds = mapMaybe contactConnId (filter contactActive cts)
|
||||
pure (connIds, M.fromList $ zip connIds cts)
|
||||
getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact)
|
||||
getUserContactLinkConns = do
|
||||
@ -2854,7 +2863,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
|
||||
pure (connIds, M.fromList $ zip connIds ucs)
|
||||
getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember)
|
||||
getGroupMemberConns = do
|
||||
gs <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserGroups") getUserGroups
|
||||
gs <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserGroups") (`getUserGroups` vr)
|
||||
let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs
|
||||
pure (gs, map fst mPairs, M.fromList mPairs)
|
||||
getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer)
|
||||
@ -3029,12 +3038,13 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
|
||||
ts <- liftIO getCurrentTime
|
||||
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts
|
||||
waitChatStarted
|
||||
vr <- chatVersionRange
|
||||
case cType of
|
||||
CTDirect -> do
|
||||
(ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
deleteDirectCI user ct ci True True >>= toView
|
||||
CTGroup -> do
|
||||
(gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
|
||||
(gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId
|
||||
deletedTs <- liftIO getCurrentTime
|
||||
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
|
||||
_ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType"
|
||||
@ -3049,12 +3059,13 @@ startUpdatedTimedItemThread user chatRef ci ci' =
|
||||
expireChatItems :: forall m. ChatMonad m => User -> Int64 -> Bool -> m ()
|
||||
expireChatItems user@User {userId} ttl sync = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
vr <- chatVersionRange
|
||||
let expirationDate = addUTCTime (-1 * fromIntegral ttl) currentTs
|
||||
-- this is to keep group messages created during last 12 hours even if they're expired according to item_ts
|
||||
createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs
|
||||
contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user)
|
||||
loop contacts $ processContact expirationDate
|
||||
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db user Nothing Nothing)
|
||||
groups <- withStoreCtx' (Just "expireChatItems, getUserGroupDetails") (\db -> getUserGroupDetails db vr user Nothing Nothing)
|
||||
loop groups $ processGroup expirationDate createdAtCutoff
|
||||
where
|
||||
loop :: [a] -> (a -> m ()) -> m ()
|
||||
@ -3088,9 +3099,10 @@ processAgentMessage _ connId (DEL_RCVQ srv qId err_) =
|
||||
toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_
|
||||
processAgentMessage _ connId DEL_CONN =
|
||||
toView $ CRAgentConnDeleted (AgentConnId connId)
|
||||
processAgentMessage corrId connId msg =
|
||||
processAgentMessage corrId connId msg = do
|
||||
vr <- chatVersionRange
|
||||
withStore' (`getUserByAConnId` AgentConnId connId) >>= \case
|
||||
Just user -> processAgentMessageConn user corrId connId msg `catchChatError` (toView . CRChatError (Just user))
|
||||
Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` (toView . CRChatError (Just user))
|
||||
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
|
||||
|
||||
processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone -> m ()
|
||||
@ -3127,17 +3139,18 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
(ft@FileTransferMeta {fileId, cancelled}, sfts) <- withStore $ \db -> do
|
||||
fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId
|
||||
getSndFileTransfer db user fileId
|
||||
vr <- chatVersionRange
|
||||
unless cancelled $ case msg of
|
||||
SFPROG sndProgress sndTotal -> do
|
||||
let status = CIFSSndTransfer {sndProgress, sndTotal}
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId status
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
|
||||
SFDONE sndDescr rfds -> do
|
||||
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
|
||||
ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <-
|
||||
withStore $ \db -> getChatItemByFileId db user fileId
|
||||
withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
case (msgId_, itemDeleted) of
|
||||
(Just sharedMsgId, Nothing) -> do
|
||||
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
|
||||
@ -3157,7 +3170,7 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user))
|
||||
ci' <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
withAgent (`xftpDeleteSndFileInternal` aFileId)
|
||||
toView $ CRSndFileCompleteXFTP user ci' ft
|
||||
where
|
||||
@ -3181,7 +3194,7 @@ processAgentMsgSndFile _corrId aFileId msg =
|
||||
| otherwise -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateFileCancelled db user fileId CIFSSndError
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
withAgent (`xftpDeleteSndFileInternal` aFileId)
|
||||
toView $ CRSndFileError user ci
|
||||
where
|
||||
@ -3228,12 +3241,13 @@ processAgentMsgRcvFile _corrId aFileId msg =
|
||||
ft@RcvFileTransfer {fileId} <- withStore $ \db -> do
|
||||
fileId <- getXFTPRcvFileDBId db $ AgentRcvFileId aFileId
|
||||
getRcvFileTransfer db user fileId
|
||||
vr <- chatVersionRange
|
||||
unless (rcvFileCompleteOrCancelled ft) $ case msg of
|
||||
RFPROG rcvProgress rcvTotal -> do
|
||||
let status = CIFSRcvTransfer {rcvProgress, rcvTotal}
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId status
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal
|
||||
RFDONE xftpPath ->
|
||||
case liveRcvFileTransferPath ft of
|
||||
@ -3245,7 +3259,7 @@ processAgentMsgRcvFile _corrId aFileId msg =
|
||||
liftIO $ do
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
toView $ CRRcvFileComplete user ci
|
||||
RFERR e
|
||||
@ -3254,13 +3268,13 @@ processAgentMsgRcvFile _corrId aFileId msg =
|
||||
| otherwise -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateFileCancelled db user fileId CIFSRcvError
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
toView $ CRRcvFileError user ci e
|
||||
|
||||
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
|
||||
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus
|
||||
processAgentMessageConn :: forall m. ChatMonad m => VersionRange -> User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
|
||||
processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
|
||||
entity <- withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus
|
||||
case agentMessage of
|
||||
END -> case entity of
|
||||
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
|
||||
@ -3406,7 +3420,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
XOk -> pure ()
|
||||
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
|
||||
CON ->
|
||||
withStore' (\db -> getViaGroupMember db user ct) >>= \case
|
||||
withStore' (\db -> getViaGroupMember db vr user ct) >>= \case
|
||||
Nothing -> do
|
||||
-- [incognito] print incognito profile used for this contact
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
@ -3427,7 +3441,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
forM_ groupId_ $ \groupId -> do
|
||||
groupInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
|
||||
gVar <- asks random
|
||||
@ -3595,7 +3609,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
profileToSend = profileToSendOnAccept user profileMode
|
||||
void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId)
|
||||
sendIntroductions members = do
|
||||
intros <- withStore' $ \db -> createIntroductions db members m
|
||||
intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m
|
||||
shuffledIntros <- liftIO $ shuffleIntros intros
|
||||
if isCompatibleRange (memberChatVRange' m) batchSendVRange
|
||||
then do
|
||||
@ -3885,7 +3899,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
CON -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateSndFileStatus db ft FSConnected
|
||||
updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
|
||||
updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
|
||||
toView $ CRSndFileStart user ci ft
|
||||
sendFileChunk user ft
|
||||
SENT msgId -> do
|
||||
@ -3899,7 +3913,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
getChatRefByFileId db user fileId >>= \case
|
||||
ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
|
||||
_ -> pure ()
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
toView $ CRSndFileRcvCancelled user ci ft
|
||||
_ -> throwChatError $ CEFileSend fileId err
|
||||
MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure ()
|
||||
@ -3965,7 +3979,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
FileChunkCancel ->
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
|
||||
ci <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileSndCancelled user ci ft
|
||||
FileChunk {chunkNo, chunkBytes = chunk} -> do
|
||||
case integrity of
|
||||
@ -3988,7 +4002,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
deleteRcvFileChunks db ft
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileComplete user ci
|
||||
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
|
||||
RcvChunkDuplicate -> ack $ pure ()
|
||||
@ -4031,7 +4045,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ct <- acceptContactRequestAsync user cReq incognitoProfile True
|
||||
toView $ CRAcceptingContactRequest user ct
|
||||
Just groupId -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
if isCompatibleRange chatVRange groupLinkNoContactVRange
|
||||
then do
|
||||
@ -4524,14 +4538,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
|
||||
ci <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileSndCancelled user ci ft
|
||||
|
||||
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
|
||||
xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId
|
||||
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
assertSMPAcceptNotProhibited ci
|
||||
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
@ -4546,7 +4560,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- receiving inline
|
||||
_ -> do
|
||||
event <- withStore $ \db -> do
|
||||
ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
|
||||
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
|
||||
sft <- createSndDirectInlineFT db ct ft
|
||||
pure $ CRSndFileStart user ci' sft
|
||||
toView event
|
||||
@ -4574,7 +4588,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
|
||||
liftIO $ updateSndFileStatus db sft FSComplete
|
||||
liftIO $ deleteSndFileChunks db sft
|
||||
updateDirectCIFileStatus db user fileId CIFSSndComplete
|
||||
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
|
||||
case file of
|
||||
Just CIFile {fileProtocol = FPXFTP} -> do
|
||||
ft <- withStore $ \db -> getFileTransferMeta db user fileId
|
||||
@ -4619,7 +4633,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
|
||||
ci <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
toView $ CRRcvFileSndCancelled user ci ft
|
||||
else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id
|
||||
(SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel"
|
||||
@ -4627,7 +4641,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> m ()
|
||||
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
|
||||
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId
|
||||
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
assertSMPAcceptNotProhibited ci
|
||||
-- TODO check that it's not already accepted
|
||||
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
|
||||
@ -4643,7 +4657,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
(_, Just conn) -> do
|
||||
-- receiving inline
|
||||
event <- withStore $ \db -> do
|
||||
ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
|
||||
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
|
||||
sft <- liftIO $ createSndGroupInlineFT db m conn ft
|
||||
pure $ CRSndFileStart user ci' sft
|
||||
toView event
|
||||
@ -4667,7 +4681,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
||||
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
||||
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <- withStore $ \db -> createGroupInvitation db user ct inv customUserProfileId
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <-
|
||||
withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId
|
||||
if sameGroupLinkId groupLinkId groupLinkId'
|
||||
then do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
@ -5018,14 +5033,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
associateMemberWithContact :: Contact -> GroupMember -> m Contact
|
||||
associateMemberWithContact c1 m2@GroupMember {groupId} = do
|
||||
withStore' $ \db -> associateMemberWithContactRecord db user c1 m2
|
||||
g <- withStore $ \db -> getGroupInfo db user groupId
|
||||
g <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
toView $ CRContactAndMemberAssociated user c1 g m2 c1
|
||||
pure c1
|
||||
|
||||
associateContactWithMember :: GroupMember -> Contact -> m Contact
|
||||
associateContactWithMember m1@GroupMember {groupId} c2 = do
|
||||
c2' <- withStore $ \db -> associateContactWithMemberRecord db user m1 c2
|
||||
g <- withStore $ \db -> getGroupInfo db user groupId
|
||||
g <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
toView $ CRContactAndMemberAssociated user c2 g m1 c2'
|
||||
pure c2'
|
||||
|
||||
@ -5040,7 +5055,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
toView $ CRContactConnecting user ct
|
||||
pure conn'
|
||||
XGrpLinkInv glInv -> do
|
||||
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db user conn' glInv
|
||||
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv
|
||||
toView $ CRGroupLinkConnecting user gInfo host
|
||||
pure conn'
|
||||
-- TODO show/log error, other events in SMP confirmation
|
||||
@ -5440,14 +5455,15 @@ parseChatMessage conn s = do
|
||||
|
||||
sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m ()
|
||||
sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} =
|
||||
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
|
||||
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $ do
|
||||
vr <- chatVersionRange
|
||||
withStore' (`createSndFileChunk` ft) >>= \case
|
||||
Just chunkNo -> sendFileChunkNo ft chunkNo
|
||||
Nothing -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateSndFileStatus db ft FSComplete
|
||||
liftIO $ deleteSndFileChunks db ft
|
||||
updateDirectCIFileStatus db user fileId CIFSSndComplete
|
||||
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
|
||||
toView $ CRSndFileComplete user ci ft
|
||||
closeFileHandle fileId sndFiles
|
||||
deleteAgentConnectionAsync user acId
|
||||
@ -5612,8 +5628,8 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do
|
||||
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
|
||||
createSndMessage chatMsgEvent connOrGroupId = do
|
||||
gVar <- asks random
|
||||
ChatConfig {chatVRange} <- asks config
|
||||
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage chatVRange)
|
||||
vr <- chatVersionRange
|
||||
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage vr)
|
||||
where
|
||||
encodeMessage chatVRange sharedMsgId =
|
||||
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent}
|
||||
@ -5639,8 +5655,8 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
|
||||
createSndMessages :: m [Either ChatError SndMessage]
|
||||
createSndMessages = do
|
||||
gVar <- asks random
|
||||
ChatConfig {chatVRange} <- asks config
|
||||
withStoreBatch $ \db -> map (createMsg db gVar chatVRange) (toList events)
|
||||
vr <- chatVersionRange
|
||||
withStoreBatch $ \db -> map (createMsg db gVar vr) (toList events)
|
||||
createMsg db gVar chatVRange evnt = do
|
||||
r <- runExceptT $ createNewSndMessage db gVar (GroupId groupId) evnt (encodeMessage chatVRange evnt)
|
||||
pure $ first ChatErrorStore r
|
||||
@ -5649,7 +5665,7 @@ sendGroupMemberMessages user conn@Connection {connId} events groupId = do
|
||||
|
||||
directMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
|
||||
directMessage chatMsgEvent = do
|
||||
ChatConfig {chatVRange} <- asks config
|
||||
chatVRange <- chatVersionRange
|
||||
let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
|
||||
case r of
|
||||
ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody
|
||||
@ -6102,6 +6118,11 @@ waitChatStarted = do
|
||||
agentStarted <- asks agentAsync
|
||||
atomically $ readTVar agentStarted >>= \a -> unless (isJust a) retry
|
||||
|
||||
chatVersionRange :: ChatMonad' m => m VersionRange
|
||||
chatVersionRange = do
|
||||
ChatConfig {chatVRange} <- asks config
|
||||
pure chatVRange
|
||||
|
||||
chatCommandP :: Parser ChatCommand
|
||||
chatCommandP =
|
||||
choice
|
||||
|
||||
@ -52,9 +52,13 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstTo
|
||||
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
import Simplex.Messaging.Version hiding (version)
|
||||
|
||||
-- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig.
|
||||
-- This indirection is needed for backward/forward compatibility testing.
|
||||
-- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code.
|
||||
currentChatVersion :: Version
|
||||
currentChatVersion = 5
|
||||
|
||||
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
|
||||
supportedChatVRange :: VersionRange
|
||||
supportedChatVRange = mkVersionRange 1 currentChatVersion
|
||||
|
||||
|
||||
@ -38,7 +38,6 @@ import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Remote.Transport
|
||||
import Simplex.Chat.Remote.Types
|
||||
import Simplex.FileTransfer.Description (FileDigest (..))
|
||||
import Simplex.Messaging.Agent.Client (agentDRG)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||
import Simplex.Messaging.Crypto.Lazy (LazyByteString)
|
||||
|
||||
@ -35,9 +35,10 @@ import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
import Simplex.Messaging.Version (VersionRange)
|
||||
|
||||
getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
|
||||
getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
getConnectionEntity :: DB.Connection -> VersionRange -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
|
||||
getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
|
||||
c@Connection {connType, entityId} <- getConnection_
|
||||
case entityId of
|
||||
Nothing ->
|
||||
@ -115,7 +116,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
(groupMemberId, userId, userContactId)
|
||||
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
|
||||
toGroupAndMember c (groupInfoRow :. memberRow) =
|
||||
let groupInfo = toGroupInfo userContactId groupInfoRow
|
||||
let groupInfo = toGroupInfo vr userContactId groupInfoRow
|
||||
member = toGroupMember userContactId memberRow
|
||||
in (groupInfo, (member :: GroupMember) {activeConn = Just c})
|
||||
getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer
|
||||
@ -154,19 +155,19 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
|
||||
userContact_ _ = Left SEUserContactLinkNotFound
|
||||
|
||||
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
|
||||
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
getConnectionEntityByConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
|
||||
getConnectionEntityByConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
connId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
|
||||
|
||||
-- search connection for connection plan:
|
||||
-- multiple connections can have same via_contact_uri_hash if request was repeated;
|
||||
-- this function searches for latest connection with contact so that "known contact" plan would be chosen;
|
||||
-- deleted connections are filtered out to allow re-connecting via same contact address
|
||||
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
|
||||
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do
|
||||
getContactConnEntityByConnReqHash :: DB.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
|
||||
getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2) = do
|
||||
connId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
@ -183,14 +184,14 @@ getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) =
|
||||
)
|
||||
|]
|
||||
(userId, cReqHash1, cReqHash2, ConnDeleted)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
|
||||
|
||||
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
|
||||
getConnectionsToSubscribe db = do
|
||||
getConnectionsToSubscribe :: DB.Connection -> VersionRange -> IO ([ConnId], [ConnectionEntity])
|
||||
getConnectionsToSubscribe db vr = do
|
||||
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
|
||||
entities <- forM aConnIds $ \acId -> do
|
||||
getUserByAConnId db acId >>= \case
|
||||
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db user acId)
|
||||
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)
|
||||
Nothing -> pure Nothing
|
||||
unsetConnectionToSubscribe db
|
||||
let connIds = map (\(AgentConnId connId) -> connId) aConnIds
|
||||
|
||||
@ -107,6 +107,7 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Protocol (SubscriptionMode (..))
|
||||
import Simplex.Messaging.Version (VersionRange)
|
||||
|
||||
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
|
||||
getLiveSndFileTransfers db User {userId} = do
|
||||
@ -677,8 +678,8 @@ getRcvFileTransfer_ db userId fileId = do
|
||||
_ -> pure Nothing
|
||||
cancelled = fromMaybe False cancelled_
|
||||
|
||||
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem
|
||||
acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
|
||||
acceptRcvFileTransfer :: DB.Connection -> VersionRange -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem
|
||||
acceptRcvFileTransfer db vr user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
|
||||
currentTs <- getCurrentTime
|
||||
acceptRcvFT_ db user fileId filePath Nothing currentTs
|
||||
DB.execute
|
||||
@ -687,7 +688,7 @@ acceptRcvFileTransfer db user@User {userId} fileId (cmdId, acId) connStatus file
|
||||
(acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs, subMode == SMOnlyCreate)
|
||||
connId <- insertedRowId db
|
||||
setCommandConnId db user cmdId connId
|
||||
runExceptT $ getChatItemByFileId db user fileId
|
||||
runExceptT $ getChatItemByFileId db vr user fileId
|
||||
|
||||
getContactByFileId :: DB.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact
|
||||
getContactByFileId db user@User {userId} fileId = do
|
||||
@ -698,19 +699,19 @@ getContactByFileId db user@User {userId} fileId = do
|
||||
ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $
|
||||
DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, fileId)
|
||||
|
||||
acceptRcvInlineFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
|
||||
acceptRcvInlineFT db user fileId filePath = do
|
||||
acceptRcvInlineFT :: DB.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
|
||||
acceptRcvInlineFT db vr user fileId filePath = do
|
||||
liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
|
||||
startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO ()
|
||||
startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
|
||||
acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime
|
||||
|
||||
xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
|
||||
xftpAcceptRcvFT db user fileId filePath = do
|
||||
xftpAcceptRcvFT :: DB.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
|
||||
xftpAcceptRcvFT db vr user fileId filePath = do
|
||||
liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime
|
||||
getChatItemByFileId db user fileId
|
||||
getChatItemByFileId db vr user fileId
|
||||
|
||||
acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO ()
|
||||
acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do
|
||||
@ -930,9 +931,9 @@ getLocalCryptoFile db userId fileId sent =
|
||||
FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId
|
||||
pure $ CryptoFile filePath $ xftpSndFile >>= \f -> f.cryptoArgs
|
||||
|
||||
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
|
||||
updateDirectCIFileStatus db user fileId fileStatus = do
|
||||
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId
|
||||
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRange -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
|
||||
updateDirectCIFileStatus db vr user fileId fileStatus = do
|
||||
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db vr user fileId
|
||||
case (cType, testEquality d $ msgDirection @d) of
|
||||
(SCTDirect, Just Refl) -> do
|
||||
liftIO $ updateCIFileStatus db user fileId fileStatus
|
||||
|
||||
@ -128,7 +128,7 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), (:.) (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Protocol (currentChatVersion, groupForwardVRange, supportedChatVRange)
|
||||
import Simplex.Chat.Protocol (groupForwardVRange)
|
||||
import Simplex.Chat.Store.Direct
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
@ -148,9 +148,9 @@ type GroupMemberRow = ((Int64, Int64, MemberId, Version, Version, GroupMemberRol
|
||||
|
||||
type MaybeGroupMemberRow = ((Maybe Int64, Maybe Int64, Maybe MemberId, Maybe Version, Maybe Version, Maybe GroupMemberRole, Maybe GroupMemberCategory, Maybe GroupMemberStatus, Maybe Bool) :. (Maybe Int64, Maybe GroupMemberId, Maybe ContactName, Maybe ContactId, Maybe ProfileId, Maybe ProfileId, Maybe ContactName, Maybe Text, Maybe ImageData, Maybe ConnReqContact, Maybe LocalAlias, Maybe Preferences))
|
||||
|
||||
toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo
|
||||
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
|
||||
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange supportedChatVRange}
|
||||
toGroupInfo :: VersionRange -> Int64 -> GroupInfoRow -> GroupInfo
|
||||
toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) =
|
||||
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange vr}
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}
|
||||
@ -252,8 +252,8 @@ setGroupLinkMemberRole :: DB.Connection -> User -> Int64 -> GroupMemberRole -> I
|
||||
setGroupLinkMemberRole db User {userId} userContactLinkId memberRole =
|
||||
DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId)
|
||||
|
||||
getGroupAndMember :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
getGroupAndMember db User {userId, userContactId} groupMemberId =
|
||||
getGroupAndMember :: DB.Connection -> User -> Int64 -> VersionRange -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
getGroupAndMember db User {userId, userContactId} groupMemberId vr =
|
||||
ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
|
||||
DB.query
|
||||
db
|
||||
@ -289,13 +289,13 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
|
||||
where
|
||||
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
|
||||
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
|
||||
let groupInfo = toGroupInfo userContactId groupInfoRow
|
||||
let groupInfo = toGroupInfo vr userContactId groupInfoRow
|
||||
member = toGroupMember userContactId memberRow
|
||||
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
|
||||
|
||||
-- | creates completely new group with a single member - the current user
|
||||
createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo
|
||||
createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do
|
||||
createNewGroup :: DB.Connection -> VersionRange -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo
|
||||
createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do
|
||||
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
currentTs <- getCurrentTime
|
||||
@ -313,18 +313,18 @@ createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = Except
|
||||
(ldn, userId, profileId, True, currentTs, currentTs, currentTs)
|
||||
insertedRowId db
|
||||
memberId <- liftIO $ encodedRandomBytes gVar 12
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser customUserProfileId currentTs supportedChatVRange
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser customUserProfileId currentTs vr
|
||||
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
|
||||
pure GroupInfo {groupId, localDisplayName = ldn, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = Nothing, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}
|
||||
|
||||
-- | creates a new group record for the group the current user was invited to, or returns an existing one
|
||||
createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
|
||||
createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
|
||||
createGroupInvitation :: DB.Connection -> VersionRange -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
|
||||
createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
|
||||
liftIO getInvitationGroupId_ >>= \case
|
||||
Nothing -> createGroupInvitation_
|
||||
Just gId -> do
|
||||
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db user gId
|
||||
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db vr user gId
|
||||
hostId <- getHostMemberId_ db user gId
|
||||
let GroupMember {groupMemberId, memberId, memberRole} = membership
|
||||
MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember
|
||||
@ -360,7 +360,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
|
||||
insertedRowId db
|
||||
let JVersionRange hostVRange = hostConn.peerChatVRange
|
||||
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs hostVRange
|
||||
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs supportedChatVRange
|
||||
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId currentTs vr
|
||||
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
|
||||
pure (GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId = customUserProfileId, chatSettings, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs}, groupMemberId)
|
||||
|
||||
@ -431,9 +431,10 @@ createContactMemberInv_ db User {userId, userContactId} groupId invitedByGroupMe
|
||||
)
|
||||
pure $ Right incognitoLdn
|
||||
|
||||
createGroupInvitedViaLink :: DB.Connection -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupInvitedViaLink :: DB.Connection -> VersionRange -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupInvitedViaLink
|
||||
db
|
||||
vr
|
||||
user@User {userId, userContactId}
|
||||
Connection {connId, customUserProfileId}
|
||||
GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile} = do
|
||||
@ -442,9 +443,9 @@ createGroupInvitedViaLink
|
||||
hostMemberId <- insertHost_ currentTs groupId
|
||||
liftIO $ DB.execute db "UPDATE connections SET conn_type = ?, group_member_id = ?, updated_at = ? WHERE connection_id = ?" (ConnMember, hostMemberId, currentTs, connId)
|
||||
-- using IBUnknown since host is created without contact
|
||||
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs supportedChatVRange
|
||||
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember GSMemAccepted IBUnknown customUserProfileId currentTs vr
|
||||
liftIO $ setViaGroupLinkHash db groupId connId
|
||||
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId
|
||||
(,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db user hostMemberId
|
||||
where
|
||||
insertGroup_ currentTs = ExceptT $ do
|
||||
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
|
||||
@ -497,9 +498,9 @@ setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
|
||||
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group
|
||||
getGroup db user groupId = do
|
||||
gInfo <- getGroupInfo db user groupId
|
||||
getGroup :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO Group
|
||||
getGroup db vr user groupId = do
|
||||
gInfo <- getGroupInfo db vr user groupId
|
||||
members <- liftIO $ getGroupMembers db user gInfo
|
||||
pure $ Group gInfo members
|
||||
|
||||
@ -552,14 +553,14 @@ deleteGroupProfile_ db userId groupId =
|
||||
|]
|
||||
(userId, groupId)
|
||||
|
||||
getUserGroups :: DB.Connection -> User -> IO [Group]
|
||||
getUserGroups db user@User {userId} = do
|
||||
getUserGroups :: DB.Connection -> VersionRange -> User -> IO [Group]
|
||||
getUserGroups db vr user@User {userId} = do
|
||||
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId)
|
||||
rights <$> mapM (runExceptT . getGroup db user) groupIds
|
||||
rights <$> mapM (runExceptT . getGroup db vr user) groupIds
|
||||
|
||||
getUserGroupDetails :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
|
||||
getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
|
||||
map (toGroupInfo userContactId)
|
||||
getUserGroupDetails :: DB.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
|
||||
getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ =
|
||||
map (toGroupInfo vr userContactId)
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
@ -577,9 +578,9 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
|
||||
where
|
||||
search = fromMaybe "" search_
|
||||
|
||||
getUserGroupsWithSummary :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
|
||||
getUserGroupsWithSummary db user _contactId_ search_ =
|
||||
getUserGroupDetails db user _contactId_ search_
|
||||
getUserGroupsWithSummary :: DB.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
|
||||
getUserGroupsWithSummary db vr user _contactId_ search_ =
|
||||
getUserGroupDetails db vr user _contactId_ search_
|
||||
>>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId)
|
||||
|
||||
-- the statuses on non-current members should match memberCurrent' function
|
||||
@ -620,10 +621,10 @@ checkContactHasGroups :: DB.Connection -> User -> Contact -> IO (Maybe GroupId)
|
||||
checkContactHasGroups db User {userId} Contact {contactId} =
|
||||
maybeFirstRow fromOnly $ DB.query db "SELECT group_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId)
|
||||
|
||||
getGroupInfoByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfoByName db user gName = do
|
||||
getGroupInfoByName :: DB.Connection -> VersionRange -> User -> GroupName -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfoByName db vr user gName = do
|
||||
gId <- getGroupIdByName db user gName
|
||||
getGroupInfo db user gId
|
||||
getGroupInfo db vr user gId
|
||||
|
||||
groupMemberQuery :: Query
|
||||
groupMemberQuery =
|
||||
@ -709,11 +710,11 @@ getGroupCurrentMembersCount db User {userId} GroupInfo {groupId} = do
|
||||
(groupId, userId)
|
||||
pure $ length $ filter memberCurrent' statuses
|
||||
|
||||
getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
|
||||
getGroupInvitation db user groupId =
|
||||
getGroupInvitation :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
|
||||
getGroupInvitation db vr user groupId =
|
||||
getConnRec_ user >>= \case
|
||||
Just connRequest -> do
|
||||
groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId
|
||||
groupInfo@GroupInfo {membership} <- getGroupInfo db vr user groupId
|
||||
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
|
||||
hostId <- getHostMemberId_ db user groupId
|
||||
fromMember <- getGroupMember db user groupId hostId
|
||||
@ -1005,8 +1006,8 @@ updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole
|
||||
updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole =
|
||||
DB.execute db "UPDATE group_members SET member_role = ? WHERE user_id = ? AND group_member_id = ?" (memRole, userId, groupMemberId)
|
||||
|
||||
createIntroductions :: DB.Connection -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
|
||||
createIntroductions db members toMember = do
|
||||
createIntroductions :: DB.Connection -> Version -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
|
||||
createIntroductions db chatV members toMember = do
|
||||
let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members
|
||||
if null reMembers
|
||||
then pure []
|
||||
@ -1023,7 +1024,7 @@ createIntroductions db members toMember = do
|
||||
(re_group_member_id, to_group_member_id, intro_status, intro_chat_protocol_version, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?)
|
||||
|]
|
||||
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, currentChatVersion, ts, ts)
|
||||
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, chatV, ts, ts)
|
||||
introId <- insertedRowId db
|
||||
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing}
|
||||
|
||||
@ -1201,8 +1202,8 @@ createIntroToMemberContact db user@User {userId} GroupMember {memberContactId =
|
||||
createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> VersionRange -> Maybe Int64 -> Int -> UTCTime -> SubscriptionMode -> IO Connection
|
||||
createMemberConnection_ db userId groupMemberId agentConnId peerChatVRange viaContact = createConnection_ db userId ConnMember (Just groupMemberId) agentConnId peerChatVRange viaContact Nothing Nothing
|
||||
|
||||
getViaGroupMember :: DB.Connection -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
|
||||
getViaGroupMember db User {userId, userContactId} Contact {contactId} =
|
||||
getViaGroupMember :: DB.Connection -> VersionRange -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
|
||||
getViaGroupMember db vr User {userId, userContactId} Contact {contactId} =
|
||||
maybeFirstRow toGroupAndMember $
|
||||
DB.query
|
||||
db
|
||||
@ -1239,7 +1240,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
|
||||
where
|
||||
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
|
||||
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
|
||||
let groupInfo = toGroupInfo userContactId groupInfoRow
|
||||
let groupInfo = toGroupInfo vr userContactId groupInfoRow
|
||||
member = toGroupMember userContactId memberRow
|
||||
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
|
||||
|
||||
@ -1294,9 +1295,9 @@ updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, grou
|
||||
(ldn, currentTs, userId, groupId)
|
||||
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
|
||||
|
||||
getGroupInfo :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfo db User {userId, userContactId} groupId =
|
||||
ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $
|
||||
getGroupInfo :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfo db vr User {userId, userContactId} groupId =
|
||||
ExceptT . firstRow (toGroupInfo vr userContactId) (SEGroupNotFound groupId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@ -1315,8 +1316,8 @@ getGroupInfo db User {userId, userContactId} groupId =
|
||||
|]
|
||||
(groupId, userId, userContactId)
|
||||
|
||||
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
groupId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
@ -1327,10 +1328,10 @@ getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSch
|
||||
WHERE user_id = ? AND conn_req_contact IN (?,?)
|
||||
|]
|
||||
(userId, cReqSchema1, cReqSchema2)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
|
||||
|
||||
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
|
||||
getGroupInfoByGroupLinkHash :: DB.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
|
||||
groupId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
@ -1344,7 +1345,7 @@ getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
|
||||
|
||||
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
|
||||
getGroupIdByName db User {userId} gName =
|
||||
@ -1356,8 +1357,8 @@ getGroupMemberIdByName db User {userId} groupId groupMemberName =
|
||||
ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $
|
||||
DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName)
|
||||
|
||||
getActiveMembersByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
|
||||
getActiveMembersByName db user@User {userId} groupMemberName = do
|
||||
getActiveMembersByName :: DB.Connection -> VersionRange -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
|
||||
getActiveMembersByName db vr user@User {userId} groupMemberName = do
|
||||
groupMemberIds :: [(GroupId, GroupMemberId)] <-
|
||||
liftIO $
|
||||
DB.query
|
||||
@ -1370,7 +1371,7 @@ getActiveMembersByName db user@User {userId} groupMemberName = do
|
||||
|]
|
||||
(userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember)
|
||||
possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do
|
||||
groupInfo <- getGroupInfo db user groupId
|
||||
groupInfo <- getGroupInfo db vr user groupId
|
||||
groupMember <- getGroupMember db user groupId groupMemberId
|
||||
pure (groupInfo, groupMember)
|
||||
pure $ sortOn (Down . ts . fst) possibleMembers
|
||||
@ -1827,15 +1828,15 @@ createMemberContact
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
|
||||
pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False}
|
||||
|
||||
getMemberContact :: DB.Connection -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
|
||||
getMemberContact db user contactId = do
|
||||
getMemberContact :: DB.Connection -> VersionRange -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
|
||||
getMemberContact db vr user contactId = do
|
||||
ct <- getContact db user contactId
|
||||
let Contact {contactGroupMemberId, activeConn} = ct
|
||||
case (activeConn, contactGroupMemberId) of
|
||||
(Just Connection {connId}, Just groupMemberId) -> do
|
||||
cReq <- getConnReqInv db connId
|
||||
m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId
|
||||
g <- getGroupInfo db user groupId
|
||||
g <- getGroupInfo db vr user groupId
|
||||
pure (g, m, ct, cReq)
|
||||
_ ->
|
||||
throwError $ SEMemberContactGroupMemberNotFound contactId
|
||||
|
||||
@ -134,6 +134,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
import Simplex.Messaging.Version (VersionRange)
|
||||
import UnliftIO.STM
|
||||
|
||||
deleteContactCIs :: DB.Connection -> User -> Contact -> IO ()
|
||||
@ -461,8 +462,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
|
||||
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
|
||||
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
|
||||
|
||||
getChatPreviews :: DB.Connection -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
|
||||
getChatPreviews db user withPCC pagination query = do
|
||||
getChatPreviews :: DB.Connection -> VersionRange -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
|
||||
getChatPreviews db vr user withPCC pagination query = do
|
||||
directChats <- findDirectChatPreviews_ db user pagination query
|
||||
groupChats <- findGroupChatPreviews_ db user pagination query
|
||||
cReqChats <- getContactRequestChatPreviews_ db user pagination query
|
||||
@ -483,7 +484,7 @@ getChatPreviews db user withPCC pagination query = do
|
||||
getChatPreview :: AChatPreviewData -> ExceptT StoreError IO AChat
|
||||
getChatPreview (ACPD cType cpd) = case cType of
|
||||
SCTDirect -> getDirectChatPreview_ db user cpd
|
||||
SCTGroup -> getGroupChatPreview_ db user cpd
|
||||
SCTGroup -> getGroupChatPreview_ db vr user cpd
|
||||
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
|
||||
SCTContactConnection -> let (ContactConnectionPD _ chat) = cpd in pure chat
|
||||
|
||||
@ -688,9 +689,9 @@ findGroupChatPreviews_ db User {userId} pagination clq =
|
||||
)
|
||||
([":user_id" := userId, ":rcv_new" := CISRcvNew, ":search" := search] <> pagParams)
|
||||
|
||||
getGroupChatPreview_ :: DB.Connection -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
|
||||
getGroupChatPreview_ db user (GroupChatPD _ groupId lastItemId_ stats) = do
|
||||
groupInfo <- getGroupInfo db user groupId
|
||||
getGroupChatPreview_ :: DB.Connection -> VersionRange -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
|
||||
getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
|
||||
groupInfo <- getGroupInfo db vr user groupId
|
||||
lastItem <- case lastItemId_ of
|
||||
Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId
|
||||
Nothing -> pure []
|
||||
@ -874,10 +875,10 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
|
||||
|]
|
||||
(userId, contactId, search, beforeChatItemId, count)
|
||||
|
||||
getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
|
||||
getGroupChat db user groupId pagination search_ = do
|
||||
getGroupChat :: DB.Connection -> VersionRange -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
|
||||
getGroupChat db vr user groupId pagination search_ = do
|
||||
let search = fromMaybe "" search_
|
||||
g <- getGroupInfo db user groupId
|
||||
g <- getGroupInfo db vr user groupId
|
||||
case pagination of
|
||||
CPLast count -> getGroupChatLast_ db user g count search
|
||||
CPAfter afterId count -> getGroupChatAfter_ db user g afterId count search
|
||||
@ -1185,19 +1186,19 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir,
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
|
||||
getAllChatItems db user@User {userId} pagination search_ = do
|
||||
getAllChatItems :: DB.Connection -> VersionRange -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
|
||||
getAllChatItems db vr user@User {userId} pagination search_ = do
|
||||
itemRefs <-
|
||||
rights . map toChatItemRef <$> case pagination of
|
||||
CPLast count -> liftIO $ getAllChatItemsLast_ count
|
||||
CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId
|
||||
CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId
|
||||
mapM (uncurry (getAChatItem db user) >=> liftIO . getACIReactions db) itemRefs
|
||||
mapM (uncurry (getAChatItem db vr user) >=> liftIO . getACIReactions db) itemRefs
|
||||
where
|
||||
search = fromMaybe "" search_
|
||||
getAChatItem_ itemId = do
|
||||
chatRef <- getChatRefViaItemId db user itemId
|
||||
getAChatItem db user chatRef itemId
|
||||
getAChatItem db vr user chatRef itemId
|
||||
getAllChatItemsLast_ count =
|
||||
reverse
|
||||
<$> DB.query
|
||||
@ -1713,8 +1714,8 @@ getGroupChatItemIdByText' db User {userId} groupId msg =
|
||||
|]
|
||||
(userId, groupId, msg <> "%")
|
||||
|
||||
getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByFileId db user@User {userId} fileId = do
|
||||
getChatItemByFileId :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByFileId db vr user@User {userId} fileId = do
|
||||
(chatRef, itemId) <-
|
||||
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $
|
||||
DB.query
|
||||
@ -1727,10 +1728,10 @@ getChatItemByFileId db user@User {userId} fileId = do
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, fileId)
|
||||
getAChatItem db user chatRef itemId
|
||||
getAChatItem db vr user chatRef itemId
|
||||
|
||||
getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByGroupId db user@User {userId} groupId = do
|
||||
getChatItemByGroupId :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByGroupId db vr user@User {userId} groupId = do
|
||||
(chatRef, itemId) <-
|
||||
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $
|
||||
DB.query
|
||||
@ -1743,7 +1744,7 @@ getChatItemByGroupId db user@User {userId} groupId = do
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupId)
|
||||
getAChatItem db user chatRef itemId
|
||||
getAChatItem db vr user chatRef itemId
|
||||
|
||||
getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef
|
||||
getChatRefViaItemId db User {userId} itemId = do
|
||||
@ -1755,14 +1756,14 @@ getChatRefViaItemId db User {userId} itemId = do
|
||||
(Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId
|
||||
(_, _) -> Left $ SEBadChatItem itemId
|
||||
|
||||
getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
|
||||
getAChatItem db user chatRef itemId = case chatRef of
|
||||
getAChatItem :: DB.Connection -> VersionRange -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
|
||||
getAChatItem db vr user chatRef itemId = case chatRef of
|
||||
ChatRef CTDirect contactId -> do
|
||||
ct <- getContact db user contactId
|
||||
(CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId
|
||||
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
|
||||
ChatRef CTGroup groupId -> do
|
||||
gInfo <- getGroupInfo db user groupId
|
||||
gInfo <- getGroupInfo db vr user groupId
|
||||
(CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId
|
||||
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci
|
||||
_ -> throwError $ SEChatItemNotFound itemId
|
||||
|
||||
@ -128,16 +128,43 @@ testCfg =
|
||||
xftpFileConfig = Nothing
|
||||
}
|
||||
|
||||
testAgentCfgVPrev :: AgentConfig
|
||||
testAgentCfgVPrev =
|
||||
testAgentCfg
|
||||
{ smpAgentVRange = prevRange $ smpAgentVRange testAgentCfg,
|
||||
smpClientVRange = prevRange $ smpClientVRange testAgentCfg,
|
||||
e2eEncryptVRange = prevRange $ e2eEncryptVRange testAgentCfg,
|
||||
smpCfg = (smpCfg testAgentCfg) {serverVRange = prevRange $ serverVRange $ smpCfg testAgentCfg}
|
||||
}
|
||||
|
||||
testAgentCfgV1 :: AgentConfig
|
||||
testAgentCfgV1 =
|
||||
testAgentCfg
|
||||
{ smpClientVRange = mkVersionRange 1 1,
|
||||
smpAgentVRange = mkVersionRange 1 1,
|
||||
smpCfg = (smpCfg testAgentCfg) {serverVRange = mkVersionRange 1 1}
|
||||
{ smpClientVRange = v1Range,
|
||||
smpAgentVRange = v1Range,
|
||||
e2eEncryptVRange = v1Range,
|
||||
smpCfg = (smpCfg testAgentCfg) {serverVRange = v1Range}
|
||||
}
|
||||
|
||||
testCfgVPrev :: ChatConfig
|
||||
testCfgVPrev =
|
||||
testCfg
|
||||
{ chatVRange = prevRange $ chatVRange testCfg,
|
||||
agentConfig = testAgentCfgVPrev
|
||||
}
|
||||
|
||||
testCfgV1 :: ChatConfig
|
||||
testCfgV1 = testCfg {agentConfig = testAgentCfgV1}
|
||||
testCfgV1 =
|
||||
testCfg
|
||||
{ chatVRange = v1Range,
|
||||
agentConfig = testAgentCfgV1
|
||||
}
|
||||
|
||||
prevRange :: VersionRange -> VersionRange
|
||||
prevRange vr = vr {maxVersion = maxVersion vr - 1}
|
||||
|
||||
v1Range :: VersionRange
|
||||
v1Range = mkVersionRange 1 1
|
||||
|
||||
testCfgCreateGroupDirect :: ChatConfig
|
||||
testCfgCreateGroupDirect =
|
||||
|
||||
@ -24,8 +24,9 @@ import Test.Hspec
|
||||
chatGroupTests :: SpecWith FilePath
|
||||
chatGroupTests = do
|
||||
describe "chat groups" $ do
|
||||
it "add contacts, create group and send/receive messages" testGroup
|
||||
it "add contacts, create group and send/receive messages, check messages" testGroupCheckMessages
|
||||
describe "add contacts, create group and send/receive messages" testGroupMatrix
|
||||
it "v1: add contacts, create group and send/receive messages" testGroup
|
||||
it "v1: add contacts, create group and send/receive messages, check messages" testGroupCheckMessages
|
||||
it "create group with incognito membership" testNewGroupIncognito
|
||||
it "create and join group with 4 members" testGroup2
|
||||
it "create and delete group" testGroupDelete
|
||||
@ -146,15 +147,19 @@ chatGroupTests = do
|
||||
testGroup :: HasCallStack => FilePath -> IO ()
|
||||
testGroup =
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> testGroupShared alice bob cath False
|
||||
\alice bob cath -> testGroupShared alice bob cath False True
|
||||
|
||||
testGroupCheckMessages :: HasCallStack => FilePath -> IO ()
|
||||
testGroupCheckMessages =
|
||||
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> testGroupShared alice bob cath True
|
||||
\alice bob cath -> testGroupShared alice bob cath True True
|
||||
|
||||
testGroupShared :: HasCallStack => TestCC -> TestCC -> TestCC -> Bool -> IO ()
|
||||
testGroupShared alice bob cath checkMessages = do
|
||||
testGroupMatrix :: SpecWith FilePath
|
||||
testGroupMatrix =
|
||||
versionTestMatrix3 $ \alice bob cath -> testGroupShared alice bob cath False False
|
||||
|
||||
testGroupShared :: HasCallStack => TestCC -> TestCC -> TestCC -> Bool -> Bool -> IO ()
|
||||
testGroupShared alice bob cath checkMessages directConnections = do
|
||||
connectUsers alice bob
|
||||
connectUsers alice cath
|
||||
alice ##> "/g team"
|
||||
@ -206,6 +211,7 @@ testGroupShared alice bob cath checkMessages = do
|
||||
(alice <# "#team cath> hey team")
|
||||
(bob <# "#team cath> hey team")
|
||||
msgItem2 <- lastItemId alice
|
||||
when directConnections $
|
||||
bob <##> cath
|
||||
when checkMessages $ getReadChats msgItem1 msgItem2
|
||||
-- list groups
|
||||
@ -263,17 +269,34 @@ testGroupShared alice bob cath checkMessages = do
|
||||
(cath </)
|
||||
cath ##> "#team hello"
|
||||
cath <## "you are no longer a member of the group"
|
||||
when directConnections $
|
||||
bob <##> cath
|
||||
-- delete contact
|
||||
alice ##> "/d bob"
|
||||
alice <## "bob: contact is deleted"
|
||||
bob <## "alice (Alice) deleted contact with you"
|
||||
alice `send` "@bob hey"
|
||||
if directConnections
|
||||
then
|
||||
alice
|
||||
<### [ "@bob hey",
|
||||
"member #team bob does not have direct connection, creating",
|
||||
"peer chat protocol version range incompatible"
|
||||
]
|
||||
else do
|
||||
alice
|
||||
<### [ WithTime "@bob hey",
|
||||
"member #team bob does not have direct connection, creating",
|
||||
"contact for member #team bob is created",
|
||||
"sent invitation to connect directly to member #team bob",
|
||||
"bob (Bob): contact is connected"
|
||||
]
|
||||
bob
|
||||
<### [ "#team alice is creating direct contact alice with you",
|
||||
WithTime "alice> hey",
|
||||
"alice: security code changed",
|
||||
"alice (Alice): contact is connected"
|
||||
]
|
||||
when checkMessages $ threadDelay 1000000
|
||||
alice #> "#team checking connection"
|
||||
bob <# "#team alice> checking connection"
|
||||
|
||||
@ -69,20 +69,22 @@ ifCI xrun run d t = do
|
||||
|
||||
versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
||||
versionTestMatrix2 runTest = do
|
||||
it "v2" $ testChat2 aliceProfile bobProfile runTest
|
||||
it "current" $ testChat2 aliceProfile bobProfile runTest
|
||||
it "prev" $ testChatCfg2 testCfgVPrev aliceProfile bobProfile runTest
|
||||
it "prev to curr" $ runTestCfg2 testCfg testCfgVPrev runTest
|
||||
it "curr to prev" $ runTestCfg2 testCfgVPrev testCfg runTest
|
||||
it "v1" $ testChatCfg2 testCfgV1 aliceProfile bobProfile runTest
|
||||
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
|
||||
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
|
||||
|
||||
-- versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
||||
-- versionTestMatrix3 runTest = do
|
||||
-- it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
|
||||
|
||||
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest
|
||||
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest
|
||||
-- it "v2+v1 to v2" $ runTestCfg3 testCfg testCfg testCfgV1 runTest
|
||||
-- it "v2 to v1" $ runTestCfg3 testCfgV1 testCfg testCfg runTest
|
||||
-- it "v2+v1 to v1" $ runTestCfg3 testCfgV1 testCfg testCfgV1 runTest
|
||||
versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
|
||||
versionTestMatrix3 runTest = do
|
||||
it "current" $ testChat3 aliceProfile bobProfile cathProfile runTest
|
||||
it "prev" $ testChatCfg3 testCfgVPrev aliceProfile bobProfile cathProfile runTest
|
||||
it "prev to curr" $ runTestCfg3 testCfg testCfgVPrev testCfgVPrev runTest
|
||||
it "curr+prev to curr" $ runTestCfg3 testCfg testCfg testCfgVPrev runTest
|
||||
it "curr to prev" $ runTestCfg3 testCfgVPrev testCfg testCfg runTest
|
||||
it "curr+prev to prev" $ runTestCfg3 testCfgVPrev testCfg testCfgVPrev runTest
|
||||
|
||||
inlineCfg :: Integer -> ChatConfig
|
||||
inlineCfg n = testCfg {inlineFiles = defaultInlineFilesConfig {sendChunks = 0, offerChunks = n, receiveChunks = n}}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user