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

core: use version from config, add tests (#3588)

Browse Source 
* core: use version from config, add tests

* comment

* refactor
This commit is contained in:
Evgeny Poberezkin 2023-12-24 13:27:51 +00:00 committed by GitHub
parent 5a6670998c
commit af22348bf8
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 348 additions and 268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

295
src/Simplex/Chat.hs
View File

@ -276,28 +276,28 @@ newChatController
logFilePath = logFile, logFilePath = logFile,
contactMergeEnabled contactMergeEnabled
} }
where where
configServers :: DefaultAgentServers configServers :: DefaultAgentServers
configServers = configServers =
let smp' = fromMaybe (defaultServers.smp) (nonEmpty smpServers) let smp' = fromMaybe (defaultServers.smp) (nonEmpty smpServers)
xftp' = fromMaybe (defaultServers.xftp) (nonEmpty xftpServers) xftp' = fromMaybe (defaultServers.xftp) (nonEmpty xftpServers)
in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig} in defaultServers {smp = smp', xftp = xftp', netCfg = networkConfig}
agentServers :: ChatConfig -> IO InitialAgentServers agentServers :: ChatConfig -> IO InitialAgentServers
agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do agentServers config@ChatConfig {defaultServers = defServers@DefaultAgentServers {ntf, netCfg}} = do
users <- withTransaction chatStore getUsers users <- withTransaction chatStore getUsers
smp' <- getUserServers users SPSMP smp' <- getUserServers users SPSMP
xftp' <- getUserServers users SPXFTP xftp' <- getUserServers users SPXFTP
pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg} pure InitialAgentServers {smp = smp', xftp = xftp', ntf, netCfg}
where where
getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p))) getUserServers :: forall p. (ProtocolTypeI p, UserProtocol p) => [User] -> SProtocolType p -> IO (Map UserId (NonEmpty (ProtoServerWithAuth p)))
getUserServers users protocol = case users of getUserServers users protocol = case users of
[] -> pure $ M.fromList [(1, cfgServers protocol defServers)] [] -> pure $ M.fromList [(1, cfgServers protocol defServers)]
_ -> M.fromList <$> initialServers _ -> M.fromList <$> initialServers
where where
initialServers :: IO [(UserId, NonEmpty (ProtoServerWithAuth p))] initialServers :: IO [(UserId, NonEmpty (ProtoServerWithAuth p))]
initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users initialServers = mapM (\u -> (aUserId u,) <$> userServers u) users
userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p)) userServers :: User -> IO (NonEmpty (ProtoServerWithAuth p))
userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user') userServers user' = activeAgentServers config protocol <$> withTransaction chatStore (`getProtocolServers` user')
activeAgentServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ProtoServerWithAuth p) activeAgentServers :: UserProtocol p => ChatConfig -> SProtocolType p -> [ServerCfg p] -> NonEmpty (ProtoServerWithAuth p)
activeAgentServers ChatConfig {defaultServers} p = activeAgentServers ChatConfig {defaultServers} p =
@ -356,11 +356,12 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m () subscribeUsers :: forall m. ChatMonad' m => Bool -> [User] -> m ()
subscribeUsers onlyNeeded users = do subscribeUsers onlyNeeded users = do
let (us, us') = partition activeUser users let (us, us') = partition activeUser users
subscribe us vr <- chatVersionRange
subscribe us' subscribe vr us
subscribe vr us'
where where
subscribe :: [User] -> m () subscribe :: VersionRange -> [User] -> m ()
subscribe = mapM_ $ runExceptT . subscribeUserConnections onlyNeeded Agent.subscribeConnections subscribe vr = mapM_ $ runExceptT . subscribeUserConnections vr onlyNeeded Agent.subscribeConnections
startFilesToReceive :: forall m. ChatMonad' m => [User] -> m () startFilesToReceive :: forall m. ChatMonad' m => [User] -> m ()
startFilesToReceive users = do startFilesToReceive users = do
@ -437,7 +438,11 @@ parseChatCommand = A.parseOnly chatCommandP . B.dropWhileEnd isSpace
-- | Chat API commands interpreted in context of a local zone -- | Chat API commands interpreted in context of a local zone
processChatCommand :: forall m. ChatMonad m => ChatCommand -> m ChatResponse 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 ShowActiveUser -> withUser' $ pure . CRActiveUser
CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do CreateActiveUser NewUser {profile, sameServers, pastTimestamp} -> do
forM_ profile $ \Profile {displayName} -> checkValidName displayName forM_ profile $ \Profile {displayName} -> checkValidName displayName
@ -607,7 +612,7 @@ processChatCommand = \case
. M.assocs . M.assocs
<$> withConnection st (readTVarIO . DB.slow) <$> withConnection st (readTVarIO . DB.slow)
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do 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) unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRApiChats user previews pure $ CRApiChats user previews
APIGetChat (ChatRef cType cId) pagination search -> withUser $ \user -> case cType of 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) directChat <- withStore (\db -> getDirectChat db user cId pagination search)
pure $ CRApiChat user (AChat SCTDirect directChat) pure $ CRApiChat user (AChat SCTDirect directChat)
CTGroup -> do 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) pure $ CRApiChat user (AChat SCTGroup groupChat)
CTContactRequest -> pure $ chatCmdError (Just user) "not implemented" CTContactRequest -> pure $ chatCmdError (Just user) "not implemented"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIGetChatItems pagination search -> withUser $ \user -> do 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 pure $ CRChatItems user Nothing chatItems
APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do
(aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db -> (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 let itemVersions = if null versions then maybeToList $ mkItemVersion ci else versions
memberDeliveryStatuses <- case (cType, dir) of memberDeliveryStatuses <- case (cType, dir) of
(SCTGroup, SMDSnd) -> do (SCTGroup, SMDSnd) -> do
@ -699,7 +704,7 @@ processChatCommand = \case
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwChatError CEInvalidQuote quoteData _ = throwChatError CEInvalidQuote
CTGroup -> do CTGroup -> do
g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId g@(Group gInfo _) <- withStore $ \db -> getGroup db vr user chatId
assertUserGroupRole gInfo GRAuthor assertUserGroupRole gInfo GRAuthor
send g send g
where where
@ -804,7 +809,7 @@ processChatCommand = \case
_ -> throwChatError CEInvalidChatItemUpdate _ -> throwChatError CEInvalidChatItemUpdate
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
CTGroup -> do 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 assertUserGroupRole gInfo GRAuthor
cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId cci <- withStore $ \db -> getGroupCIWithReactions db user gInfo itemId
case cci of case cci of
@ -840,7 +845,7 @@ processChatCommand = \case
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
CTGroup -> do 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 CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}} <- withStore $ \db -> getGroupChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId, editable) of case (mode, msgDir, itemSharedMsgId, editable) of
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime (CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
@ -852,7 +857,7 @@ processChatCommand = \case
CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do 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 CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId
case (chatDir, itemSharedMsgId) of case (chatDir, itemSharedMsgId) of
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
@ -881,7 +886,7 @@ processChatCommand = \case
pure $ CRChatItemReaction user add r pure $ CRChatItemReaction user add r
_ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID"
CTGroup -> 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 (Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do
unless (groupFeatureAllowed SGFReactions g) $ unless (groupFeatureAllowed SGFReactions g) $
throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions)) throwChatError (CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions))
@ -940,7 +945,7 @@ processChatCommand = \case
ok user ok user
CTGroup -> do CTGroup -> do
withStore $ \db -> do withStore $ \db -> do
Group {groupInfo} <- getGroup db user chatId Group {groupInfo} <- getGroup db vr user chatId
liftIO $ updateGroupUnreadChat db user groupInfo unreadChat liftIO $ updateGroupUnreadChat db user groupInfo unreadChat
ok user ok user
_ -> pure $ chatCmdError (Just user) "not supported" _ -> pure $ chatCmdError (Just user) "not supported"
@ -965,7 +970,7 @@ processChatCommand = \case
withStore' $ \db -> deletePendingContactConnection db userId chatId withStore' $ \db -> deletePendingContactConnection db userId chatId
pure $ CRContactConnectionDeleted user conn pure $ CRContactConnectionDeleted user conn
CTGroup -> do 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 let isOwner = membership.memberRole == GROwner
canDelete = isOwner || not (memberCurrent membership) canDelete = isOwner || not (memberCurrent membership)
unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
@ -1008,7 +1013,7 @@ processChatCommand = \case
withStore' $ \db -> deleteContactCIs db user ct withStore' $ \db -> deleteContactCIs db user ct
pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct) pure $ CRChatCleared user (AChatInfo SCTDirect $ DirectChat ct)
CTGroup -> do CTGroup -> do
gInfo <- withStore $ \db -> getGroupInfo db user chatId gInfo <- withStore $ \db -> getGroupInfo db vr user chatId
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
deleteFilesAndConns user filesInfo deleteFilesAndConns user filesInfo
withStore' $ \db -> deleteGroupCIs db user gInfo withStore' $ \db -> deleteGroupCIs db user gInfo
@ -1152,7 +1157,7 @@ processChatCommand = \case
user_ <- withStore' (`getUserByAConnId` agentConnId) user_ <- withStore' (`getUserByAConnId` agentConnId)
connEntity_ <- connEntity_ <-
pure user_ $>>= \user -> 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} pure CRNtfMessages {user_, connEntity_, msgTs = msgTs', ntfMessages = map ntfMsgInfo msgs}
APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do APIGetUserProtoServers userId (AProtocolType p) -> withUserId userId $ \user -> withServerProtocol p $ do
ChatConfig {defaultServers} <- asks config ChatConfig {defaultServers} <- asks config
@ -1215,7 +1220,7 @@ processChatCommand = \case
ok user ok user
CTGroup -> do CTGroup -> do
ms <- withStore $ \db -> do ms <- withStore $ \db -> do
Group _ ms <- getGroup db user chatId Group _ ms <- getGroup db vr user chatId
liftIO $ updateGroupSettings db user chatId chatSettings liftIO $ updateGroupSettings db user chatId chatSettings
pure ms pure ms
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId -> forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
@ -1240,10 +1245,10 @@ processChatCommand = \case
connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct) connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct)
pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile) pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile)
APIGroupInfo gId -> withUser $ \user -> do 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 pure $ CRGroupInfo user g s
APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do 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) connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
pure $ CRGroupMemberInfo user g m connectionStats pure $ CRGroupMemberInfo user g m connectionStats
APISwitchContact contactId -> withUser $ \user -> do APISwitchContact contactId -> withUser $ \user -> do
@ -1254,7 +1259,7 @@ processChatCommand = \case
pure $ CRContactSwitchStarted user ct connectionStats pure $ CRContactSwitchStarted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
APISwitchGroupMember gId gMemberId -> withUser $ \user -> do 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 case memberConnId m of
Just connId -> do Just connId -> do
connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId) connectionStats <- withAgent (\a -> switchConnectionAsync a "" connId)
@ -1268,7 +1273,7 @@ processChatCommand = \case
pure $ CRContactSwitchAborted user ct connectionStats pure $ CRContactSwitchAborted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do 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 case memberConnId m of
Just connId -> do Just connId -> do
connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
@ -1283,7 +1288,7 @@ processChatCommand = \case
pure $ CRContactRatchetSyncStarted user ct cStats pure $ CRContactRatchetSyncStarted user ct cStats
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> withChatLock "syncGroupMemberRatchet" $ do 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 case memberConnId m of
Just connId -> do Just connId -> do
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force
@ -1305,7 +1310,7 @@ processChatCommand = \case
pure $ CRContactCode user ct' code pure $ CRContactCode user ct' code
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do 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 case activeConn of
Just conn@Connection {connId} -> do Just conn@Connection {connId} -> do
code <- getConnectionCode $ aConnId conn code <- getConnectionCode $ aConnId conn
@ -1487,7 +1492,7 @@ processChatCommand = \case
let chatRef = ChatRef CTDirect ctId let chatRef = ChatRef CTDirect ctId
processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage Nothing Nothing mc
Left _ -> Left _ ->
withStore' (\db -> runExceptT $ getActiveMembersByName db user name) >>= \case withStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
Right [(gInfo, member)] -> do Right [(gInfo, member)] -> do
let GroupInfo {localDisplayName = gName} = gInfo let GroupInfo {localDisplayName = gName} = gInfo
GroupMember {localDisplayName = mName} = member GroupMember {localDisplayName = mName} = member
@ -1507,7 +1512,7 @@ processChatCommand = \case
let mc = MCText msg let mc = MCText msg
case memberContactId m of case memberContactId m of
Nothing -> do Nothing -> do
gInfo <- withStore $ \db -> getGroupInfo db user gId gInfo <- withStore $ \db -> getGroupInfo db vr user gId
toView $ CRNoMemberContactCreating user gInfo m toView $ CRNoMemberContactCreating user gInfo m
processChatCommand (APICreateMemberContact gId mId) >>= \case processChatCommand (APICreateMemberContact gId mId) >>= \case
cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do cr@(CRNewMemberContact _ Contact {contactId} _ _) -> do
@ -1567,13 +1572,13 @@ processChatCommand = \case
gVar <- asks random gVar <- asks random
-- [incognito] generate incognito profile for group membership -- [incognito] generate incognito profile for group membership
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing 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 pure $ CRGroupCreated user groupInfo
NewGroup incognito gProfile -> withUser $ \User {userId} -> NewGroup incognito gProfile -> withUser $ \User {userId} ->
processChatCommand $ APINewGroup userId incognito gProfile processChatCommand $ APINewGroup userId incognito gProfile
APIAddMember groupId contactId memRole -> withUser $ \user -> withChatLock "addMember" $ do 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 -- 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_ assertDirectAllowed user MDSnd contact XGrpInv_
let Group gInfo members = group let Group gInfo members = group
Contact {localDisplayName = cName} = contact Contact {localDisplayName = cName} = contact
@ -1603,7 +1608,7 @@ processChatCommand = \case
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
withChatLock "joinGroup" . procCmd $ do withChatLock "joinGroup" . procCmd $ do
(invitation, ct) <- withStore $ \db -> 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 (inv,) <$> getContactViaMember db user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
Contact {activeConn} = ct Contact {activeConn} = ct
@ -1621,14 +1626,14 @@ processChatCommand = \case
Nothing -> throwChatError $ CEContactNotActive ct Nothing -> throwChatError $ CEContactNotActive ct
where where
updateCIGroupInvitationStatus user = do 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 case (cInfo, content) of
(DirectChat ct, CIRcvGroupInvitation ciGroupInv memRole) -> do (DirectChat ct, CIRcvGroupInvitation ciGroupInv memRole) -> do
let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole let aciContent = ACIContent SMDRcv $ CIRcvGroupInvitation ciGroupInv {status = CIGISAccepted} memRole
updateDirectChatItemView user ct itemId aciContent False Nothing updateDirectChatItemView user ct itemId aciContent False Nothing
_ -> pure () -- prohibited _ -> pure () -- prohibited
APIMemberRole groupId memberId memRole -> withUser $ \user -> do 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 if memberId == groupMemberId' membership
then changeMemberRole user gInfo members membership $ SGEUserRole memRole then changeMemberRole user gInfo members membership $ SGEUserRole memRole
else case find ((== memberId) . groupMemberId') members of else case find ((== memberId) . groupMemberId') members of
@ -1652,7 +1657,7 @@ processChatCommand = \case
toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole}
APIRemoveMember groupId memberId -> withUser $ \user -> do 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 case find ((== memberId) . groupMemberId') members of
Nothing -> throwChatError CEGroupMemberNotFound Nothing -> throwChatError CEGroupMemberNotFound
Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus, memberProfile} -> do
@ -1671,7 +1676,7 @@ processChatCommand = \case
deleteOrUpdateMemberRecord user m deleteOrUpdateMemberRecord user m
pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved} pure $ CRUserDeletedMember user gInfo m {memberStatus = GSMemRemoved}
APILeaveGroup groupId -> withUser $ \user@User {userId} -> do 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 withChatLock "leaveGroup" . procCmd $ do
(msg, _) <- sendGroupMessage user gInfo members XGrpLeave (msg, _) <- sendGroupMessage user gInfo members XGrpLeave
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft)
@ -1683,7 +1688,7 @@ processChatCommand = \case
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}} pure $ CRLeftMemberUser user gInfo {membership = membership {memberStatus = GSMemLeft}}
APIListMembers groupId -> withUser $ \user -> 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 AddMember gName cName memRole -> withUser $ \user -> do
(groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName (groupId, contactId) <- withStore $ \db -> (,) <$> getGroupIdByName db user gName <*> getContactIdByName db user cName
processChatCommand $ APIAddMember groupId contactId memRole processChatCommand $ APIAddMember groupId contactId memRole
@ -1705,23 +1710,23 @@ processChatCommand = \case
groupId <- withStore $ \db -> getGroupIdByName db user gName groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId processChatCommand $ APIListMembers groupId
APIListGroups userId contactId_ search_ -> withUserId userId $ \user -> 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 ListGroups cName_ search_ -> withUser $ \user@User {userId} -> do
ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName ct_ <- forM cName_ $ \cName -> withStore $ \db -> getContactByName db user cName
processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_ processChatCommand $ APIListGroups userId (contactId' <$> ct_) search_
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do 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' runUpdateGroupProfile user g p'
UpdateGroupNames gName GroupProfile {displayName, fullName} -> UpdateGroupNames gName GroupProfile {displayName, fullName} ->
updateGroupProfileByName gName $ \p -> p {displayName, fullName} updateGroupProfileByName gName $ \p -> p {displayName, fullName}
ShowGroupProfile gName -> withUser $ \user -> ShowGroupProfile gName -> withUser $ \user ->
CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db user gName) CRGroupProfile user <$> withStore (\db -> getGroupInfoByName db vr user gName)
UpdateGroupDescription gName description -> UpdateGroupDescription gName description ->
updateGroupProfileByName gName $ \p -> p {description} updateGroupProfileByName gName $ \p -> p {description}
ShowGroupDescription gName -> withUser $ \user -> 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 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 assertUserGroupRole gInfo GRAdmin
when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole when (mRole > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole
groupLinkId <- GroupLinkId <$> drgRandomBytes 16 groupLinkId <- GroupLinkId <$> drgRandomBytes 16
@ -1731,22 +1736,22 @@ processChatCommand = \case
withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode withStore $ \db -> createGroupLink db user gInfo connId cReq groupLinkId mRole subMode
pure $ CRGroupLinkCreated user gInfo cReq mRole pure $ CRGroupLinkCreated user gInfo cReq mRole
APIGroupLinkMemberRole groupId mRole' -> withUser $ \user -> withChatLock "groupLinkMemberRole " $ do 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 (groupLinkId, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
assertUserGroupRole gInfo GRAdmin assertUserGroupRole gInfo GRAdmin
when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole' when (mRole' > GRMember) $ throwChatError $ CEGroupMemberInitialRole gInfo mRole'
when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole' when (mRole' /= mRole) $ withStore' $ \db -> setGroupLinkMemberRole db user groupLinkId mRole'
pure $ CRGroupLink user gInfo groupLink mRole' pure $ CRGroupLink user gInfo groupLink mRole'
APIDeleteGroupLink groupId -> withUser $ \user -> withChatLock "deleteGroupLink" $ do 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 deleteGroupLink' user gInfo
pure $ CRGroupLinkDeleted user gInfo pure $ CRGroupLinkDeleted user gInfo
APIGetGroupLink groupId -> withUser $ \user -> do 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 (_, groupLink, mRole) <- withStore $ \db -> getGroupLink db user gInfo
pure $ CRGroupLink user gInfo groupLink mRole pure $ CRGroupLink user gInfo groupLink mRole
APICreateMemberContact gId gMemberId -> withUser $ \user -> do 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 assertUserGroupRole g GRAuthor
unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed" unless (groupFeatureAllowed SGFDirectMessages g) $ throwChatError $ CECommandError "direct messages not allowed"
case memberConn m of case memberConn m of
@ -1762,7 +1767,7 @@ processChatCommand = \case
pure $ CRNewMemberContact user ct g m pure $ CRNewMemberContact user ct g m
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
APISendMemberContactInvitation contactId msgContent_ -> withUser $ \user -> do 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" when (contactGrpInvSent ct) $ throwChatError $ CECommandError "x.grp.direct.inv already sent"
case memberConn m of case memberConn m of
Just mConn -> do Just mConn -> do
@ -1794,7 +1799,7 @@ processChatCommand = \case
processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc
LastChats count_ -> withUser' $ \user -> do LastChats count_ -> withUser' $ \user -> do
let count = fromMaybe 5000 count_ 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) unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
pure $ CRChats previews pure $ CRChats previews
LastMessages (Just chatName) count search -> withUser $ \user -> do LastMessages (Just chatName) count search -> withUser $ \user -> do
@ -1802,22 +1807,22 @@ processChatCommand = \case
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp) pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
LastMessages Nothing count search -> withUser $ \user -> do 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 pure $ CRChatItems user Nothing chatItems
LastChatItemId (Just chatName) index -> withUser $ \user -> do LastChatItemId (Just chatName) index -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing) chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp) pure $ CRChatItemId user (fmap aChatItemId . listToMaybe . aChatItems . chat $ chatResp)
LastChatItemId Nothing index -> withUser $ \user -> do 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) pure $ CRChatItemId user (fmap aChatItemId . listToMaybe $ chatItems)
ShowChatItem (Just itemId) -> withUser $ \user -> do ShowChatItem (Just itemId) -> withUser $ \user -> do
chatItem <- withStore $ \db -> do chatItem <- withStore $ \db -> do
chatRef <- getChatRefViaItemId db user itemId chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId getAChatItem db vr user chatRef itemId
pure $ CRChatItems user Nothing ((: []) chatItem) pure $ CRChatItems user Nothing ((: []) chatItem)
ShowChatItem Nothing -> withUser $ \user -> do 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 pure $ CRChatItems user Nothing chatItems
ShowChatItemInfo chatName msg -> withUser $ \user -> do ShowChatItemInfo chatName msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
@ -1867,10 +1872,10 @@ processChatCommand = \case
contact <- withStore $ \db -> getContact db user contactId contact <- withStore $ \db -> getContact db user contactId
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
ChatRef CTGroup groupId -> do 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 void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" _ -> 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 pure $ CRSndFileCancelled user ci ftm fts
where where
fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} = fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} =
@ -1881,7 +1886,7 @@ processChatCommand = \case
| otherwise -> case xftpRcvFile of | otherwise -> case xftpRcvFile of
Nothing -> do Nothing -> do
cancelRcvFileTransfer user ftr >>= mapM_ (deleteAgentConnectionAsync user) 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 pure $ CRRcvFileCancelled user ci ftr
Just XFTPRcvFile {agentRcvFileId} -> do Just XFTPRcvFile {agentRcvFileId} -> do
forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do forM_ (liveRcvFileTransferPath ftr) $ \filePath -> do
@ -1894,10 +1899,10 @@ processChatCommand = \case
updateCIFileStatus db user fileId CIFSRcvInvitation updateCIFileStatus db user fileId CIFSRcvInvitation
updateRcvFileStatus db fileId FSNew updateRcvFileStatus db fileId FSNew
updateRcvFileAgentId db fileId Nothing updateRcvFileAgentId db fileId Nothing
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
pure $ CRRcvFileCancelled user ci ftr pure $ CRRcvFileCancelled user ci ftr
FileStatus fileId -> withUser $ \user -> do 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 case file of
Just CIFile {fileProtocol = FPXFTP} -> Just CIFile {fileProtocol = FPXFTP} ->
pure $ CRFileTransferStatusXFTP user ci pure $ CRFileTransferStatusXFTP user ci
@ -2199,7 +2204,7 @@ processChatCommand = \case
updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse
updateGroupProfileByName gName update = withUser $ \user -> do updateGroupProfileByName gName update = withUser $ \user -> do
g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> 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 runUpdateGroupProfile user g $ update p
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
withCurrentCall ctId action = do withCurrentCall ctId action = do
@ -2314,15 +2319,16 @@ processChatCommand = \case
ctId <- getContactIdByName db user name ctId <- getContactIdByName db user name
Contact {chatSettings} <- getContact db user ctId Contact {chatSettings} <- getContact db user ctId
pure (ctId, chatSettings) pure (ctId, chatSettings)
CTGroup -> withStore $ \db -> do CTGroup ->
gId <- getGroupIdByName db user name withStore $ \db -> do
GroupInfo {chatSettings} <- getGroupInfo db user gId gId <- getGroupIdByName db user name
pure (gId, chatSettings) GroupInfo {chatSettings} <- getGroupInfo db vr user gId
pure (gId, chatSettings)
_ -> throwChatError $ CECommandError "not supported" _ -> throwChatError $ CECommandError "not supported"
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan
connectPlan user (ACR SCMInvitation cReq) = do 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 Nothing -> pure $ CPInvitationLink ILPOk
Just (RcvDirectMsgConnection conn ct_) -> do Just (RcvDirectMsgConnection conn ct_) -> do
let Connection {connStatus, contactConnInitiated} = conn let Connection {connStatus, contactConnInitiated} = conn
@ -2351,7 +2357,7 @@ processChatCommand = \case
withStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case withStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case
Just _ -> pure $ CPContactAddress CAPOwnLink Just _ -> pure $ CPContactAddress CAPOwnLink
Nothing -> Nothing ->
withStore' (\db -> getContactConnEntityByConnReqHash db user cReqHashes) >>= \case withStore' (\db -> getContactConnEntityByConnReqHash db vr user cReqHashes) >>= \case
Nothing -> Nothing ->
withStore' (\db -> getContactWithoutConnViaAddress db user cReqSchemas) >>= \case withStore' (\db -> getContactWithoutConnViaAddress db user cReqSchemas) >>= \case
Nothing -> pure $ CPContactAddress CAPOk Nothing -> pure $ CPContactAddress CAPOk
@ -2364,11 +2370,11 @@ processChatCommand = \case
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection" Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
-- group link -- group link
Just _ -> Just _ ->
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db user cReqSchemas) >>= \case withStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case
Just g -> pure $ CPGroupLink (GLPOwnLink g) Just g -> pure $ CPGroupLink (GLPOwnLink g)
Nothing -> do Nothing -> do
connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db user cReqHashes connEnt_ <- withStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db user cReqHashes gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes
case (gInfo_, connEnt_) of case (gInfo_, connEnt_) of
(Nothing, Nothing) -> pure $ CPGroupLink GLPOk (Nothing, Nothing) -> pure $ CPGroupLink GLPOk
(Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect (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 unless (fileStatus == RFSNew) $ case fileStatus of
RFSCancelled _ -> throwChatError $ CEFileCancelled fName RFSCancelled _ -> throwChatError $ CEFileCancelled fName
_ -> throwChatError $ CEFileAlreadyReceiving fName _ -> throwChatError $ CEFileAlreadyReceiving fName
vr <- chatVersionRange
case (xftpRcvFile, fileConnReq) of case (xftpRcvFile, fileConnReq) of
-- direct file protocol -- direct file protocol
(Nothing, Just connReq) -> do (Nothing, Just connReq) -> do
@ -2605,14 +2612,14 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
dm <- directMessage $ XFileAcpt fName dm <- directMessage $ XFileAcpt fName
connIds <- joinAgentConnectionAsync user True connReq dm subMode connIds <- joinAgentConnectionAsync user True connReq dm subMode
filePath <- getRcvFilePath fileId filePath_ fName True 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 -- XFTP
(Just XFTPRcvFile {}, _) -> do (Just XFTPRcvFile {}, _) -> do
filePath <- getRcvFilePath fileId filePath_ fName False filePath <- getRcvFilePath fileId filePath_ fName False
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do (ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
-- marking file as accepted and reading description in the same transaction -- marking file as accepted and reading description in the same transaction
-- to prevent race condition with appending description -- to prevent race condition with appending description
ci <- xftpAcceptRcvFT db user fileId filePath ci <- xftpAcceptRcvFT db vr user fileId filePath
rfd <- getRcvFileDescrByRcvFileId db fileId rfd <- getRcvFileDescrByRcvFileId db fileId
pure (ci, rfd) pure (ci, rfd)
receiveViaCompleteFD user fileId rfd cryptoArgs receiveViaCompleteFD user fileId rfd cryptoArgs
@ -2636,10 +2643,11 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
acceptFile cmdFunction send = do acceptFile cmdFunction send = do
filePath <- getRcvFilePath fileId filePath_ fName True filePath <- getRcvFilePath fileId filePath_ fName True
inline <- receiveInline inline <- receiveInline
vr <- chatVersionRange
if if
| inline -> do | inline -> do
-- accepting inline -- 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 sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
send $ XFileAcptInv sharedMsgId Nothing fName send $ XFileAcptInv sharedMsgId Nothing fName
pure ci pure ci
@ -2648,7 +2656,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
-- accepting via a new connection -- accepting via a new connection
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
connIds <- createAgentConnectionAsync user cmdFunction True SCMInvitation subMode 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 :: m Bool
receiveInline = do receiveInline = do
ChatConfig {fileChunkSize, inlineFiles = InlineFilesConfig {receiveChunks, offerChunks}} <- asks config 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 :: ChatMonad m => User -> FileTransferId -> m ()
startReceivingFile user fileId = do startReceivingFile user fileId = do
vr <- chatVersionRange
ci <- withStoreCtx (Just "startReceivingFile, updateRcvFileStatus ...") $ \db -> do ci <- withStoreCtx (Just "startReceivingFile, updateRcvFileStatus ...") $ \db -> do
liftIO $ updateRcvFileStatus db fileId FSConnected liftIO $ updateRcvFileStatus db fileId FSConnected
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1 liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRRcvFileStart user ci toView $ CRRcvFileStart user ci
getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> Bool -> m FilePath 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 ())) type AgentBatchSubscribe m = AgentClient -> [ConnId] -> ExceptT AgentErrorType m (Map ConnId (Either AgentErrorType ()))
subscribeUserConnections :: forall m. ChatMonad m => Bool -> AgentBatchSubscribe m -> User -> m () subscribeUserConnections :: forall m. ChatMonad m => VersionRange -> Bool -> AgentBatchSubscribe m -> User -> m ()
subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do subscribeUserConnections vr onlyNeeded agentBatchSubscribe user@User {userId} = do
-- get user connections -- get user connections
ce <- asks $ subscriptionEvents . config ce <- asks $ subscriptionEvents . config
(conns, cts, ucs, gs, ms, sfts, rfts, pcs) <- (conns, cts, ucs, gs, ms, sfts, rfts, pcs) <-
if onlyNeeded if onlyNeeded
then do 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 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) pure (conns, cts, ucs, [], ms, sfts, rfts, pcs)
else do else do
@ -2845,7 +2854,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
getContactConns :: m ([ConnId], Map ConnId Contact) getContactConns :: m ([ConnId], Map ConnId Contact)
getContactConns = do getContactConns = do
cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts 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) pure (connIds, M.fromList $ zip connIds cts)
getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact) getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact)
getUserContactLinkConns = do getUserContactLinkConns = do
@ -2854,7 +2863,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
pure (connIds, M.fromList $ zip connIds ucs) pure (connIds, M.fromList $ zip connIds ucs)
getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember) getGroupMemberConns :: m ([Group], [ConnId], Map ConnId GroupMember)
getGroupMemberConns = do 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 let mPairs = concatMap (\(Group _ ms) -> mapMaybe (\m -> (,m) <$> memberConnId m) (filter (not . memberRemoved) ms)) gs
pure (gs, map fst mPairs, M.fromList mPairs) pure (gs, map fst mPairs, M.fromList mPairs)
getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer) getSndFileTransferConns :: m ([ConnId], Map ConnId SndFileTransfer)
@ -3029,12 +3038,13 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
ts <- liftIO getCurrentTime ts <- liftIO getCurrentTime
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts
waitChatStarted waitChatStarted
vr <- chatVersionRange
case cType of case cType of
CTDirect -> do CTDirect -> do
(ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId (ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
deleteDirectCI user ct ci True True >>= toView deleteDirectCI user ct ci True True >>= toView
CTGroup -> do 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 deletedTs <- liftIO getCurrentTime
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
_ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType" _ -> 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 :: forall m. ChatMonad m => User -> Int64 -> Bool -> m ()
expireChatItems user@User {userId} ttl sync = do expireChatItems user@User {userId} ttl sync = do
currentTs <- liftIO getCurrentTime currentTs <- liftIO getCurrentTime
vr <- chatVersionRange
let expirationDate = addUTCTime (-1 * fromIntegral ttl) currentTs 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 -- 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 createdAtCutoff = addUTCTime (-43200 :: NominalDiffTime) currentTs
contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user) contacts <- withStoreCtx' (Just "expireChatItems, getUserContacts") (`getUserContacts` user)
loop contacts $ processContact expirationDate 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 loop groups $ processGroup expirationDate createdAtCutoff
where where
loop :: [a] -> (a -> m ()) -> m () loop :: [a] -> (a -> m ()) -> m ()
@ -3088,9 +3099,10 @@ processAgentMessage _ connId (DEL_RCVQ srv qId err_) =
toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_ toView $ CRAgentRcvQueueDeleted (AgentConnId connId) srv (AgentQueueId qId) err_
processAgentMessage _ connId DEL_CONN = processAgentMessage _ connId DEL_CONN =
toView $ CRAgentConnDeleted (AgentConnId connId) toView $ CRAgentConnDeleted (AgentConnId connId)
processAgentMessage corrId connId msg = processAgentMessage corrId connId msg = do
vr <- chatVersionRange
withStore' (`getUserByAConnId` AgentConnId connId) >>= \case 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) _ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone -> m () 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 (ft@FileTransferMeta {fileId, cancelled}, sfts) <- withStore $ \db -> do
fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId fileId <- getXFTPSndFileDBId db user $ AgentSndFileId aFileId
getSndFileTransfer db user fileId getSndFileTransfer db user fileId
vr <- chatVersionRange
unless cancelled $ case msg of unless cancelled $ case msg of
SFPROG sndProgress sndTotal -> do SFPROG sndProgress sndTotal -> do
let status = CIFSSndTransfer {sndProgress, sndTotal} let status = CIFSSndTransfer {sndProgress, sndTotal}
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status liftIO $ updateCIFileStatus db user fileId status
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
SFDONE sndDescr rfds -> do SFDONE sndDescr rfds -> do
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr) withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <- 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 case (msgId_, itemDeleted) of
(Just sharedMsgId, Nothing) -> do (Just sharedMsgId, Nothing) -> do
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send" 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)) forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user))
ci' <- withStore $ \db -> do ci' <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId) withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileCompleteXFTP user ci' ft toView $ CRSndFileCompleteXFTP user ci' ft
where where
@ -3181,7 +3194,7 @@ processAgentMsgSndFile _corrId aFileId msg =
| otherwise -> do | otherwise -> do
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSSndError liftIO $ updateFileCancelled db user fileId CIFSSndError
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
withAgent (`xftpDeleteSndFileInternal` aFileId) withAgent (`xftpDeleteSndFileInternal` aFileId)
toView $ CRSndFileError user ci toView $ CRSndFileError user ci
where where
@ -3228,12 +3241,13 @@ processAgentMsgRcvFile _corrId aFileId msg =
ft@RcvFileTransfer {fileId} <- withStore $ \db -> do ft@RcvFileTransfer {fileId} <- withStore $ \db -> do
fileId <- getXFTPRcvFileDBId db $ AgentRcvFileId aFileId fileId <- getXFTPRcvFileDBId db $ AgentRcvFileId aFileId
getRcvFileTransfer db user fileId getRcvFileTransfer db user fileId
vr <- chatVersionRange
unless (rcvFileCompleteOrCancelled ft) $ case msg of unless (rcvFileCompleteOrCancelled ft) $ case msg of
RFPROG rcvProgress rcvTotal -> do RFPROG rcvProgress rcvTotal -> do
let status = CIFSRcvTransfer {rcvProgress, rcvTotal} let status = CIFSRcvTransfer {rcvProgress, rcvTotal}
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateCIFileStatus db user fileId status liftIO $ updateCIFileStatus db user fileId status
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal
RFDONE xftpPath -> RFDONE xftpPath ->
case liveRcvFileTransferPath ft of case liveRcvFileTransferPath ft of
@ -3245,7 +3259,7 @@ processAgentMsgRcvFile _corrId aFileId msg =
liftIO $ do liftIO $ do
updateRcvFileStatus db fileId FSComplete updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete updateCIFileStatus db user fileId CIFSRcvComplete
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
agentXFTPDeleteRcvFile aFileId fileId agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileComplete user ci toView $ CRRcvFileComplete user ci
RFERR e RFERR e
@ -3254,13 +3268,13 @@ processAgentMsgRcvFile _corrId aFileId msg =
| otherwise -> do | otherwise -> do
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateFileCancelled db user fileId CIFSRcvError liftIO $ updateFileCancelled db user fileId CIFSRcvError
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
agentXFTPDeleteRcvFile aFileId fileId agentXFTPDeleteRcvFile aFileId fileId
toView $ CRRcvFileError user ci e toView $ CRRcvFileError user ci e
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m () processAgentMessageConn :: forall m. ChatMonad m => VersionRange -> User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus entity <- withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus
case agentMessage of case agentMessage of
END -> case entity of END -> case entity of
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
@ -3406,7 +3420,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
XOk -> pure () XOk -> pure ()
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok" _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
CON -> CON ->
withStore' (\db -> getViaGroupMember db user ct) >>= \case withStore' (\db -> getViaGroupMember db vr user ct) >>= \case
Nothing -> do Nothing -> do
-- [incognito] print incognito profile used for this contact -- [incognito] print incognito profile used for this contact
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) 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) ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
forM_ groupId_ $ \groupId -> do forM_ groupId_ $ \groupId -> do
groupInfo <- withStore $ \db -> getGroupInfo db user groupId groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
gVar <- asks random gVar <- asks random
@ -3595,7 +3609,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
profileToSend = profileToSendOnAccept user profileMode profileToSend = profileToSendOnAccept user profileMode
void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId) void $ sendDirectMessage conn (XGrpLinkMem profileToSend) (GroupId groupId)
sendIntroductions members = do sendIntroductions members = do
intros <- withStore' $ \db -> createIntroductions db members m intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m
shuffledIntros <- liftIO $ shuffleIntros intros shuffledIntros <- liftIO $ shuffleIntros intros
if isCompatibleRange (memberChatVRange' m) batchSendVRange if isCompatibleRange (memberChatVRange' m) batchSendVRange
then do then do
@ -3885,7 +3899,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
CON -> do CON -> do
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSConnected 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 toView $ CRSndFileStart user ci ft
sendFileChunk user ft sendFileChunk user ft
SENT msgId -> do SENT msgId -> do
@ -3899,7 +3913,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
getChatRefByFileId db user fileId >>= \case getChatRefByFileId db user fileId >>= \case
ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled ChatRef CTDirect _ -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
_ -> pure () _ -> pure ()
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRSndFileRcvCancelled user ci ft toView $ CRSndFileRcvCancelled user ci ft
_ -> throwChatError $ CEFileSend fileId err _ -> throwChatError $ CEFileSend fileId err
MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure () MSG meta _ _ -> withAckMessage' agentConnId conn meta $ pure ()
@ -3965,7 +3979,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
FileChunkCancel -> FileChunkCancel ->
unless (rcvFileCompleteOrCancelled ft) $ do unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) 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 toView $ CRRcvFileSndCancelled user ci ft
FileChunk {chunkNo, chunkBytes = chunk} -> do FileChunk {chunkNo, chunkBytes = chunk} -> do
case integrity of case integrity of
@ -3988,7 +4002,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
updateRcvFileStatus db fileId FSComplete updateRcvFileStatus db fileId FSComplete
updateCIFileStatus db user fileId CIFSRcvComplete updateCIFileStatus db user fileId CIFSRcvComplete
deleteRcvFileChunks db ft deleteRcvFileChunks db ft
getChatItemByFileId db user fileId getChatItemByFileId db vr user fileId
toView $ CRRcvFileComplete user ci toView $ CRRcvFileComplete user ci
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn) forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
RcvChunkDuplicate -> ack $ pure () RcvChunkDuplicate -> ack $ pure ()
@ -4031,7 +4045,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ct <- acceptContactRequestAsync user cReq incognitoProfile True ct <- acceptContactRequestAsync user cReq incognitoProfile True
toView $ CRAcceptingContactRequest user ct toView $ CRAcceptingContactRequest user ct
Just groupId -> do Just groupId -> do
gInfo <- withStore $ \db -> getGroupInfo db user groupId gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
if isCompatibleRange chatVRange groupLinkNoContactVRange if isCompatibleRange chatVRange groupLinkNoContactVRange
then do then do
@ -4524,14 +4538,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ft <- withStore (\db -> getRcvFileTransfer db user fileId) ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) 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 toView $ CRRcvFileSndCancelled user ci ft
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m () xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId 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 assertSMPAcceptNotProhibited ci
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) 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 -- [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 -- receiving inline
_ -> do _ -> do
event <- withStore $ \db -> 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 sft <- createSndDirectInlineFT db ct ft
pure $ CRSndFileStart user ci' sft pure $ CRSndFileStart user ci' sft
toView event toView event
@ -4574,7 +4588,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
liftIO $ updateSndFileStatus db sft FSComplete liftIO $ updateSndFileStatus db sft FSComplete
liftIO $ deleteSndFileChunks db sft liftIO $ deleteSndFileChunks db sft
updateDirectCIFileStatus db user fileId CIFSSndComplete updateDirectCIFileStatus db vr user fileId CIFSSndComplete
case file of case file of
Just CIFile {fileProtocol = FPXFTP} -> do Just CIFile {fileProtocol = FPXFTP} -> do
ft <- withStore $ \db -> getFileTransferMeta db user fileId 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) ft <- withStore (\db -> getRcvFileTransfer db user fileId)
unless (rcvFileCompleteOrCancelled ft) $ do unless (rcvFileCompleteOrCancelled ft) $ do
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user) 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 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 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" (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 -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> m ()
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId 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 assertSMPAcceptNotProhibited ci
-- TODO check that it's not already accepted -- TODO check that it's not already accepted
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId) 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 (_, Just conn) -> do
-- receiving inline -- receiving inline
event <- withStore $ \db -> do 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 sft <- liftIO $ createSndGroupInlineFT db m conn ft
pure $ CRSndFileStart user ci' sft pure $ CRSndFileStart user ci' sft
toView event toView event
@ -4667,7 +4681,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile -- [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' if sameGroupLinkId groupLinkId groupLinkId'
then do then do
subMode <- chatReadVar subscriptionMode subMode <- chatReadVar subscriptionMode
@ -5018,14 +5033,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
associateMemberWithContact :: Contact -> GroupMember -> m Contact associateMemberWithContact :: Contact -> GroupMember -> m Contact
associateMemberWithContact c1 m2@GroupMember {groupId} = do associateMemberWithContact c1 m2@GroupMember {groupId} = do
withStore' $ \db -> associateMemberWithContactRecord db user c1 m2 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 toView $ CRContactAndMemberAssociated user c1 g m2 c1
pure c1 pure c1
associateContactWithMember :: GroupMember -> Contact -> m Contact associateContactWithMember :: GroupMember -> Contact -> m Contact
associateContactWithMember m1@GroupMember {groupId} c2 = do associateContactWithMember m1@GroupMember {groupId} c2 = do
c2' <- withStore $ \db -> associateContactWithMemberRecord db user m1 c2 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' toView $ CRContactAndMemberAssociated user c2 g m1 c2'
pure c2' pure c2'
@ -5040,7 +5055,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
toView $ CRContactConnecting user ct toView $ CRContactConnecting user ct
pure conn' pure conn'
XGrpLinkInv glInv -> do 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 toView $ CRGroupLinkConnecting user gInfo host
pure conn' pure conn'
-- TODO show/log error, other events in SMP confirmation -- TODO show/log error, other events in SMP confirmation
@ -5440,14 +5455,15 @@ parseChatMessage conn s = do
sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m () sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m ()
sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} = 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 withStore' (`createSndFileChunk` ft) >>= \case
Just chunkNo -> sendFileChunkNo ft chunkNo Just chunkNo -> sendFileChunkNo ft chunkNo
Nothing -> do Nothing -> do
ci <- withStore $ \db -> do ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSComplete liftIO $ updateSndFileStatus db ft FSComplete
liftIO $ deleteSndFileChunks db ft liftIO $ deleteSndFileChunks db ft
updateDirectCIFileStatus db user fileId CIFSSndComplete updateDirectCIFileStatus db vr user fileId CIFSSndComplete
toView $ CRSndFileComplete user ci ft toView $ CRSndFileComplete user ci ft
closeFileHandle fileId sndFiles closeFileHandle fileId sndFiles
deleteAgentConnectionAsync user acId deleteAgentConnectionAsync user acId
@ -5612,8 +5628,8 @@ sendDirectMessage conn chatMsgEvent connOrGroupId = do
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
createSndMessage chatMsgEvent connOrGroupId = do createSndMessage chatMsgEvent connOrGroupId = do
gVar <- asks random gVar <- asks random
ChatConfig {chatVRange} <- asks config vr <- chatVersionRange
withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage chatVRange) withStore $ \db -> createNewSndMessage db gVar connOrGroupId chatMsgEvent (encodeMessage vr)
where where
encodeMessage chatVRange sharedMsgId = encodeMessage chatVRange sharedMsgId =
encodeChatMessage ChatMessage {chatVRange, msgId = Just sharedMsgId, chatMsgEvent} 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 :: m [Either ChatError SndMessage]
createSndMessages = do createSndMessages = do
gVar <- asks random gVar <- asks random
ChatConfig {chatVRange} <- asks config vr <- chatVersionRange
withStoreBatch $ \db -> map (createMsg db gVar chatVRange) (toList events) withStoreBatch $ \db -> map (createMsg db gVar vr) (toList events)
createMsg db gVar chatVRange evnt = do createMsg db gVar chatVRange evnt = do
r <- runExceptT $ createNewSndMessage db gVar (GroupId groupId) evnt (encodeMessage chatVRange evnt) r <- runExceptT $ createNewSndMessage db gVar (GroupId groupId) evnt (encodeMessage chatVRange evnt)
pure $ first ChatErrorStore r 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 :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> m ByteString
directMessage chatMsgEvent = do directMessage chatMsgEvent = do
ChatConfig {chatVRange} <- asks config chatVRange <- chatVersionRange
let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent} let r = encodeChatMessage ChatMessage {chatVRange, msgId = Nothing, chatMsgEvent}
case r of case r of
ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody ECMEncoded encodedBody -> pure . LB.toStrict $ encodedBody
@ -6102,6 +6118,11 @@ waitChatStarted = do
agentStarted <- asks agentAsync agentStarted <- asks agentAsync
atomically $ readTVar agentStarted >>= \a -> unless (isJust a) retry 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 :: Parser ChatCommand
chatCommandP = chatCommandP =
choice choice

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

@ -52,9 +52,13 @@ import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, fromTextField_, fstTo
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
import Simplex.Messaging.Version hiding (version) 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 :: Version
currentChatVersion = 5 currentChatVersion = 5
-- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above)
supportedChatVRange :: VersionRange supportedChatVRange :: VersionRange
supportedChatVRange = mkVersionRange 1 currentChatVersion supportedChatVRange = mkVersionRange 1 currentChatVersion

1
src/Simplex/Chat/Remote/Protocol.hs
View File

@ -38,7 +38,6 @@ import Simplex.Chat.Controller
import Simplex.Chat.Remote.Transport import Simplex.Chat.Remote.Transport
import Simplex.Chat.Remote.Types import Simplex.Chat.Remote.Types
import Simplex.FileTransfer.Description (FileDigest (..)) import Simplex.FileTransfer.Description (FileDigest (..))
import Simplex.Messaging.Agent.Client (agentDRG)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..))
import Simplex.Messaging.Crypto.Lazy (LazyByteString) import Simplex.Messaging.Crypto.Lazy (LazyByteString)

25
src/Simplex/Chat/Store/Connections.hs
View File

@ -35,9 +35,10 @@ import Simplex.Messaging.Agent.Protocol (ConnId)
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow) import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import Simplex.Messaging.Util (eitherToMaybe) import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version (VersionRange)
getConnectionEntity :: DB.Connection -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity getConnectionEntity :: DB.Connection -> VersionRange -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db user@User {userId, userContactId} agentConnId = do getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
c@Connection {connType, entityId} <- getConnection_ c@Connection {connType, entityId} <- getConnection_
case entityId of case entityId of
Nothing -> Nothing ->
@ -115,7 +116,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
(groupMemberId, userId, userContactId) (groupMemberId, userId, userContactId)
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember) toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
toGroupAndMember c (groupInfoRow :. memberRow) = toGroupAndMember c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = Just c}) in (groupInfo, (member :: GroupMember) {activeConn = Just c})
getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer 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_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
userContact_ _ = Left SEUserContactLinkNotFound userContact_ _ = Left SEUserContactLinkNotFound
getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity) getConnectionEntityByConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
getConnectionEntityByConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do getConnectionEntityByConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
connId_ <- connId_ <-
maybeFirstRow fromOnly $ maybeFirstRow fromOnly $
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2) 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: -- search connection for connection plan:
-- multiple connections can have same via_contact_uri_hash if request was repeated; -- 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; -- 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 -- deleted connections are filtered out to allow re-connecting via same contact address
getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity) getContactConnEntityByConnReqHash :: DB.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) = do getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2) = do
connId_ <- connId_ <-
maybeFirstRow fromOnly $ maybeFirstRow fromOnly $
DB.query DB.query
@ -183,14 +184,14 @@ getContactConnEntityByConnReqHash db user@User {userId} (cReqHash1, cReqHash2) =
) )
|] |]
(userId, cReqHash1, cReqHash2, ConnDeleted) (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.Connection -> VersionRange -> IO ([ConnId], [ConnectionEntity])
getConnectionsToSubscribe db = do getConnectionsToSubscribe db vr = do
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1" aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
entities <- forM aConnIds $ \acId -> do entities <- forM aConnIds $ \acId -> do
getUserByAConnId db acId >>= \case getUserByAConnId db acId >>= \case
Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db user acId) Just user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId)
Nothing -> pure Nothing Nothing -> pure Nothing
unsetConnectionToSubscribe db unsetConnectionToSubscribe db
let connIds = map (\(AgentConnId connId) -> connId) aConnIds let connIds = map (\(AgentConnId connId) -> connId) aConnIds

25
src/Simplex/Chat/Store/Files.hs
View File

@ -107,6 +107,7 @@ import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import qualified Simplex.Messaging.Crypto.File as CF import qualified Simplex.Messaging.Crypto.File as CF
import Simplex.Messaging.Protocol (SubscriptionMode (..)) import Simplex.Messaging.Protocol (SubscriptionMode (..))
import Simplex.Messaging.Version (VersionRange)
getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer] getLiveSndFileTransfers :: DB.Connection -> User -> IO [SndFileTransfer]
getLiveSndFileTransfers db User {userId} = do getLiveSndFileTransfers db User {userId} = do
@ -677,8 +678,8 @@ getRcvFileTransfer_ db userId fileId = do
_ -> pure Nothing _ -> pure Nothing
cancelled = fromMaybe False cancelled_ cancelled = fromMaybe False cancelled_
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> ConnStatus -> FilePath -> SubscriptionMode -> ExceptT StoreError IO AChatItem acceptRcvFileTransfer :: DB.Connection -> VersionRange -> 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 vr user@User {userId} fileId (cmdId, acId) connStatus filePath subMode = ExceptT $ do
currentTs <- getCurrentTime currentTs <- getCurrentTime
acceptRcvFT_ db user fileId filePath Nothing currentTs acceptRcvFT_ db user fileId filePath Nothing currentTs
DB.execute 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) (acId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs, subMode == SMOnlyCreate)
connId <- insertedRowId db connId <- insertedRowId db
setCommandConnId db user cmdId connId 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.Connection -> User -> FileTransferId -> ExceptT StoreError IO Contact
getContactByFileId db user@User {userId} fileId = do getContactByFileId db user@User {userId} fileId = do
@ -698,19 +699,19 @@ getContactByFileId db user@User {userId} fileId = do
ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $ ExceptT . firstRow fromOnly (SEContactNotFoundByFileId fileId) $
DB.query db "SELECT contact_id FROM files WHERE user_id = ? AND file_id = ?" (userId, 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.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db user fileId filePath = do acceptRcvInlineFT db vr user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath (Just IFMOffer) =<< getCurrentTime 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.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO ()
startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline = startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime acceptRcvFT_ db user fileId filePath rcvFileInline =<< getCurrentTime
xftpAcceptRcvFT :: DB.Connection -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem xftpAcceptRcvFT :: DB.Connection -> VersionRange -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
xftpAcceptRcvFT db user fileId filePath = do xftpAcceptRcvFT db vr user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath Nothing =<< getCurrentTime 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.Connection -> User -> FileTransferId -> FilePath -> Maybe InlineFileMode -> UTCTime -> IO ()
acceptRcvFT_ db User {userId} fileId filePath rcvFileInline currentTs = do 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 FileTransferMeta {filePath, xftpSndFile} <- getFileTransferMeta_ db userId fileId
pure $ CryptoFile filePath $ xftpSndFile >>= \f -> f.cryptoArgs pure $ CryptoFile filePath $ xftpSndFile >>= \f -> f.cryptoArgs
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRange -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
updateDirectCIFileStatus db user fileId fileStatus = do updateDirectCIFileStatus db vr user fileId fileStatus = do
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db user fileId aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db vr user fileId
case (cType, testEquality d $ msgDirection @d) of case (cType, testEquality d $ msgDirection @d) of
(SCTDirect, Just Refl) -> do (SCTDirect, Just Refl) -> do
liftIO $ updateCIFileStatus db user fileId fileStatus liftIO $ updateCIFileStatus db user fileId fileStatus

115
src/Simplex/Chat/Store/Groups.hs
View File

@ -128,7 +128,7 @@ import Data.Time.Clock (UTCTime (..), getCurrentTime)
import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), (:.) (..)) import Database.SQLite.Simple (NamedParam (..), Only (..), Query (..), (:.) (..))
import Database.SQLite.Simple.QQ (sql) import Database.SQLite.Simple.QQ (sql)
import Simplex.Chat.Messages 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.Direct
import Simplex.Chat.Store.Shared import Simplex.Chat.Store.Shared
import Simplex.Chat.Types 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)) 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 :: VersionRange -> Int64 -> GroupInfoRow -> GroupInfo
toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs) :. userMemberRow) = 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 supportedChatVRange} let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = JVersionRange vr}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences fullGroupPreferences = mergeGroupPreferences groupPreferences
groupProfile = GroupProfile {displayName, fullName, description, image, 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 = 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) 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.Connection -> User -> Int64 -> VersionRange -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember db User {userId, userContactId} groupMemberId = getGroupAndMember db User {userId, userContactId} groupMemberId vr =
ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $ ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
DB.query DB.query
db db
@ -289,13 +289,13 @@ getGroupAndMember db User {userId, userContactId} groupMemberId =
where where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) = toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
-- | creates completely new group with a single member - the current user -- | 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.Connection -> VersionRange -> TVar ChaChaDRG -> User -> GroupProfile -> Maybe Profile -> ExceptT StoreError IO GroupInfo
createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile
fullGroupPreferences = mergeGroupPreferences groupPreferences fullGroupPreferences = mergeGroupPreferences groupPreferences
currentTs <- getCurrentTime currentTs <- getCurrentTime
@ -313,18 +313,18 @@ createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = Except
(ldn, userId, profileId, True, currentTs, currentTs, currentTs) (ldn, userId, profileId, True, currentTs, currentTs, currentTs)
insertedRowId db insertedRowId db
memberId <- liftIO $ encodedRandomBytes gVar 12 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} 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} 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 -- | 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 :: DB.Connection -> VersionRange -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName 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 vr user@User {userId} contact@Contact {contactId, activeConn = Just hostConn@Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
liftIO getInvitationGroupId_ >>= \case liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_ Nothing -> createGroupInvitation_
Just gId -> do 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 hostId <- getHostMemberId_ db user gId
let GroupMember {groupMemberId, memberId, memberRole} = membership let GroupMember {groupMemberId, memberId, memberRole} = membership
MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember MemberIdRole {memberId = memberId', memberRole = memberRole'} = invitedMember
@ -360,7 +360,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo
insertedRowId db insertedRowId db
let JVersionRange hostVRange = hostConn.peerChatVRange let JVersionRange hostVRange = hostConn.peerChatVRange
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing currentTs hostVRange 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} 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) 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 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 createGroupInvitedViaLink
db db
vr
user@User {userId, userContactId} user@User {userId, userContactId}
Connection {connId, customUserProfileId} Connection {connId, customUserProfileId}
GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile} = do GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile} = do
@ -442,9 +443,9 @@ createGroupInvitedViaLink
hostMemberId <- insertHost_ currentTs groupId 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) 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 -- 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 liftIO $ setViaGroupLinkHash db groupId connId
(,) <$> getGroupInfo db user groupId <*> getGroupMemberById db user hostMemberId (,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db user hostMemberId
where where
insertGroup_ currentTs = ExceptT $ do insertGroup_ currentTs = ExceptT $ do
let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile 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 -- TODO return the last connection that is ready, not any last connection
-- requires updating connection status -- requires updating connection status
getGroup :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO Group getGroup :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db user groupId = do getGroup db vr user groupId = do
gInfo <- getGroupInfo db user groupId gInfo <- getGroupInfo db vr user groupId
members <- liftIO $ getGroupMembers db user gInfo members <- liftIO $ getGroupMembers db user gInfo
pure $ Group gInfo members pure $ Group gInfo members
@ -552,14 +553,14 @@ deleteGroupProfile_ db userId groupId =
|] |]
(userId, groupId) (userId, groupId)
getUserGroups :: DB.Connection -> User -> IO [Group] getUserGroups :: DB.Connection -> VersionRange -> User -> IO [Group]
getUserGroups db user@User {userId} = do getUserGroups db vr user@User {userId} = do
groupIds <- map fromOnly <$> DB.query db "SELECT group_id FROM groups WHERE user_id = ?" (Only userId) 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.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
getUserGroupDetails db User {userId, userContactId} _contactId_ search_ = getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ =
map (toGroupInfo userContactId) map (toGroupInfo vr userContactId)
<$> DB.query <$> DB.query
db db
[sql| [sql|
@ -577,9 +578,9 @@ getUserGroupDetails db User {userId, userContactId} _contactId_ search_ =
where where
search = fromMaybe "" search_ search = fromMaybe "" search_
getUserGroupsWithSummary :: DB.Connection -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)] getUserGroupsWithSummary :: DB.Connection -> VersionRange -> User -> Maybe ContactId -> Maybe String -> IO [(GroupInfo, GroupSummary)]
getUserGroupsWithSummary db user _contactId_ search_ = getUserGroupsWithSummary db vr user _contactId_ search_ =
getUserGroupDetails db user _contactId_ search_ getUserGroupDetails db vr user _contactId_ search_
>>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId) >>= mapM (\g@GroupInfo {groupId} -> (g,) <$> getGroupSummary db user groupId)
-- the statuses on non-current members should match memberCurrent' function -- 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} = 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) 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.Connection -> VersionRange -> User -> GroupName -> ExceptT StoreError IO GroupInfo
getGroupInfoByName db user gName = do getGroupInfoByName db vr user gName = do
gId <- getGroupIdByName db user gName gId <- getGroupIdByName db user gName
getGroupInfo db user gId getGroupInfo db vr user gId
groupMemberQuery :: Query groupMemberQuery :: Query
groupMemberQuery = groupMemberQuery =
@ -709,11 +710,11 @@ getGroupCurrentMembersCount db User {userId} GroupInfo {groupId} = do
(groupId, userId) (groupId, userId)
pure $ length $ filter memberCurrent' statuses pure $ length $ filter memberCurrent' statuses
getGroupInvitation :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation getGroupInvitation :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
getGroupInvitation db user groupId = getGroupInvitation db vr user groupId =
getConnRec_ user >>= \case getConnRec_ user >>= \case
Just connRequest -> do Just connRequest -> do
groupInfo@GroupInfo {membership} <- getGroupInfo db user groupId groupInfo@GroupInfo {membership} <- getGroupInfo db vr user groupId
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
hostId <- getHostMemberId_ db user groupId hostId <- getHostMemberId_ db user groupId
fromMember <- getGroupMember db user groupId hostId fromMember <- getGroupMember db user groupId hostId
@ -1005,8 +1006,8 @@ updateGroupMemberRole :: DB.Connection -> User -> GroupMember -> GroupMemberRole
updateGroupMemberRole db User {userId} GroupMember {groupMemberId} memRole = 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) 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.Connection -> Version -> [GroupMember] -> GroupMember -> IO [GroupMemberIntro]
createIntroductions db members toMember = do createIntroductions db chatV members toMember = do
let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members let reMembers = filter (\m -> memberCurrent m && groupMemberId' m /= groupMemberId' toMember) members
if null reMembers if null reMembers
then pure [] 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) (re_group_member_id, to_group_member_id, intro_status, intro_chat_protocol_version, created_at, updated_at)
VALUES (?,?,?,?,?,?) VALUES (?,?,?,?,?,?)
|] |]
(groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, currentChatVersion, ts, ts) (groupMemberId' reMember, groupMemberId' toMember, GMIntroPending, chatV, ts, ts)
introId <- insertedRowId db introId <- insertedRowId db
pure GroupMemberIntro {introId, reMember, toMember, introStatus = GMIntroPending, introInvitation = Nothing} 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.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 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.Connection -> VersionRange -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
getViaGroupMember db User {userId, userContactId} Contact {contactId} = getViaGroupMember db vr User {userId, userContactId} Contact {contactId} =
maybeFirstRow toGroupAndMember $ maybeFirstRow toGroupAndMember $
DB.query DB.query
db db
@ -1239,7 +1240,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} =
where where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember) toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) = toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow let groupInfo = toGroupInfo vr userContactId groupInfoRow
member = toGroupMember userContactId memberRow member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow}) in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
@ -1294,9 +1295,9 @@ updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, grou
(ldn, currentTs, userId, groupId) (ldn, currentTs, userId, groupId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId) 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.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db User {userId, userContactId} groupId = getGroupInfo db vr User {userId, userContactId} groupId =
ExceptT . firstRow (toGroupInfo userContactId) (SEGroupNotFound groupId) $ ExceptT . firstRow (toGroupInfo vr userContactId) (SEGroupNotFound groupId) $
DB.query DB.query
db db
[sql| [sql|
@ -1315,8 +1316,8 @@ getGroupInfo db User {userId, userContactId} groupId =
|] |]
(groupId, userId, userContactId) (groupId, userId, userContactId)
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo) getGroupInfoByUserContactLinkConnReq :: DB.Connection -> VersionRange -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSchema2) = do getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
groupId_ <- groupId_ <-
maybeFirstRow fromOnly $ maybeFirstRow fromOnly $
DB.query DB.query
@ -1327,10 +1328,10 @@ getGroupInfoByUserContactLinkConnReq db user@User {userId} (cReqSchema1, cReqSch
WHERE user_id = ? AND conn_req_contact IN (?,?) WHERE user_id = ? AND conn_req_contact IN (?,?)
|] |]
(userId, cReqSchema1, cReqSchema2) (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.Connection -> VersionRange -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
groupId_ <- groupId_ <-
maybeFirstRow fromOnly $ maybeFirstRow fromOnly $
DB.query DB.query
@ -1344,7 +1345,7 @@ getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1
LIMIT 1 LIMIT 1
|] |]
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted) (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.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
getGroupIdByName db User {userId} gName = getGroupIdByName db User {userId} gName =
@ -1356,8 +1357,8 @@ getGroupMemberIdByName db User {userId} groupId groupMemberName =
ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound 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) 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.Connection -> VersionRange -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
getActiveMembersByName db user@User {userId} groupMemberName = do getActiveMembersByName db vr user@User {userId} groupMemberName = do
groupMemberIds :: [(GroupId, GroupMemberId)] <- groupMemberIds :: [(GroupId, GroupMemberId)] <-
liftIO $ liftIO $
DB.query DB.query
@ -1370,7 +1371,7 @@ getActiveMembersByName db user@User {userId} groupMemberName = do
|] |]
(userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember) (userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember)
possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do
groupInfo <- getGroupInfo db user groupId groupInfo <- getGroupInfo db vr user groupId
groupMember <- getGroupMember db user groupId groupMemberId groupMember <- getGroupMember db user groupId groupMemberId
pure (groupInfo, groupMember) pure (groupInfo, groupMember)
pure $ sortOn (Down . ts . fst) possibleMembers pure $ sortOn (Down . ts . fst) possibleMembers
@ -1827,15 +1828,15 @@ createMemberContact
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn 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} 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.Connection -> VersionRange -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db user contactId = do getMemberContact db vr user contactId = do
ct <- getContact db user contactId ct <- getContact db user contactId
let Contact {contactGroupMemberId, activeConn} = ct let Contact {contactGroupMemberId, activeConn} = ct
case (activeConn, contactGroupMemberId) of case (activeConn, contactGroupMemberId) of
(Just Connection {connId}, Just groupMemberId) -> do (Just Connection {connId}, Just groupMemberId) -> do
cReq <- getConnReqInv db connId cReq <- getConnReqInv db connId
m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId
g <- getGroupInfo db user groupId g <- getGroupInfo db vr user groupId
pure (g, m, ct, cReq) pure (g, m, ct, cReq)
_ -> _ ->
throwError $ SEMemberContactGroupMemberNotFound contactId throwError $ SEMemberContactGroupMemberNotFound contactId

45
src/Simplex/Chat/Store/Messages.hs
View File

@ -134,6 +134,7 @@ import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..)) import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
import Simplex.Messaging.Util (eitherToMaybe) import Simplex.Messaging.Util (eitherToMaybe)
import Simplex.Messaging.Version (VersionRange)
import UnliftIO.STM import UnliftIO.STM
deleteContactCIs :: DB.Connection -> User -> Contact -> IO () deleteContactCIs :: DB.Connection -> User -> Contact -> IO ()
@ -461,8 +462,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
getChatPreviews :: DB.Connection -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat] getChatPreviews :: DB.Connection -> VersionRange -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
getChatPreviews db user withPCC pagination query = do getChatPreviews db vr user withPCC pagination query = do
directChats <- findDirectChatPreviews_ db user pagination query directChats <- findDirectChatPreviews_ db user pagination query
groupChats <- findGroupChatPreviews_ db user pagination query groupChats <- findGroupChatPreviews_ db user pagination query
cReqChats <- getContactRequestChatPreviews_ 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 :: AChatPreviewData -> ExceptT StoreError IO AChat
getChatPreview (ACPD cType cpd) = case cType of getChatPreview (ACPD cType cpd) = case cType of
SCTDirect -> getDirectChatPreview_ db user cpd SCTDirect -> getDirectChatPreview_ db user cpd
SCTGroup -> getGroupChatPreview_ db user cpd SCTGroup -> getGroupChatPreview_ db vr user cpd
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
SCTContactConnection -> let (ContactConnectionPD _ 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) ([":user_id" := userId, ":rcv_new" := CISRcvNew, ":search" := search] <> pagParams)
getGroupChatPreview_ :: DB.Connection -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat getGroupChatPreview_ :: DB.Connection -> VersionRange -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
getGroupChatPreview_ db user (GroupChatPD _ groupId lastItemId_ stats) = do getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
groupInfo <- getGroupInfo db user groupId groupInfo <- getGroupInfo db vr user groupId
lastItem <- case lastItemId_ of lastItem <- case lastItemId_ of
Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId Just lastItemId -> (: []) <$> getGroupChatItem db user groupId lastItemId
Nothing -> pure [] Nothing -> pure []
@ -874,10 +875,10 @@ getDirectChatBefore_ db User {userId} ct@Contact {contactId} beforeChatItemId co
|] |]
(userId, contactId, search, beforeChatItemId, count) (userId, contactId, search, beforeChatItemId, count)
getGroupChat :: DB.Connection -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup) getGroupChat :: DB.Connection -> VersionRange -> User -> Int64 -> ChatPagination -> Maybe String -> ExceptT StoreError IO (Chat 'CTGroup)
getGroupChat db user groupId pagination search_ = do getGroupChat db vr user groupId pagination search_ = do
let search = fromMaybe "" search_ let search = fromMaybe "" search_
g <- getGroupInfo db user groupId g <- getGroupInfo db vr user groupId
case pagination of case pagination of
CPLast count -> getGroupChatLast_ db user g count search CPLast count -> getGroupChatLast_ db user g count search
CPAfter afterId count -> getGroupChatAfter_ db user g afterId 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 :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] getAllChatItems :: DB.Connection -> VersionRange -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem]
getAllChatItems db user@User {userId} pagination search_ = do getAllChatItems db vr user@User {userId} pagination search_ = do
itemRefs <- itemRefs <-
rights . map toChatItemRef <$> case pagination of rights . map toChatItemRef <$> case pagination of
CPLast count -> liftIO $ getAllChatItemsLast_ count CPLast count -> liftIO $ getAllChatItemsLast_ count
CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId CPAfter afterId count -> liftIO . getAllChatItemsAfter_ afterId count . aChatItemTs =<< getAChatItem_ afterId
CPBefore beforeId count -> liftIO . getAllChatItemsBefore_ beforeId count . aChatItemTs =<< getAChatItem_ beforeId 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 where
search = fromMaybe "" search_ search = fromMaybe "" search_
getAChatItem_ itemId = do getAChatItem_ itemId = do
chatRef <- getChatRefViaItemId db user itemId chatRef <- getChatRefViaItemId db user itemId
getAChatItem db user chatRef itemId getAChatItem db vr user chatRef itemId
getAllChatItemsLast_ count = getAllChatItemsLast_ count =
reverse reverse
<$> DB.query <$> DB.query
@ -1713,8 +1714,8 @@ getGroupChatItemIdByText' db User {userId} groupId msg =
|] |]
(userId, groupId, msg <> "%") (userId, groupId, msg <> "%")
getChatItemByFileId :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO AChatItem getChatItemByFileId :: DB.Connection -> VersionRange -> User -> Int64 -> ExceptT StoreError IO AChatItem
getChatItemByFileId db user@User {userId} fileId = do getChatItemByFileId db vr user@User {userId} fileId = do
(chatRef, itemId) <- (chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $ ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $
DB.query DB.query
@ -1727,10 +1728,10 @@ getChatItemByFileId db user@User {userId} fileId = do
LIMIT 1 LIMIT 1
|] |]
(userId, fileId) (userId, fileId)
getAChatItem db user chatRef itemId getAChatItem db vr user chatRef itemId
getChatItemByGroupId :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO AChatItem getChatItemByGroupId :: DB.Connection -> VersionRange -> User -> GroupId -> ExceptT StoreError IO AChatItem
getChatItemByGroupId db user@User {userId} groupId = do getChatItemByGroupId db vr user@User {userId} groupId = do
(chatRef, itemId) <- (chatRef, itemId) <-
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $ ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $
DB.query DB.query
@ -1743,7 +1744,7 @@ getChatItemByGroupId db user@User {userId} groupId = do
LIMIT 1 LIMIT 1
|] |]
(userId, groupId) (userId, groupId)
getAChatItem db user chatRef itemId getAChatItem db vr user chatRef itemId
getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef
getChatRefViaItemId db User {userId} itemId = do getChatRefViaItemId db User {userId} itemId = do
@ -1755,14 +1756,14 @@ getChatRefViaItemId db User {userId} itemId = do
(Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId (Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId
(_, _) -> Left $ SEBadChatItem itemId (_, _) -> Left $ SEBadChatItem itemId
getAChatItem :: DB.Connection -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem getAChatItem :: DB.Connection -> VersionRange -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
getAChatItem db user chatRef itemId = case chatRef of getAChatItem db vr user chatRef itemId = case chatRef of
ChatRef CTDirect contactId -> do ChatRef CTDirect contactId -> do
ct <- getContact db user contactId ct <- getContact db user contactId
(CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId (CChatItem msgDir ci) <- getDirectChatItem db user contactId itemId
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
ChatRef CTGroup groupId -> do ChatRef CTGroup groupId -> do
gInfo <- getGroupInfo db user groupId gInfo <- getGroupInfo db vr user groupId
(CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId (CChatItem msgDir ci) <- getGroupChatItem db user groupId itemId
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) ci
_ -> throwError $ SEChatItemNotFound itemId _ -> throwError $ SEChatItemNotFound itemId

35
tests/ChatClient.hs
View File

@ -128,16 +128,43 @@ testCfg =
xftpFileConfig = Nothing 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 :: AgentConfig
testAgentCfgV1 = testAgentCfgV1 =
testAgentCfg testAgentCfg
{ smpClientVRange = mkVersionRange 1 1, { smpClientVRange = v1Range,
smpAgentVRange = mkVersionRange 1 1, smpAgentVRange = v1Range,
smpCfg = (smpCfg testAgentCfg) {serverVRange = mkVersionRange 1 1} e2eEncryptVRange = v1Range,
smpCfg = (smpCfg testAgentCfg) {serverVRange = v1Range}
}
testCfgVPrev :: ChatConfig
testCfgVPrev =
testCfg
{ chatVRange = prevRange $ chatVRange testCfg,
agentConfig = testAgentCfgVPrev
} }
testCfgV1 :: ChatConfig 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 :: ChatConfig
testCfgCreateGroupDirect = testCfgCreateGroupDirect =

49
tests/ChatTests/Groups.hs
View File

@ -24,8 +24,9 @@ import Test.Hspec
chatGroupTests :: SpecWith FilePath chatGroupTests :: SpecWith FilePath
chatGroupTests = do chatGroupTests = do
describe "chat groups" $ do describe "chat groups" $ do
it "add contacts, create group and send/receive messages" testGroup describe "add contacts, create group and send/receive messages" testGroupMatrix
it "add contacts, create group and send/receive messages, check messages" testGroupCheckMessages 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 group with incognito membership" testNewGroupIncognito
it "create and join group with 4 members" testGroup2 it "create and join group with 4 members" testGroup2
it "create and delete group" testGroupDelete it "create and delete group" testGroupDelete
@ -146,15 +147,19 @@ chatGroupTests = do
testGroup :: HasCallStack => FilePath -> IO () testGroup :: HasCallStack => FilePath -> IO ()
testGroup = testGroup =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $ 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 :: HasCallStack => FilePath -> IO ()
testGroupCheckMessages = testGroupCheckMessages =
testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $ 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 () testGroupMatrix :: SpecWith FilePath
testGroupShared alice bob cath checkMessages = do 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 bob
connectUsers alice cath connectUsers alice cath
alice ##> "/g team" alice ##> "/g team"
@ -206,7 +211,8 @@ testGroupShared alice bob cath checkMessages = do
(alice <# "#team cath> hey team") (alice <# "#team cath> hey team")
(bob <# "#team cath> hey team") (bob <# "#team cath> hey team")
msgItem2 <- lastItemId alice msgItem2 <- lastItemId alice
bob <##> cath when directConnections $
bob <##> cath
when checkMessages $ getReadChats msgItem1 msgItem2 when checkMessages $ getReadChats msgItem1 msgItem2
-- list groups -- list groups
alice ##> "/gs" alice ##> "/gs"
@ -263,17 +269,34 @@ testGroupShared alice bob cath checkMessages = do
(cath </) (cath </)
cath ##> "#team hello" cath ##> "#team hello"
cath <## "you are no longer a member of the group" cath <## "you are no longer a member of the group"
bob <##> cath when directConnections $
bob <##> cath
-- delete contact -- delete contact
alice ##> "/d bob" alice ##> "/d bob"
alice <## "bob: contact is deleted" alice <## "bob: contact is deleted"
bob <## "alice (Alice) deleted contact with you" bob <## "alice (Alice) deleted contact with you"
alice `send` "@bob hey" alice `send` "@bob hey"
alice if directConnections
<### [ "@bob hey", then
"member #team bob does not have direct connection, creating", alice
"peer chat protocol version range incompatible" <### [ "@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 when checkMessages $ threadDelay 1000000
alice #> "#team checking connection" alice #> "#team checking connection"
bob <# "#team alice> checking connection" bob <# "#team alice> checking connection"

22
tests/ChatTests/Utils.hs
View File

@ -69,20 +69,22 @@ ifCI xrun run d t = do
versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath versionTestMatrix2 :: (HasCallStack => TestCC -> TestCC -> IO ()) -> SpecWith FilePath
versionTestMatrix2 runTest = do 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" $ testChatCfg2 testCfgV1 aliceProfile bobProfile runTest
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
-- versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath versionTestMatrix3 :: (HasCallStack => TestCC -> TestCC -> TestCC -> IO ()) -> SpecWith FilePath
-- versionTestMatrix3 runTest = do versionTestMatrix3 runTest = do
-- it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest it "current" $ testChat3 aliceProfile bobProfile cathProfile runTest
it "prev" $ testChatCfg3 testCfgVPrev aliceProfile bobProfile cathProfile runTest
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest it "prev to curr" $ runTestCfg3 testCfg testCfgVPrev testCfgVPrev runTest
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest it "curr+prev to curr" $ runTestCfg3 testCfg testCfg testCfgVPrev runTest
-- it "v2+v1 to v2" $ runTestCfg3 testCfg testCfg testCfgV1 runTest it "curr to prev" $ runTestCfg3 testCfgVPrev testCfg testCfg runTest
-- it "v2 to v1" $ runTestCfg3 testCfgV1 testCfg testCfg runTest it "curr+prev to prev" $ runTestCfg3 testCfgVPrev testCfg testCfgVPrev runTest
-- it "v2+v1 to v1" $ runTestCfg3 testCfgV1 testCfg testCfgV1 runTest
inlineCfg :: Integer -> ChatConfig inlineCfg :: Integer -> ChatConfig
inlineCfg n = testCfg {inlineFiles = defaultInlineFilesConfig {sendChunks = 0, offerChunks = n, receiveChunks = n}} inlineCfg n = testCfg {inlineFiles = defaultInlineFilesConfig {sendChunks = 0, offerChunks = n, receiveChunks = n}}