mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-06-07 11:02:45 +00:00
core: store context to pass configuration parameters (#7057)
* core: store context to pass configuration parameters * fix directory * fix test * comment * order --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny
@@ -204,7 +204,7 @@ linkCheckThread_ opts env@ServiceState {eventQ}
|
||||
threadDelay $ linkCheckInterval opts * 1000000
|
||||
u <- readTVarIO $ currentUser cc
|
||||
forM_ u $ \user ->
|
||||
withDB' "linkCheckThread" cc (\db -> getAllGroupRegs_ db user) >>= \case
|
||||
withDB' "linkCheckThread" cc (\db -> getAllGroupRegs_ db (storeCxt cc) user) >>= \case
|
||||
Left e -> logError $ "linkCheckThread error: " <> T.pack e
|
||||
Right grs -> forM_ grs $ \(gInfo, gr) ->
|
||||
unless (groupRemoved $ groupRegStatus gr) $
|
||||
@@ -462,7 +462,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
|
||||
getOwnerGroupMember :: GroupId -> GroupReg -> IO (Either String GroupMember)
|
||||
getOwnerGroupMember gId GroupReg {dbOwnerMemberId} = case dbOwnerMemberId of
|
||||
Just mId -> withDB "getGroupMember" cc $ \db -> withExceptT show $ getGroupMember db (vr cc) user gId mId
|
||||
Just mId -> withDB "getGroupMember" cc $ \db -> withExceptT show $ getGroupMember db (storeCxt cc) user gId mId
|
||||
Nothing -> pure $ Left "no owner member in group registration"
|
||||
|
||||
deServiceJoinedGroup :: ContactId -> GroupInfo -> GroupMember -> IO ()
|
||||
@@ -556,7 +556,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
Right (CRConnectionPlan _ _ (CPGroupLink (GLPKnown {groupInfo = g'}))) ->
|
||||
case dbOwnerMemberId gr of
|
||||
Just ownerGMId ->
|
||||
withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMember db (vr cc) user groupId ownerGMId) >>= \case
|
||||
withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case
|
||||
Right ownerMember
|
||||
| let GroupMember {memberRole = role} = ownerMember, role >= GROwner ->
|
||||
setGroupStatus notifyAdminUsers st env cc groupId (GRSPendingApproval n') (`updatedNotification` g')
|
||||
@@ -813,7 +813,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
_ -> False
|
||||
checkValidOwner dbOwnerMemberId owners onValid = case dbOwnerMemberId of
|
||||
Just ownerGMId ->
|
||||
withDB "checkGroupLink" cc (\db -> withExceptT show $ getGroupMember db (vr cc) user groupId ownerGMId) >>= \case
|
||||
withDB "checkGroupLink" cc (\db -> withExceptT show $ getGroupMember db (storeCxt cc) user groupId ownerGMId) >>= \case
|
||||
Right GroupMember {memberId, memberPubKey}
|
||||
| any (\GroupLinkOwner {memberId = mId, memberKey} -> memberId == mId && memberPubKey == Just memberKey) owners -> onValid
|
||||
_ -> setGroupStatus logError st env cc groupId GRSSuspendedBadRoles $ \gr' ->
|
||||
@@ -985,7 +985,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
addGroupReg notifyAdminUsers st cc ct gInfo GRSProposed $ \_ -> pure ()
|
||||
sendChatCmd cc (APIConnectPreparedGroup gId False (Just ownerContact) Nothing) >>= \case
|
||||
Right CRStartedConnectionToGroup {groupInfo = gInfo'} ->
|
||||
withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (vr cc) user gInfo' mId) >>= \case
|
||||
withDB "getGroupMember" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (storeCxt cc) user gInfo' mId) >>= \case
|
||||
Right ownerMember ->
|
||||
void $ setGroupRegOwner cc gId ownerMember
|
||||
Left e -> do
|
||||
@@ -998,7 +998,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
deReregistration ct g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup = pg_}} profileChanged LinkOwnerSig {ownerId = Just (B64UrlByteString oIdBytes)} = do
|
||||
let mId = MemberId oIdBytes
|
||||
gt = maybe "group" groupTypeStr' pg_
|
||||
withDB "getGroupMemberByMemberId" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (vr cc) user g mId) >>= \case
|
||||
withDB "getGroupMemberByMemberId" cc (\db -> withExceptT show $ getGroupMemberByMemberId db (storeCxt cc) user g mId) >>= \case
|
||||
Right ownerMember@GroupMember {memberRole = role, memberStatus} ->
|
||||
if
|
||||
| role >= GROwner && memberStatus /= GSMemUnknown ->
|
||||
@@ -1451,7 +1451,7 @@ directoryServiceEvent st opts@DirectoryOpts {adminUsers, superUsers, serviceName
|
||||
getOwnersInfo :: [(GroupInfo, GroupReg)] -> IO [((GroupInfo, GroupReg), Maybe (Either String Contact))]
|
||||
getOwnersInfo gs =
|
||||
fmap (either (\e -> map (,Just (Left e)) gs) id) $ withDB' "getOwnersInfo" cc $ \db ->
|
||||
mapM (\g@(_, gr) -> fmap ((g,) . Just . first show) $ runExceptT $ getContact db (vr cc) user $ dbContactId gr) gs
|
||||
mapM (\g@(_, gr) -> fmap ((g,) . Just . first show) $ runExceptT $ getContact db (storeCxt cc) user $ dbContactId gr) gs
|
||||
|
||||
sendGroupsInfo :: Contact -> ChatItemId -> Bool -> ([(GroupInfo, GroupReg)], Int) -> IO ()
|
||||
sendGroupsInfo ct ciId isAdmin (gs, n) = do
|
||||
@@ -1519,7 +1519,7 @@ updateGroupListingFiles cc u dir =
|
||||
Left e -> logError $ "generateListing error: failed to read groups: " <> T.pack e
|
||||
|
||||
getContact' :: ChatController -> User -> ContactId -> IO (Either String Contact)
|
||||
getContact' cc user ctId = withDB "getContact" cc $ \db -> withExceptT show $ getContact db (vr cc) user ctId
|
||||
getContact' cc user ctId = withDB "getContact" cc $ \db -> withExceptT show $ getContact db (storeCxt cc) user ctId
|
||||
|
||||
getGroupLink' :: ChatController -> User -> GroupInfo -> IO (Either String GroupLink)
|
||||
getGroupLink' cc user gInfo =
|
||||
|
||||
@@ -85,7 +85,6 @@ import Data.Time.Clock.System (systemEpochDay)
|
||||
import Directory.Search
|
||||
import Directory.Util
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Protocol (supportedChatVRange)
|
||||
import Simplex.Chat.Options.DB (FromField (..), ToField (..))
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Store.Groups
|
||||
@@ -315,28 +314,28 @@ getGroupReg_ db gId =
|
||||
getGroupAndReg :: ChatController -> User -> GroupId -> IO (Either String (GroupInfo, GroupReg))
|
||||
getGroupAndReg cc user@User {userId, userContactId} gId =
|
||||
withDB "getGroupAndReg" cc $ \db ->
|
||||
ExceptT $ firstRow (toGroupInfoReg (vr cc) user) ("group " ++ show gId ++ " not found") $
|
||||
ExceptT $ firstRow (toGroupInfoReg (storeCxt cc) user) ("group " ++ show gId ++ " not found") $
|
||||
DB.query db (groupReqQuery <> " AND g.group_id = ?") (userId, userContactId, gId)
|
||||
|
||||
getUserGroupReg :: ChatController -> User -> ContactId -> UserGroupRegId -> IO (Either String (GroupInfo, GroupReg))
|
||||
getUserGroupReg cc user@User {userId, userContactId} ctId ugrId =
|
||||
withDB "getUserGroupReg" cc $ \db ->
|
||||
ExceptT $ firstRow (toGroupInfoReg (vr cc) user) ("group " ++ show ugrId ++ " not found") $
|
||||
ExceptT $ firstRow (toGroupInfoReg (storeCxt cc) user) ("group " ++ show ugrId ++ " not found") $
|
||||
DB.query db (groupReqQuery <> " AND r.contact_id = ? AND r.user_group_reg_id = ?") (userId, userContactId, ctId, ugrId)
|
||||
|
||||
getUserGroupRegs :: ChatController -> User -> ContactId -> IO (Either String [(GroupInfo, GroupReg)])
|
||||
getUserGroupRegs cc user@User {userId, userContactId} ctId =
|
||||
withDB' "getUserGroupRegs" cc $ \db ->
|
||||
map (toGroupInfoReg (vr cc) user)
|
||||
map (toGroupInfoReg (storeCxt cc) user)
|
||||
<$> DB.query db (groupReqQuery <> " AND r.contact_id = ? ORDER BY r.user_group_reg_id") (userId, userContactId, ctId)
|
||||
|
||||
getAllListedGroups :: ChatController -> User -> IO (Either String [(GroupInfo, GroupReg, Maybe GroupLink)])
|
||||
getAllListedGroups cc user = withDB' "getAllListedGroups" cc $ \db -> getAllListedGroups_ db (vr cc) user
|
||||
getAllListedGroups cc user = withDB' "getAllListedGroups" cc $ \db -> getAllListedGroups_ db (storeCxt cc) user
|
||||
|
||||
getAllListedGroups_ :: DB.Connection -> VersionRangeChat -> User -> IO [(GroupInfo, GroupReg, Maybe GroupLink)]
|
||||
getAllListedGroups_ db vr' user@User {userId, userContactId} =
|
||||
getAllListedGroups_ :: DB.Connection -> StoreCxt -> User -> IO [(GroupInfo, GroupReg, Maybe GroupLink)]
|
||||
getAllListedGroups_ db cxt user@User {userId, userContactId} =
|
||||
DB.query db (groupReqQuery <> " AND r.group_reg_status = ?") (userId, userContactId, GRSActive)
|
||||
>>= mapM (withGroupLink . toGroupInfoReg vr' user)
|
||||
>>= mapM (withGroupLink . toGroupInfoReg cxt user)
|
||||
where
|
||||
withGroupLink (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g)
|
||||
|
||||
@@ -382,7 +381,7 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa
|
||||
countQuery' = countQuery <> " JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id WHERE r.group_reg_status = ? "
|
||||
orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC "
|
||||
where
|
||||
groups = (map (toGroupInfoReg (vr cc) user) <$>)
|
||||
groups = (map (toGroupInfoReg (storeCxt cc) user) <$>)
|
||||
count = maybeFirstRow' 0 fromOnly
|
||||
listedGroupQuery = groupReqQuery <> " AND r.group_reg_status = ? "
|
||||
countQuery = "SELECT COUNT(1) FROM groups g JOIN sx_directory_group_regs r ON g.group_id = r.group_id "
|
||||
@@ -395,22 +394,22 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa
|
||||
)
|
||||
|]
|
||||
|
||||
getAllGroupRegs_ :: DB.Connection -> User -> IO [(GroupInfo, GroupReg)]
|
||||
getAllGroupRegs_ db user@User {userId, userContactId} =
|
||||
map (toGroupInfoReg supportedChatVRange user)
|
||||
getAllGroupRegs_ :: DB.Connection -> StoreCxt -> User -> IO [(GroupInfo, GroupReg)]
|
||||
getAllGroupRegs_ db cxt user@User {userId, userContactId} =
|
||||
map (toGroupInfoReg cxt user)
|
||||
<$> DB.query db groupReqQuery (userId, userContactId)
|
||||
|
||||
getDuplicateGroupRegs :: ChatController -> User -> Text -> IO (Either String [(GroupInfo, GroupReg)])
|
||||
getDuplicateGroupRegs cc user@User {userId, userContactId} displayName =
|
||||
withDB' "getDuplicateGroupRegs" cc $ \db ->
|
||||
map (toGroupInfoReg (vr cc) user)
|
||||
map (toGroupInfoReg (storeCxt cc) user)
|
||||
<$> DB.query db (groupReqQuery <> " AND gp.display_name = ?") (userId, userContactId, displayName)
|
||||
|
||||
listLastGroups :: ChatController -> User -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int))
|
||||
listLastGroups cc user@User {userId, userContactId} count =
|
||||
withDB' "getUserGroupRegs" cc $ \db -> do
|
||||
gs <-
|
||||
map (toGroupInfoReg (vr cc) user)
|
||||
map (toGroupInfoReg (storeCxt cc) user)
|
||||
<$> DB.query db (groupReqQuery <> " ORDER BY group_reg_id DESC LIMIT ?") (userId, userContactId, count)
|
||||
n <- maybeFirstRow' 0 fromOnly $ DB.query_ db "SELECT COUNT(1) FROM sx_directory_group_regs"
|
||||
pure (gs, n)
|
||||
@@ -419,14 +418,14 @@ listPendingGroups :: ChatController -> User -> Int -> IO (Either String ([(Group
|
||||
listPendingGroups cc user@User {userId, userContactId} count =
|
||||
withDB' "getUserGroupRegs" cc $ \db -> do
|
||||
gs <-
|
||||
map (toGroupInfoReg (vr cc) user)
|
||||
map (toGroupInfoReg (storeCxt cc) user)
|
||||
<$> DB.query db (groupReqQuery <> " AND r.group_reg_status LIKE 'pending_approval%' ORDER BY group_reg_id DESC LIMIT ?") (userId, userContactId, count)
|
||||
n <- maybeFirstRow' 0 fromOnly $ DB.query_ db "SELECT COUNT(1) FROM sx_directory_group_regs WHERE group_reg_status LIKE 'pending_approval%'"
|
||||
pure (gs, n)
|
||||
|
||||
toGroupInfoReg :: VersionRangeChat -> User -> (GroupInfoRow :. GroupRegRow) -> (GroupInfo, GroupReg)
|
||||
toGroupInfoReg vr' User {userContactId} (groupRow :. grRow) =
|
||||
(toGroupInfo vr' userContactId [] groupRow, rowToGroupReg grRow)
|
||||
toGroupInfoReg :: StoreCxt -> User -> (GroupInfoRow :. GroupRegRow) -> (GroupInfo, GroupReg)
|
||||
toGroupInfoReg cxt User {userContactId} (groupRow :. grRow) =
|
||||
(toGroupInfo cxt userContactId [] groupRow, rowToGroupReg grRow)
|
||||
|
||||
type GroupRegRow = (GroupId, UserGroupRegId, ContactId, Maybe GroupMemberId, GroupRegStatus, BoolInt, UTCTime)
|
||||
|
||||
|
||||
@@ -18,10 +18,9 @@ import Directory.Listing
|
||||
import Directory.Options
|
||||
import Directory.Store
|
||||
import Simplex.Chat (createChatDatabase)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..))
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatDatabase (..), mkStoreCxt)
|
||||
import Simplex.Chat.Options (CoreChatOpts (..))
|
||||
import Simplex.Chat.Options.DB
|
||||
import Simplex.Chat.Protocol (supportedChatVRange)
|
||||
import Simplex.Chat.Store.Groups (getHostMember)
|
||||
import Simplex.Chat.Store.Profiles (getUsers)
|
||||
import Simplex.Chat.Store.Shared (getGroupInfo)
|
||||
@@ -62,7 +61,7 @@ checkDirectoryLog opts cfg =
|
||||
runDirectoryMigrations opts cfg st
|
||||
gs <- readDirectoryLogData logFile
|
||||
withActiveUser st $ \user -> withTransaction st $ \db -> do
|
||||
mapM_ (verifyGroupRegistration db user) gs
|
||||
mapM_ (verifyGroupRegistration (mkStoreCxt cfg) db user) gs
|
||||
putStrLn $ show (length gs) <> " group registrations OK"
|
||||
|
||||
importDirectoryLogToDB :: DirectoryOpts -> ChatConfig -> IO ()
|
||||
@@ -73,7 +72,7 @@ importDirectoryLogToDB opts cfg = do
|
||||
ctRegs <- TM.emptyIO
|
||||
withActiveUser st $ \user -> withTransaction st $ \db -> do
|
||||
forM_ gs $ \gr ->
|
||||
whenM (verifyGroupRegistration db user gr) $ do
|
||||
whenM (verifyGroupRegistration (mkStoreCxt cfg) db user gr) $ do
|
||||
putStrLn $ "importing group " <> show (dbGroupId gr)
|
||||
insertGroupReg db =<< fixUserGroupRegId ctRegs gr
|
||||
renamePath logFile (logFile ++ ".bak")
|
||||
@@ -101,28 +100,28 @@ exportDBToDirectoryLog opts cfg =
|
||||
runDirectoryMigrations opts cfg st
|
||||
withActiveUser st $ \user -> do
|
||||
gs <- withFile logFile WriteMode $ \h -> withTransaction st $ \db -> do
|
||||
gs <- getAllGroupRegs_ db user
|
||||
gs <- getAllGroupRegs_ db (mkStoreCxt cfg) user
|
||||
forM_ gs $ \(_, gr) ->
|
||||
whenM (verifyGroupRegistration db user gr) $
|
||||
whenM (verifyGroupRegistration (mkStoreCxt cfg) db user gr) $
|
||||
B.hPutStrLn h $ strEncode $ GRCreate gr
|
||||
pure gs
|
||||
putStrLn $ show (length gs) <> " group registrations exported"
|
||||
|
||||
saveGroupListingFiles :: DirectoryOpts -> ChatConfig -> IO ()
|
||||
saveGroupListingFiles opts _cfg = case webFolder opts of
|
||||
saveGroupListingFiles opts cfg = case webFolder opts of
|
||||
Nothing -> exit "use --web-folder to generate listings"
|
||||
Just dir ->
|
||||
withChatStore opts $ \st -> withActiveUser st $ \user ->
|
||||
withTransaction st $ \db ->
|
||||
getAllListedGroups_ db supportedChatVRange user >>= generateListing dir
|
||||
getAllListedGroups_ db (mkStoreCxt cfg) user >>= generateListing dir
|
||||
|
||||
verifyGroupRegistration :: DB.Connection -> User -> GroupReg -> IO Bool
|
||||
verifyGroupRegistration db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} =
|
||||
runExceptT (getGroupInfo db supportedChatVRange user gId) >>= \case
|
||||
verifyGroupRegistration :: StoreCxt -> DB.Connection -> User -> GroupReg -> IO Bool
|
||||
verifyGroupRegistration cxt db user GroupReg {dbGroupId = gId, dbContactId = ctId, dbOwnerMemberId, groupRegStatus} =
|
||||
runExceptT (getGroupInfo db cxt user gId) >>= \case
|
||||
Left e -> False <$ putStrLn ("Error: loading group " <> show gId <> " (skipping): " <> show e)
|
||||
Right GroupInfo {localDisplayName} -> do
|
||||
let groupRef = show gId <> " " <> T.unpack localDisplayName
|
||||
runExceptT (getHostMember db supportedChatVRange user gId) >>= \case
|
||||
runExceptT (getHostMember db cxt user gId) >>= \case
|
||||
Left e -> False <$ putStrLn ("Error: loading host member of group " <> groupRef <> " (skipping): " <> show e)
|
||||
Right GroupMember {groupMemberId = mId', memberContactId = ctId'} -> case dbOwnerMemberId of
|
||||
Nothing -> True <$ putStrLn ("Warning: group " <> groupRef <> " has no owner member ID, host member ID is " <> show mId' <> ", registration status: " <> B.unpack (strEncode groupRegStatus))
|
||||
|
||||
@@ -15,9 +15,9 @@ import Simplex.Messaging.Agent.Store.Common (withTransaction)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Util (catchAll)
|
||||
|
||||
vr :: ChatController -> VersionRangeChat
|
||||
vr ChatController {config = ChatConfig {chatVRange}} = chatVRange
|
||||
{-# INLINE vr #-}
|
||||
storeCxt :: ChatController -> StoreCxt
|
||||
storeCxt ChatController {config} = mkStoreCxt config
|
||||
{-# INLINE storeCxt #-}
|
||||
|
||||
withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Either String a)
|
||||
withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
|
||||
|
||||
@@ -169,6 +169,12 @@ data ChatConfig = ChatConfig
|
||||
chatHooks :: ChatHooks
|
||||
}
|
||||
|
||||
-- | Builds the read-only context threaded through store functions from chat config.
|
||||
-- The single construction point, so new store-wide config (e.g. server keys) is added in one place.
|
||||
mkStoreCxt :: ChatConfig -> StoreCxt
|
||||
mkStoreCxt ChatConfig {chatVRange} = StoreCxt chatVRange
|
||||
{-# INLINE mkStoreCxt #-}
|
||||
|
||||
data RandomAgentServers = RandomAgentServers
|
||||
{ smpServers :: NonEmpty (ServerCfg 'PSMP),
|
||||
xftpServers :: NonEmpty (ServerCfg 'PXFTP)
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -473,12 +473,12 @@ deleteGroupCIs user gInfo chatScopeInfo items byGroupMember_ deletedTs = do
|
||||
deleteCIFiles user ciFilesInfo
|
||||
(errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items)
|
||||
unless (null errs) $ toView $ CEvtChatErrors errs
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
deletions' <- case chatScopeInfo of
|
||||
Nothing -> pure deletions
|
||||
Just scopeInfo@GCSIMemberSupport {groupMember_} -> do
|
||||
let decStats = countDeletedUnreadItems groupMember_ deletions
|
||||
gInfo' <- withFastStore' $ \db -> updateGroupScopeUnreadStats db vr user gInfo scopeInfo decStats
|
||||
gInfo' <- withFastStore' $ \db -> updateGroupScopeUnreadStats db cxt user gInfo scopeInfo decStats
|
||||
pure $ map (updateDeletionGroupInfo gInfo') deletions
|
||||
pure deletions'
|
||||
where
|
||||
@@ -689,7 +689,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
unless (fileStatus == RFSNew) $ case fileStatus of
|
||||
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
|
||||
_ -> throwChatError $ CEFileAlreadyReceiving fName
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
case (xftpRcvFile, fileConnReq) of
|
||||
-- XFTP
|
||||
(Just XFTPRcvFile {userApprovedRelays = approvedBeforeReady}, _) -> do
|
||||
@@ -698,7 +698,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
(ci, rfd) <- withStore $ \db -> do
|
||||
-- marking file as accepted and reading description in the same transaction
|
||||
-- to prevent race condition with appending description
|
||||
ci <- xftpAcceptRcvFT db vr user fileId filePath userApproved
|
||||
ci <- xftpAcceptRcvFT db cxt user fileId filePath userApproved
|
||||
rfd <- getRcvFileDescrByRcvFileId db fileId
|
||||
pure (ci, rfd)
|
||||
receiveViaCompleteFD user fileId rfd userApproved cryptoArgs
|
||||
@@ -709,10 +709,10 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
chatRef <- withStore $ \db -> getChatRefByFileId db user fileId
|
||||
case (chatRef, grpMemberId) of
|
||||
(ChatRef CTDirect contactId _, Nothing) -> do
|
||||
ct <- withStore $ \db -> getContact db vr user contactId
|
||||
ct <- withStore $ \db -> getContact db cxt user contactId
|
||||
acceptFile $ \msg -> void $ sendDirectContactMessage user ct msg
|
||||
(ChatRef CTGroup groupId _, Just memId) -> do
|
||||
GroupMember {activeConn} <- withStore $ \db -> getGroupMember db vr user groupId memId
|
||||
GroupMember {activeConn} <- withStore $ \db -> getGroupMember db cxt user groupId memId
|
||||
case activeConn of
|
||||
Just conn -> do
|
||||
acceptFile $ \msg -> void $ sendDirectMemberMessage conn msg groupId
|
||||
@@ -723,12 +723,12 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
acceptFile send = do
|
||||
filePath <- getRcvFilePath fileId filePath_ fName True
|
||||
inline <- receiveInline
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
if
|
||||
| inline -> do
|
||||
-- accepting inline
|
||||
(ci, sharedMsgId) <- withStore $ \db ->
|
||||
liftM2 (,) (acceptRcvInlineFT db vr user fileId filePath) (getSharedMsgIdByFileId db userId fileId)
|
||||
liftM2 (,) (acceptRcvInlineFT db cxt user fileId filePath) (getSharedMsgIdByFileId db userId fileId)
|
||||
send $ XFileAcptInv sharedMsgId Nothing fName
|
||||
pure ci
|
||||
| fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName
|
||||
@@ -804,13 +804,13 @@ getNetworkConfig = withAgent' $ liftIO . getFastNetworkConfig
|
||||
|
||||
resetRcvCIFileStatus :: User -> FileTransferId -> CIFileStatus 'MDRcv -> CM (Maybe AChatItem)
|
||||
resetRcvCIFileStatus user fileId ciFileStatus = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
withStore $ \db -> do
|
||||
liftIO $ do
|
||||
updateCIFileStatus db user fileId ciFileStatus
|
||||
updateRcvFileStatus db fileId FSNew
|
||||
updateRcvFileAgentId db fileId Nothing
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
|
||||
receiveViaURI :: User -> FileDescriptionURI -> CryptoFile -> CM RcvFileTransfer
|
||||
receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile {cryptoArgs} = do
|
||||
@@ -828,11 +828,11 @@ receiveViaURI user@User {userId} FileDescriptionURI {description} cf@CryptoFile
|
||||
|
||||
startReceivingFile :: User -> FileTransferId -> CM ()
|
||||
startReceivingFile user fileId = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateRcvFileStatus db fileId FSConnected
|
||||
liftIO $ updateCIFileStatus db user fileId $ CIFSRcvTransfer 0 1
|
||||
getChatItemByFileId db vr user fileId
|
||||
getChatItemByFileId db cxt user fileId
|
||||
toView $ CEvtRcvFileStart user ci
|
||||
|
||||
getRcvFilePath :: FileTransferId -> Maybe FilePath -> String -> Bool -> CM FilePath
|
||||
@@ -883,8 +883,8 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let pqSup = PQSupportOn
|
||||
pqSup' = pqSup `CR.pqSupportAnd` pqSupport
|
||||
vr <- chatVersionRange
|
||||
let chatV = vr `peerConnChatVersion` cReqChatVRange
|
||||
cxt <- chatStoreCxt
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
(ct, conn, incognitoProfile) <- case contactId_ of
|
||||
Nothing -> do
|
||||
incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
|
||||
@@ -893,7 +893,7 @@ acceptContactRequest nm user@User {userId} UserContactRequest {agentInvitationId
|
||||
createContactFromRequest db user userContactLinkId_ connId chatV cReqChatVRange cName profileId cp xContactId incognitoProfile subMode pqSup' False
|
||||
pure (ct, conn, incognitoProfile)
|
||||
Just contactId -> do
|
||||
ct <- withFastStore $ \db -> getContact db vr user contactId
|
||||
ct <- withFastStore $ \db -> getContact db cxt user contactId
|
||||
case contactConn ct of
|
||||
Nothing -> do
|
||||
incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
|
||||
@@ -920,15 +920,15 @@ acceptContactRequestAsync
|
||||
incognitoProfile = do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let profileToSend = userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
|
||||
vr <- chatVersionRange
|
||||
let chatV = vr `peerConnChatVersion` cReqChatVRange
|
||||
cxt <- chatStoreCxt
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
(cmdId, acId) <- agentAcceptContactAsync user True cReqInvId (XInfo profileToSend) subMode cReqPQSup chatV
|
||||
currentTs <- liftIO getCurrentTime
|
||||
withStore $ \db -> do
|
||||
forM_ xContactId $ \xcId -> liftIO $ setContactAcceptedXContactId db ct xcId
|
||||
Connection {connId} <- liftIO $ createAcceptedContactConn db user (Just uclId) contactId acId chatV cReqChatVRange cReqPQSup incognitoProfile subMode currentTs
|
||||
liftIO $ setCommandConnId db user cmdId connId
|
||||
getContact db vr user contactId
|
||||
getContact db cxt user contactId
|
||||
|
||||
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> CM GroupMember
|
||||
acceptGroupJoinRequestAsync
|
||||
@@ -964,12 +964,12 @@ acceptGroupJoinRequestAsync
|
||||
groupSize = Just currentMemCount
|
||||
}
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
vr <- chatVersionRange
|
||||
let chatV = vr `peerConnChatVersion` cReqChatVRange
|
||||
cxt <- chatStoreCxt
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
|
||||
withStore $ \db -> do
|
||||
liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
|
||||
getGroupMemberById db vr user groupMemberId
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
|
||||
acceptGroupJoinSendRejectAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> GroupRejectionReason -> CM GroupMember
|
||||
acceptGroupJoinSendRejectAsync
|
||||
@@ -994,12 +994,12 @@ acceptGroupJoinSendRejectAsync
|
||||
rejectionReason
|
||||
}
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
vr <- chatVersionRange
|
||||
let chatV = vr `peerConnChatVersion` cReqChatVRange
|
||||
cxt <- chatStoreCxt
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
connIds <- agentAcceptContactAsync user False cReqInvId msg subMode PQSupportOff chatV
|
||||
withStore $ \db -> do
|
||||
liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
|
||||
getGroupMemberById db vr user groupMemberId
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
|
||||
acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
|
||||
acceptBusinessJoinRequestAsync
|
||||
@@ -1008,7 +1008,7 @@ acceptBusinessJoinRequestAsync
|
||||
gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}}
|
||||
clientMember@GroupMember {groupMemberId, memberId}
|
||||
UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId} = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
let userProfile@Profile {displayName, preferences} = fromLocalProfile $ profile' user
|
||||
-- TODO [short links] take groupPreferences from group info
|
||||
groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs preferences
|
||||
@@ -1027,7 +1027,7 @@ acceptBusinessJoinRequestAsync
|
||||
groupSize = Just 1
|
||||
}
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let chatV = vr `peerConnChatVersion` cReqChatVRange
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
|
||||
withStore' $ \db -> do
|
||||
forM_ xContactId $ \xcId -> setBusinessChatAcceptedXContactId db gInfo xcId
|
||||
@@ -1051,28 +1051,28 @@ acceptRelayJoinRequestAsync
|
||||
-- TODO [channel web] derive RelayCapabilities from relay config (RelayWebOptions)
|
||||
let msg = XGrpRelayAcpt relayLink defaultRelayCapabilities
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
vr <- chatVersionRange
|
||||
let chatV = vr `peerConnChatVersion` cReqChatVRange
|
||||
cxt <- chatStoreCxt
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
|
||||
withStore $ \db -> do
|
||||
liftIO $ createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
|
||||
gInfo' <- liftIO $ updateRelayOwnStatusFromTo db gInfo RSInvited RSAccepted
|
||||
ownerMember' <- getGroupMemberById db vr user groupMemberId
|
||||
ownerMember' <- getGroupMemberById db cxt user groupMemberId
|
||||
pure (gInfo', ownerMember')
|
||||
|
||||
rejectRelayInvitationAsync
|
||||
:: User
|
||||
-> Int64
|
||||
-> VersionRangeChat
|
||||
-> StoreCxt
|
||||
-> GroupRelayInvitation
|
||||
-> InvitationId
|
||||
-> VersionRangeChat
|
||||
-> Int64
|
||||
-> RelayRejectionReason
|
||||
-> CM ()
|
||||
rejectRelayInvitationAsync user uclId vr groupRelayInv invId reqChatVRange initialDelay reason = do
|
||||
rejectRelayInvitationAsync user uclId cxt groupRelayInv invId reqChatVRange initialDelay reason = do
|
||||
(_gInfo, ownerMember) <- withStore $ \db ->
|
||||
createRelayRequestGroup db vr user groupRelayInv invId reqChatVRange initialDelay GSMemInvited RSRejected
|
||||
createRelayRequestGroup db cxt user groupRelayInv invId reqChatVRange initialDelay GSMemInvited RSRejected
|
||||
let GroupMember {groupMemberId} = ownerMember
|
||||
msg = XGrpRelayReject reason
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
@@ -1086,15 +1086,15 @@ businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
|
||||
businessGroupProfile Profile {displayName, fullName, shortDescr, image} groupPreferences =
|
||||
GroupProfile {displayName, fullName, description = Nothing, shortDescr, image, publicGroup = Nothing, groupPreferences = Just groupPreferences, memberAdmission = Nothing}
|
||||
|
||||
introduceToModerators :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToModerators vr user gInfo@GroupInfo {groupId} m@GroupMember {memberRole, memberId} = do
|
||||
introduceToModerators :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToModerators cxt user gInfo@GroupInfo {groupId} m@GroupMember {memberRole, memberId} = do
|
||||
forM_ (memberConn m) $ \mConn -> do
|
||||
let msg =
|
||||
if maxVersion (memberChatVRange m) >= groupKnockingVersion
|
||||
then XGrpLinkAcpt GAPendingReview memberRole memberId
|
||||
else XMsgNew $ mcSimple (MCText pendingReviewMessage)
|
||||
void $ sendDirectMemberMessage mConn msg groupId
|
||||
modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo
|
||||
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
let rcpModMs = filter shouldIntroduceToMod modMs
|
||||
introduceMember user gInfo m rcpModMs (Just $ MSMember $ memberId' m)
|
||||
where
|
||||
@@ -1104,15 +1104,15 @@ introduceToModerators vr user gInfo@GroupInfo {groupId} m@GroupMember {memberRol
|
||||
&& groupMemberId' mem /= groupMemberId' m
|
||||
&& maxVersion (memberChatVRange mem) >= groupKnockingVersion
|
||||
|
||||
introduceToAll :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToAll vr user gInfo m = do
|
||||
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db vr user gInfo) (getMemberRelationsVector db m)
|
||||
introduceToAll :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToAll cxt user gInfo m = do
|
||||
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
|
||||
let recipients = filter (shouldIntroduce m vector) members
|
||||
introduceMember user gInfo m recipients Nothing
|
||||
|
||||
introduceToRemaining :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToRemaining vr user gInfo m = do
|
||||
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db vr user gInfo) (getMemberRelationsVector db m)
|
||||
introduceToRemaining :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceToRemaining cxt user gInfo m = do
|
||||
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
|
||||
let recipients = filter (shouldIntroduce m vector) members
|
||||
introduceMember user gInfo m recipients Nothing
|
||||
|
||||
@@ -1166,10 +1166,10 @@ memberIntroEvt gInfo reMember =
|
||||
-- Used in groups with relays to introduce moderators and above to a new member,
|
||||
-- and to announce the new member to moderators and above.
|
||||
-- This doesn't create introduction records in db, compared to above methods.
|
||||
introduceInChannel :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceInChannel :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
|
||||
introduceInChannel _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
|
||||
introduceInChannel vr user gInfo subscriber@GroupMember {activeConn = Just conn} = do
|
||||
modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo
|
||||
introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn} = do
|
||||
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
void $ sendGroupMessage' user gInfo modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
|
||||
let introEvts = map (memberIntroEvt gInfo) modMs
|
||||
forM_ (L.nonEmpty introEvts) $ \introEvts' ->
|
||||
@@ -1328,9 +1328,9 @@ setGroupLinkData' nm user gInfo =
|
||||
|
||||
setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM GroupLink
|
||||
setGroupLinkData nm user gInfo gLink = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
(conn, groupRelays) <- withFastStore $ \db ->
|
||||
(,) <$> getGroupLinkConnection db vr user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
|
||||
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
|
||||
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
|
||||
linkType = if useRelays' gInfo then CCTChannel else CCTGroup
|
||||
sLnk <- shortenShortLink' . setShortLinkType_ linkType =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData))
|
||||
@@ -1338,17 +1338,17 @@ setGroupLinkData nm user gInfo gLink = do
|
||||
|
||||
setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
|
||||
setGroupLinkDataAsync user gInfo gLink = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
(conn, groupRelays) <- withStore $ \db ->
|
||||
(,) <$> getGroupLinkConnection db vr user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
|
||||
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
|
||||
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
|
||||
setAgentConnShortLinkAsync user conn userLinkData (Just crClientData)
|
||||
|
||||
connectToRelayAsync :: User -> GroupInfo -> ShortLinkContact -> CM ()
|
||||
connectToRelayAsync user gInfo relayLink = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
gVar <- asks random
|
||||
relayMember@GroupMember {activeConn} <- withFastStore $ \db -> getCreateRelayForMember db vr gVar user gInfo relayLink
|
||||
relayMember@GroupMember {activeConn} <- withFastStore $ \db -> getCreateRelayForMember db cxt gVar user gInfo relayLink
|
||||
case activeConn of
|
||||
Just _ -> pure ()
|
||||
Nothing -> do
|
||||
@@ -1359,9 +1359,9 @@ connectToRelayAsync user gInfo relayLink = do
|
||||
updatePublicGroupData :: User -> GroupInfo -> CM GroupInfo
|
||||
updatePublicGroupData user gInfo
|
||||
| useRelays' gInfo && memberRole' (membership gInfo) == GROwner = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
(gInfo', gLink) <- withStore $ \db -> do
|
||||
gInfo' <- updatePublicMemberCount db vr user gInfo
|
||||
gInfo' <- updatePublicMemberCount db cxt user gInfo
|
||||
gLink <- getGroupLink db user gInfo'
|
||||
pure (gInfo', gLink)
|
||||
setGroupLinkDataAsync user gInfo' gLink
|
||||
@@ -1371,12 +1371,12 @@ updatePublicGroupData user gInfo
|
||||
updateGroupFromLinkData :: User -> GroupInfo -> GroupShortLinkData -> CM (GroupInfo, Bool)
|
||||
updateGroupFromLinkData user gInfo@GroupInfo {groupProfile = p, groupSummary = GroupSummary {publicMemberCount = localCount}} GroupShortLinkData {groupProfile, publicGroupData}
|
||||
| profileChanged || countChanged = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
withStore $ \db -> do
|
||||
g <- if profileChanged then updateGroupProfile db user gInfo groupProfile else pure gInfo
|
||||
g' <- case publicGroupData of
|
||||
Just PublicGroupData {publicMemberCount} | countChanged ->
|
||||
setPublicMemberCount db vr user g publicMemberCount
|
||||
setPublicMemberCount db cxt user g publicMemberCount
|
||||
_ -> pure g
|
||||
pure (g', profileChanged)
|
||||
| otherwise = pure (gInfo, False)
|
||||
@@ -1455,14 +1455,14 @@ shortenCreatedLink (CCLink cReq sLnk) = CCLink cReq <$> mapM shortenShortLink' s
|
||||
|
||||
deleteGroupLink' :: User -> GroupInfo -> CM ()
|
||||
deleteGroupLink' user gInfo = do
|
||||
vr <- chatVersionRange
|
||||
conn <- withStore $ \db -> getGroupLinkConnection db vr user gInfo
|
||||
cxt <- chatStoreCxt
|
||||
conn <- withStore $ \db -> getGroupLinkConnection db cxt user gInfo
|
||||
deleteGroupLink_ user gInfo conn
|
||||
|
||||
deleteGroupLinkIfExists :: User -> GroupInfo -> CM ()
|
||||
deleteGroupLinkIfExists user gInfo = do
|
||||
vr <- chatVersionRange
|
||||
conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db vr user gInfo)
|
||||
cxt <- chatStoreCxt
|
||||
conn_ <- eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupLinkConnection db cxt user gInfo)
|
||||
mapM_ (deleteGroupLink_ user gInfo) conn_
|
||||
|
||||
deleteGroupLink_ :: User -> GroupInfo -> Connection -> CM ()
|
||||
@@ -1497,16 +1497,16 @@ deleteTimedItem user (ChatRef cType chatId scope, itemId) deleteAt = do
|
||||
ts <- liftIO getCurrentTime
|
||||
liftIO $ threadDelay' $ diffToMicroseconds $ diffUTCTime deleteAt ts
|
||||
lift waitChatStartedAndActivated
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
case cType of
|
||||
CTDirect -> do
|
||||
(ct, ci) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId
|
||||
(ct, ci) <- withStore $ \db -> (,) <$> getContact db cxt user chatId <*> getDirectChatItem db user chatId itemId
|
||||
deletions <- deleteDirectCIs user ct [ci]
|
||||
toView $ CEvtChatItemsDeleted user deletions True True
|
||||
CTGroup -> do
|
||||
(gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId
|
||||
(gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db cxt user chatId <*> getGroupChatItem db user chatId itemId
|
||||
deletedTs <- liftIO getCurrentTime
|
||||
chatScopeInfo <- mapM (getChatScopeInfo vr user) scope
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
deletions <- deleteGroupCIs user gInfo chatScopeInfo [ci] Nothing deletedTs
|
||||
toView $ CEvtChatItemsDeleted user deletions True True
|
||||
_ -> eToView $ ChatError $ CEInternalError "bad deleteTimedItem cType"
|
||||
@@ -1623,25 +1623,25 @@ parseChatMessage conn s = do
|
||||
errType = CEInvalidChatMessage conn Nothing (safeDecodeUtf8 s)
|
||||
{-# INLINE parseChatMessage #-}
|
||||
|
||||
getChatScopeInfo :: VersionRangeChat -> User -> GroupChatScope -> CM GroupChatScopeInfo
|
||||
getChatScopeInfo vr user = \case
|
||||
getChatScopeInfo :: StoreCxt -> User -> GroupChatScope -> CM GroupChatScopeInfo
|
||||
getChatScopeInfo cxt user = \case
|
||||
GCSMemberSupport Nothing -> pure $ GCSIMemberSupport Nothing
|
||||
GCSMemberSupport (Just gmId) -> do
|
||||
supportMem <- withFastStore $ \db -> getGroupMemberById db vr user gmId
|
||||
supportMem <- withFastStore $ \db -> getGroupMemberById db cxt user gmId
|
||||
pure $ GCSIMemberSupport (Just supportMem)
|
||||
|
||||
getGroupRecipients :: VersionRangeChat -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> VersionChat -> CM [GroupMember]
|
||||
getGroupRecipients vr user gInfo@GroupInfo {membership} scopeInfo modsCompatVersion
|
||||
getGroupRecipients :: StoreCxt -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> VersionChat -> CM [GroupMember]
|
||||
getGroupRecipients cxt user gInfo@GroupInfo {membership} scopeInfo modsCompatVersion
|
||||
| useRelays' gInfo && not (isRelay membership) = do
|
||||
unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member"
|
||||
withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
|
||||
withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo
|
||||
| otherwise = case scopeInfo of
|
||||
Nothing -> do
|
||||
unless (memberCurrent membership && memberActive membership) $ throwChatError $ CECommandError "not current member"
|
||||
ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
|
||||
ms <- withFastStore' $ \db -> getGroupMembers db cxt user gInfo
|
||||
pure $ filter memberCurrent ms
|
||||
Just (GCSIMemberSupport Nothing) -> do
|
||||
modMs <- withFastStore' $ \db -> getGroupModerators db vr user gInfo
|
||||
modMs <- withFastStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
let rcpModMs' = filter (\m -> compatible m && memberCurrent m) modMs
|
||||
when (null rcpModMs') $ throwChatError $ CECommandError "no admins support this message"
|
||||
pure rcpModMs'
|
||||
@@ -1651,7 +1651,7 @@ getGroupRecipients vr user gInfo@GroupInfo {membership} scopeInfo modsCompatVers
|
||||
if memberStatus supportMem == GSMemPendingApproval
|
||||
then pure [supportMem]
|
||||
else do
|
||||
modMs <- withFastStore' $ \db -> getGroupModerators db vr user gInfo
|
||||
modMs <- withFastStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
let rcpModMs' = filter (\m -> compatible m && memberCurrent m) modMs
|
||||
pure $ [supportMem] <> rcpModMs'
|
||||
where
|
||||
@@ -1677,8 +1677,8 @@ mkGroupChatScope gInfo@GroupInfo {membership} m
|
||||
| otherwise =
|
||||
pure (gInfo, m, Nothing)
|
||||
|
||||
mkGetMessageChatScope :: VersionRangeChat -> User -> GroupInfo -> GroupMember -> MsgContent -> Maybe MsgScope -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
|
||||
mkGetMessageChatScope vr user gInfo@GroupInfo {membership} m mc msgScope_ =
|
||||
mkGetMessageChatScope :: StoreCxt -> User -> GroupInfo -> GroupMember -> MsgContent -> Maybe MsgScope -> CM (GroupInfo, GroupMember, Maybe GroupChatScopeInfo)
|
||||
mkGetMessageChatScope cxt user gInfo@GroupInfo {membership} m mc msgScope_ =
|
||||
mkGroupChatScope gInfo m >>= \case
|
||||
groupScope@(_gInfo', _m', Just _scopeInfo) -> pure groupScope
|
||||
(_, _, Nothing)
|
||||
@@ -1693,7 +1693,7 @@ mkGetMessageChatScope vr user gInfo@GroupInfo {membership} m mc msgScope_ =
|
||||
(gInfo', scopeInfo) <- mkGroupSupportChatInfo gInfo
|
||||
pure (gInfo', m, Just scopeInfo)
|
||||
| otherwise -> do
|
||||
referredMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo mId
|
||||
referredMember <- withStore $ \db -> getGroupMemberByMemberId db cxt user gInfo mId
|
||||
-- TODO [knocking] return patched _referredMember'?
|
||||
(_referredMember', scopeInfo) <- mkMemberSupportChatInfo referredMember
|
||||
pure (gInfo, m, Just scopeInfo)
|
||||
@@ -1807,8 +1807,8 @@ cancelSndFileTransfer user@User {userId} ft@SndFileTransfer {fileId, connId, fil
|
||||
withStore' $ \db -> updateSndFileStatus db ft FSCancelled
|
||||
when sendCancel $ case fileInline of
|
||||
Just _ -> do
|
||||
vr <- chatVersionRange
|
||||
(sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db vr user connId
|
||||
cxt <- chatStoreCxt
|
||||
(sharedMsgId, conn) <- withStore $ \db -> (,) <$> getSharedMsgIdByFileId db userId fileId <*> getConnectionById db cxt user connId
|
||||
void $ sendDirectMessage_ conn (BFileChunk sharedMsgId FileChunkCancel) (ConnectionId connId)
|
||||
_ -> throwChatError $ CEException "cancelSndFileTransfer: cancelling file via a separate connection is deprecated"
|
||||
|
||||
@@ -1992,13 +1992,13 @@ batchSndMessagesJSON mode = batchMessages mode maxEncodedMsgLength . L.toList
|
||||
|
||||
encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString
|
||||
encodeConnInfo chatMsgEvent = do
|
||||
vr <- chatVersionRange
|
||||
encodeConnInfoPQ PQSupportOff (maxVersion vr) chatMsgEvent
|
||||
cxt <- chatStoreCxt
|
||||
encodeConnInfoPQ PQSupportOff (maxVersion (vr cxt)) chatMsgEvent
|
||||
|
||||
encodeConnInfoPQ :: MsgEncodingI e => PQSupport -> VersionChat -> ChatMsgEvent e -> CM ByteString
|
||||
encodeConnInfoPQ pqSup v chatMsgEvent = do
|
||||
vr <- chatVersionRange
|
||||
let info = ChatMessage {chatVRange = vr, msgId = Nothing, chatMsgEvent}
|
||||
cxt <- chatStoreCxt
|
||||
let info = ChatMessage {chatVRange = vr cxt, msgId = Nothing, chatMsgEvent}
|
||||
case encodeChatMessage maxEncodedInfoLength info of
|
||||
ECMEncoded connInfo -> case pqSup of
|
||||
PQSupportOn | v >= pqEncryptionCompressionVersion && B.length connInfo > maxCompressedInfoLength -> do
|
||||
@@ -2312,8 +2312,8 @@ saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta
|
||||
withStore (\db -> createNewMessageAndRcvMsgDelivery db (GroupId groupId) newMsg sharedMsgId_ rcvMsgDelivery $ Just amGroupMemId)
|
||||
`catchAllErrors` \e -> case e of
|
||||
ChatErrorStore (SEDuplicateGroupMessage _ _ _ (Just forwardedByGroupMemberId)) -> do
|
||||
vr <- chatVersionRange
|
||||
fm <- withStore $ \db -> getGroupMember db vr user groupId forwardedByGroupMemberId
|
||||
cxt <- chatStoreCxt
|
||||
fm <- withStore $ \db -> getGroupMember db cxt user groupId forwardedByGroupMemberId
|
||||
forM_ (memberConn fm) $ \fmConn ->
|
||||
void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemId) groupId
|
||||
throwError e
|
||||
@@ -2333,8 +2333,8 @@ saveGroupFwdRcvMsg user gInfo@GroupInfo {groupId} forwardingMember refAuthorMemb
|
||||
| useRelays' gInfo -> pure Nothing -- with chat relays, duplicates are expected
|
||||
| otherwise -> case (authorGroupMemberId, forwardedByGroupMemberId) of
|
||||
(Just authorGMId, Nothing) -> do
|
||||
vr <- chatVersionRange
|
||||
am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db vr user groupId authorGMId
|
||||
cxt <- chatStoreCxt
|
||||
am@GroupMember {memberId = amMemberId} <- withStore $ \db -> getGroupMember db cxt user groupId authorGMId
|
||||
if maybe False (\ref -> sameMemberId (memberId' ref) am) refAuthorMember_
|
||||
then forM_ (memberConn forwardingMember) $ \fmConn ->
|
||||
void $ sendDirectMemberMessage fmConn (XGrpMemCon amMemberId) groupId
|
||||
@@ -2376,9 +2376,9 @@ saveSndChatItems ::
|
||||
CM [Either ChatError (ChatItem c 'MDSnd)]
|
||||
saveSndChatItems user cd showGroupAsSender itemsData itemTimed live = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
when (contactChatDeleted cd || any (\NewSndChatItemData {content} -> ciRequiresAttention content) (rights itemsData)) $
|
||||
void (withStore' $ \db -> updateChatTsStats db vr user cd createdAt Nothing)
|
||||
void (withStore' $ \db -> updateChatTsStats db cxt user cd createdAt Nothing)
|
||||
lift $ withStoreBatch (\db -> map (bindRight $ createItem db createdAt) itemsData)
|
||||
where
|
||||
createItem :: DB.Connection -> UTCTime -> NewSndChatItemData c -> IO (Either ChatError (ChatItem c 'MDSnd))
|
||||
@@ -2404,14 +2404,14 @@ ciContentNoParse content = (content, (ciContentToText content, Nothing))
|
||||
saveRcvChatItem' :: (ChatTypeI c, ChatTypeQuotable c) => User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> UTCTime -> (CIContent 'MDRcv, (Text, Maybe MarkdownList)) -> Maybe (CIFile 'MDRcv) -> Maybe CITimed -> Bool -> Map MemberName MsgMention -> CM (ChatItem c 'MDRcv, ChatInfo c)
|
||||
saveRcvChatItem' user cd msg@RcvMessage {chatMsgEvent, msgSigned, forwardedByMember} sharedMsgId_ brokerTs (content, (t, ft_)) ciFile itemTimed live mentions = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
withStore' $ \db -> do
|
||||
(mentions' :: Map MemberName CIMention, userMention) <- case toChatInfo cd of
|
||||
GroupChat g@GroupInfo {membership} _ -> groupMentions db g membership
|
||||
_ -> pure (M.empty, False)
|
||||
cInfo' <-
|
||||
if (ciRequiresAttention content || contactChatDeleted cd)
|
||||
then updateChatTsStats db vr user cd createdAt (memberChatStats userMention)
|
||||
then updateChatTsStats db cxt user cd createdAt (memberChatStats userMention)
|
||||
else pure $ toChatInfo cd
|
||||
let showAsGroup = case cd of CDChannelRcv {} -> True; _ -> False
|
||||
hasLink_ = ciContentHasLink content ft_
|
||||
@@ -2704,13 +2704,13 @@ createChatItems ::
|
||||
createChatItems user itemTs_ dirsCIContents = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
let itemTs = fromMaybe createdAt itemTs_
|
||||
vr <- chatVersionRange'
|
||||
void . withStoreBatch' $ \db -> map (updateChat db vr createdAt) dirsCIContents
|
||||
cxt <- chatStoreCxt'
|
||||
void . withStoreBatch' $ \db -> map (updateChat db cxt createdAt) dirsCIContents
|
||||
withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents
|
||||
where
|
||||
updateChat :: DB.Connection -> VersionRangeChat -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO ()
|
||||
updateChat db vr createdAt (cd, _, contents)
|
||||
| any (ciRequiresAttention . fst) contents || contactChatDeleted cd = void $ updateChatTsStats db vr user cd createdAt memberChatStats
|
||||
updateChat :: DB.Connection -> StoreCxt -> UTCTime -> (ChatDirection c d, ShowGroupAsSender, [(CIContent d, Maybe SharedMsgId)]) -> IO ()
|
||||
updateChat db cxt createdAt (cd, _, contents)
|
||||
| any (ciRequiresAttention . fst) contents || contactChatDeleted cd = void $ updateChatTsStats db cxt user cd createdAt memberChatStats
|
||||
| otherwise = pure ()
|
||||
where
|
||||
memberChatStats :: Maybe (Int, MemberAttention, Int)
|
||||
@@ -2749,8 +2749,8 @@ createLocalChatItems ::
|
||||
UTCTime ->
|
||||
CM [ChatItem 'CTLocal 'MDSnd]
|
||||
createLocalChatItems user cd itemsData createdAt = do
|
||||
vr <- chatVersionRange
|
||||
void $ withStore' $ \db -> updateChatTsStats db vr user cd createdAt Nothing
|
||||
cxt <- chatStoreCxt
|
||||
void $ withStore' $ \db -> updateChatTsStats db cxt user cd createdAt Nothing
|
||||
(errs, items) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (createItem db) $ L.toList itemsData)
|
||||
unless (null errs) $ toView $ CEvtChatErrors errs
|
||||
pure items
|
||||
@@ -2800,6 +2800,14 @@ waitChatStartedAndActivated = do
|
||||
activated <- readTVar chatActivated
|
||||
unless (isJust started && activated) retry
|
||||
|
||||
chatStoreCxt :: CM StoreCxt
|
||||
chatStoreCxt = lift chatStoreCxt'
|
||||
{-# INLINE chatStoreCxt #-}
|
||||
|
||||
chatStoreCxt' :: CM' StoreCxt
|
||||
chatStoreCxt' = mkStoreCxt <$> asks config
|
||||
{-# INLINE chatStoreCxt' #-}
|
||||
|
||||
chatVersionRange :: CM VersionRangeChat
|
||||
chatVersionRange = lift chatVersionRange'
|
||||
{-# INLINE chatVersionRange #-}
|
||||
|
||||
@@ -115,10 +115,10 @@ processAgentMessage _ "" (ERR e) =
|
||||
processAgentMessage corrId connId msg = do
|
||||
lockEntity <- critical connId (withStore (`getChatLockEntity` AgentConnId connId))
|
||||
withEntityLock "processAgentMessage" lockEntity $ do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
-- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here
|
||||
critical connId (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case
|
||||
Just user -> processAgentMessageConn vr user corrId connId msg `catchAllErrors` eToView
|
||||
Just user -> processAgentMessageConn cxt user corrId connId msg `catchAllErrors` eToView
|
||||
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
|
||||
|
||||
-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps.
|
||||
@@ -169,27 +169,27 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
process :: User -> FileTransferId -> CM ()
|
||||
process user fileId = do
|
||||
(ft@FileTransferMeta {xftpRedirectFor, cancelled}, sfts) <- withStore $ \db -> getSndFileTransfer db user fileId
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
unless cancelled $ case msg of
|
||||
SFPROG sndProgress sndTotal -> do
|
||||
let status = CIFSSndTransfer {sndProgress, sndTotal}
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId status
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
toView $ CEvtSndFileProgressXFTP user ci ft sndProgress sndTotal
|
||||
SFDONE sndDescr rfds -> do
|
||||
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
|
||||
ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId
|
||||
ci <- withStore $ \db -> lookupChatItemByFileId db cxt user fileId
|
||||
case ci of
|
||||
Nothing -> do
|
||||
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
||||
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText rfds)
|
||||
case rfds of
|
||||
[] -> sendFileError (FileErrOther "no receiver descriptions") "no receiver descriptions" vr ft
|
||||
[] -> sendFileError (FileErrOther "no receiver descriptions") "no receiver descriptions" cxt ft
|
||||
rfd : _ -> case [fd | fd@(FD.ValidFileDescription FD.FileDescription {chunks = [_]}) <- rfds] of
|
||||
[] -> case xftpRedirectFor of
|
||||
Nothing -> xftpSndFileRedirect user fileId rfd >>= toView . CEvtSndFileRedirectStartXFTP user ft
|
||||
Just _ -> sendFileError (FileErrOther "chaining redirects") "Prohibit chaining redirects" vr ft
|
||||
Just _ -> sendFileError (FileErrOther "chaining redirects") "Prohibit chaining redirects" cxt ft
|
||||
rfds' -> do
|
||||
-- we have 1 chunk - use it as URI whether it is redirect or not
|
||||
ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor
|
||||
@@ -222,13 +222,13 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId
|
||||
ci' <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
|
||||
getChatItemByFileId db vr user fileId
|
||||
getChatItemByFileId db cxt user fileId
|
||||
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
||||
toView $ CEvtSndFileCompleteXFTP user ci' ft
|
||||
where
|
||||
getRecipients
|
||||
| useRelays' g = withStore' $ \db -> getGroupRelayMembers db vr user g
|
||||
| otherwise = withStore' $ \db -> getGroupMembers db vr user g
|
||||
| useRelays' g = withStore' $ \db -> getGroupRelayMembers db cxt user g
|
||||
| otherwise = withStore' $ \db -> getGroupMembers db cxt user g
|
||||
memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)]
|
||||
memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts')
|
||||
where
|
||||
@@ -241,10 +241,10 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
logWarn $ "Sent file warning: " <> err
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId (CIFSSndWarning $ agentFileError e)
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
toView $ CEvtSndFileWarning user ci ft err
|
||||
SFERR e ->
|
||||
sendFileError (agentFileError e) (tshow e) vr ft
|
||||
sendFileError (agentFileError e) (tshow e) cxt ft
|
||||
where
|
||||
fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
|
||||
fileDescrText = safeDecodeUtf8 . strEncode
|
||||
@@ -269,12 +269,12 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
toMsgReq :: (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq
|
||||
toMsgReq (conn, _) SndMessage {msgId, msgBody} =
|
||||
(conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, (vrValue msgBody, [msgId]))
|
||||
sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
|
||||
sendFileError ferr err vr ft = do
|
||||
sendFileError :: FileError -> Text -> StoreCxt -> FileTransferMeta -> CM ()
|
||||
sendFileError ferr err cxt ft = do
|
||||
logError $ "Sent file error: " <> err
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateFileCancelled db user fileId (CIFSSndError ferr)
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
||||
toView $ CEvtSndFileError user ci ft err
|
||||
|
||||
@@ -309,13 +309,13 @@ processAgentMsgRcvFile _corrId aFileId msg = do
|
||||
process :: User -> FileTransferId -> CM ()
|
||||
process user fileId = do
|
||||
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
unless (rcvFileCompleteOrCancelled ft) $ case msg of
|
||||
RFPROG rcvProgress rcvTotal -> do
|
||||
let status = CIFSRcvTransfer {rcvProgress, rcvTotal}
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId status
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
toView $ CEvtRcvFileProgressXFTP user ci rcvProgress rcvTotal ft
|
||||
RFDONE xftpPath ->
|
||||
case liveRcvFileTransferPath ft of
|
||||
@@ -327,13 +327,13 @@ processAgentMsgRcvFile _corrId aFileId msg = do
|
||||
liftIO $ do
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
toView $ maybe (CEvtRcvStandaloneFileComplete user fsTargetPath ft) (CEvtRcvFileComplete user) ci_
|
||||
RFWARN e -> do
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId (CIFSRcvWarning $ agentFileError e)
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
toView $ CEvtRcvFileWarning user ci e ft
|
||||
RFERR e
|
||||
| e == FILE NOT_APPROVED -> do
|
||||
@@ -344,20 +344,20 @@ processAgentMsgRcvFile _corrId aFileId msg = do
|
||||
| otherwise -> do
|
||||
aci_ <- withStore $ \db -> do
|
||||
liftIO $ updateFileCancelled db user fileId (CIFSRcvError $ agentFileError e)
|
||||
lookupChatItemByFileId db vr user fileId
|
||||
lookupChatItemByFileId db cxt user fileId
|
||||
forM_ aci_ cleanupACIFile
|
||||
agentXFTPDeleteRcvFile aFileId fileId
|
||||
toView $ CEvtRcvFileError user aci_ e ft
|
||||
|
||||
type ShouldDeleteGroupConns = Bool
|
||||
|
||||
processAgentMessageConn :: VersionRangeChat -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
|
||||
processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
|
||||
processAgentMessageConn :: StoreCxt -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
|
||||
processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
|
||||
-- as in this case no need to ACK message - we can't process messages for this connection anyway.
|
||||
-- SEDBException will be re-trown as CRITICAL as it is likely to indicate a temporary database condition
|
||||
-- that will be resolved with app restart.
|
||||
entity <- critical agentConnId $ withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus
|
||||
entity <- critical agentConnId $ withStore (\db -> getConnectionEntity db cxt user $ AgentConnId agentConnId) >>= updateConnStatus
|
||||
case agentMessage of
|
||||
END -> case entity of
|
||||
RcvDirectMsgConnection _ (Just ct) -> toView $ CEvtContactAnotherClient user ct
|
||||
@@ -562,7 +562,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
|
||||
(gInfo, host) <- withStore $ \db -> do
|
||||
liftIO $ deleteContactCardKeepConn db connId ct
|
||||
createGroupInvitedViaLink db vr user conn'' glInv
|
||||
createGroupInvitedViaLink db cxt user conn'' glInv
|
||||
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
|
||||
-- [incognito] send saved profile
|
||||
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
|
||||
@@ -614,7 +614,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
when (connChatVersion < batchSend2Version) $ forM_ (autoReply $ addressSettings ucl) $ \mc -> sendAutoReply ct' mc Nothing -- old versions only
|
||||
-- TODO REMOVE LEGACY vvv
|
||||
forM_ gli_ $ \GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
|
||||
groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
groupInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
|
||||
gVar <- asks random
|
||||
@@ -727,7 +727,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- [async agent commands] group link auto-accept continuation on receiving INV
|
||||
CFCreateConnGrpInv -> do
|
||||
(ct, groupLinkId) <- withStore $ \db -> do
|
||||
ct <- getContactViaMember db vr user m
|
||||
ct <- getContactViaMember db cxt user m
|
||||
liftIO $ setNewContactMemberConnRequest db user m cReq
|
||||
liftIO $ (ct,) <$> getGroupLinkId db user gInfo
|
||||
sendGrpInvitation ct m groupLinkId
|
||||
@@ -795,7 +795,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
pgId = fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId),
|
||||
useRelays' gInfo == isJust rcvPG && pgId rcvPG == pgId curPG -> do
|
||||
-- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records
|
||||
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db vr user gInfo m glInv
|
||||
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
|
||||
-- [incognito] send saved profile
|
||||
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
|
||||
let profileToSend = userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
|
||||
@@ -803,7 +803,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
toView $ CEvtGroupLinkConnecting user gInfo' m'
|
||||
| otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch"
|
||||
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
|
||||
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersRejected db vr user gInfo m glRjct
|
||||
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersRejected db cxt user gInfo m glRjct
|
||||
toView $ CEvtGroupLinkConnecting user gInfo' m'
|
||||
toViewTE $ TEGroupLinkRejected user gInfo' rejectionReason
|
||||
_ -> messageError "CONF from host member in prepared group must have x.grp.link.inv or x.grp.link.reject"
|
||||
@@ -877,7 +877,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
where
|
||||
firstConnectedHost
|
||||
| useRelays' gInfo = do
|
||||
relayMems <- withStore' $ \db -> getGroupRelayMembers db vr user gInfo
|
||||
relayMems <- withStore' $ \db -> getGroupRelayMembers db cxt user gInfo
|
||||
let numConnected = length $ filter (\GroupMember {memberStatus = ms} -> ms == GSMemConnected) relayMems
|
||||
pure $ numConnected == 1
|
||||
| otherwise = pure True
|
||||
@@ -907,13 +907,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
when (connChatVersion < batchSend2Version) $ getAutoReplyMsg >>= mapM_ (\mc -> sendGroupAutoReply mc Nothing)
|
||||
if useRelays' gInfo''
|
||||
then do
|
||||
introduceInChannel vr user gInfo'' m'
|
||||
introduceInChannel cxt user gInfo'' m'
|
||||
when (groupFeatureAllowed SGFHistory gInfo'') $ sendHistory user gInfo'' m'
|
||||
else case mStatus of
|
||||
GSMemPendingApproval -> pure ()
|
||||
GSMemPendingReview -> introduceToModerators vr user gInfo'' m'
|
||||
GSMemPendingReview -> introduceToModerators cxt user gInfo'' m'
|
||||
_ -> do
|
||||
introduceToAll vr user gInfo'' m'
|
||||
introduceToAll cxt user gInfo'' m'
|
||||
let memberIsCustomer = case businessChat gInfo'' of
|
||||
Just BusinessChatInfo {chatType = BCCustomer, customerId} -> memberId' m' == customerId
|
||||
_ -> False
|
||||
@@ -936,12 +936,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
sendXGrpMemCon = \case
|
||||
GCPreMember ->
|
||||
forM_ (invitedByGroupMemberId membership) $ \hostId -> do
|
||||
host <- withStore $ \db -> getGroupMember db vr user groupId hostId
|
||||
host <- withStore $ \db -> getGroupMember db cxt user groupId hostId
|
||||
forM_ (memberConn host) $ \hostConn ->
|
||||
void $ sendDirectMemberMessage hostConn (XGrpMemCon memberId) groupId
|
||||
GCPostMember ->
|
||||
forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do
|
||||
im <- withStore $ \db -> getGroupMember db vr user groupId invitingMemberId
|
||||
im <- withStore $ \db -> getGroupMember db cxt user groupId invitingMemberId
|
||||
forM_ (memberConn im) $ \imConn ->
|
||||
void $ sendDirectMemberMessage imConn (XGrpMemCon memberId) groupId
|
||||
_ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected"
|
||||
@@ -1202,7 +1202,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(confId, m', relay) <- withStore $ \db -> do
|
||||
confId <- getRelayConfId db m
|
||||
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
||||
(m', relay) <- setRelayLinkAccepted db vr user m (MemberKey relayKey) relayProfile
|
||||
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
|
||||
pure (confId, m', relay)
|
||||
allowAgentConnectionAsync user conn confId XOk
|
||||
toView $ CEvtGroupRelayUpdated user gInfo m' relay
|
||||
@@ -1290,7 +1290,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
FileChunkCancel ->
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
cancelRcvFileTransfer user ft
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
ci <- withStore $ \db -> getChatItemByFileId db cxt user fileId
|
||||
toView $ CEvtRcvFileSndCancelled user ci ft
|
||||
FileChunk {chunkNo, chunkBytes = chunk} -> do
|
||||
case integrity of
|
||||
@@ -1313,7 +1313,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
updateCIFileStatus db user fileId CIFSRcvComplete
|
||||
deleteRcvFileChunks db ft
|
||||
getChatItemByFileId db vr user fileId
|
||||
getChatItemByFileId db cxt user fileId
|
||||
toView $ CEvtRcvFileComplete user ci
|
||||
mapM_ (deleteAgentConnectionAsync . aConnId) conn_
|
||||
RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure ()
|
||||
@@ -1338,7 +1338,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
case (ucGroupId_, auData) of
|
||||
(Just groupId, UserContactLinkData UserContactData {relays = relayLinks}) -> do
|
||||
(gInfo, gLink, relays, relaysChanged, newlyActiveLinks) <- withStore $ \db -> do
|
||||
gInfo <- getGroupInfo db vr user groupId
|
||||
gInfo <- getGroupInfo db cxt user groupId
|
||||
gLink <- getGroupLink db user gInfo
|
||||
relays <- liftIO $ getGroupRelays db gInfo
|
||||
(relays', changed, newlyActive) <- liftIO $ foldrM (updateRelay db) ([], False, []) relays
|
||||
@@ -1351,7 +1351,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- dedicated subscriber count).
|
||||
when (fromMaybe 0 publicMemberCount > 1) $
|
||||
forM_ (L.nonEmpty newlyActiveLinks) $ \newlyActive -> do
|
||||
allRelayMembers <- withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
|
||||
allRelayMembers <- withFastStore' $ \db -> getGroupRelayMembers db cxt user gInfo
|
||||
let recipients =
|
||||
filter
|
||||
(\GroupMember {memberStatus, relayLink} ->
|
||||
@@ -1401,7 +1401,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
AddressSettings {autoAccept} = addressSettings
|
||||
isSimplexTeam = sameConnReqContact connReq adminContactReq
|
||||
gVar <- asks random
|
||||
withStore (\db -> createOrUpdateContactRequest db gVar vr user uclId ucl isSimplexTeam invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ reqPQSup) >>= \case
|
||||
withStore (\db -> createOrUpdateContactRequest db gVar cxt user uclId ucl isSimplexTeam invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ reqPQSup) >>= \case
|
||||
RSAcceptedRequest _ucr re -> case re of
|
||||
REContact ct ->
|
||||
-- TODO [short links] update request msg
|
||||
@@ -1533,7 +1533,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- ##### Group link join requests (don't create contact requests) #####
|
||||
Just gli@GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
|
||||
-- TODO [short links] deduplicate request by xContactId?
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
|
||||
if useRelays' gInfo
|
||||
then messageWarning $ "processContactConnMessage (group " <> groupName' gInfo <> "): ignored direct join request from " <> displayName <> " (group uses relays)"
|
||||
else do
|
||||
@@ -1559,10 +1559,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
rejected <- withStore' $ \db -> isRelayGroupRejected db user groupLink
|
||||
initialDelay <- asks $ initialInterval . relayRequestRetryInterval . config
|
||||
if rejected
|
||||
then rejectRelayInvitationAsync user uclId vr groupRelayInv invId chatVRange initialDelay RRRRejoinRejected
|
||||
then rejectRelayInvitationAsync user uclId cxt groupRelayInv invId chatVRange initialDelay RRRRejoinRejected
|
||||
else do
|
||||
(_gInfo, _ownerMember) <- withStore $ \db ->
|
||||
createRelayRequestGroup db vr user groupRelayInv invId chatVRange initialDelay GSMemAccepted RSInvited
|
||||
createRelayRequestGroup db cxt user groupRelayInv invId chatVRange initialDelay GSMemAccepted RSInvited
|
||||
lift $ void $ getRelayRequestWorker True
|
||||
xGrpRelayTest :: InvitationId -> VersionRangeChat -> ByteString -> CM ()
|
||||
xGrpRelayTest invId chatVRange challenge = do
|
||||
@@ -1577,7 +1577,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let chatV = chatVR `peerConnChatVersion` chatVRange
|
||||
(cmdId, acId) <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV
|
||||
withStore $ \db -> do
|
||||
Connection {connId = testCId} <- createRelayTestConnection db vr user acId ConnAccepted chatV subMode
|
||||
Connection {connId = testCId} <- createRelayTestConnection db cxt user acId ConnAccepted chatV subMode
|
||||
liftIO $ setCommandConnId db user cmdId testCId
|
||||
-- TODO [relays] owner, relays: TBC how to communicate member rejection rules from owner to relays
|
||||
-- TODO [relays] relay: TBC communicate rejection when memberId already exists (currently checked in createJoiningMember)
|
||||
@@ -1586,7 +1586,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(_ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId
|
||||
case gLinkInfo_ of
|
||||
Just GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
||||
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
|
||||
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p Nothing (Just joiningMemberId) Nothing GAAccepted gLinkMemRole Nothing (Just joiningMemberKey)
|
||||
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
|
||||
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
||||
@@ -1756,7 +1756,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- sendProbe -> sendProbeHashes (currently)
|
||||
-- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay)
|
||||
sendProbe probe
|
||||
ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db vr user ct)
|
||||
ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db cxt user ct)
|
||||
sendProbeHashes ms probe probeId
|
||||
else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32)
|
||||
where
|
||||
@@ -1772,7 +1772,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
then do
|
||||
(probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId $ COMGroupMember m
|
||||
sendProbe probe
|
||||
cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db vr user m)
|
||||
cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db cxt user m)
|
||||
sendProbeHashes cs probe probeId
|
||||
else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32)
|
||||
where
|
||||
@@ -1845,7 +1845,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
messageFileDescription Contact {contactId} sharedMsgId fileDescr = do
|
||||
(fileId, aci) <- withStore $ \db -> do
|
||||
fileId <- getFileIdBySharedMsgId db userId contactId sharedMsgId
|
||||
aci <- getChatItemByFileId db vr user fileId
|
||||
aci <- getChatItemByFileId db cxt user fileId
|
||||
pure (fileId, aci)
|
||||
processFDMessage fileId aci fileDescr
|
||||
|
||||
@@ -1853,7 +1853,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr = do
|
||||
(fileId, aci) <- withStore $ \db -> do
|
||||
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
aci <- getChatItemByFileId db vr user fileId
|
||||
aci <- getChatItemByFileId db cxt user fileId
|
||||
pure (fileId, aci)
|
||||
case aci of
|
||||
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir}
|
||||
@@ -2014,7 +2014,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
cci <- case itemMemberId of
|
||||
Just itemMemberId' -> getGroupMemberCIBySharedMsgId db user g itemMemberId' sharedMsgId
|
||||
Nothing -> getGroupChatItemBySharedMsgId db user g Nothing sharedMsgId
|
||||
scopeInfo <- getGroupChatScopeInfoForItem db vr user g (cChatItemId cci)
|
||||
scopeInfo <- getGroupChatScopeInfoForItem db cxt user g (cChatItemId cci)
|
||||
pure (cci, scopeInfo)
|
||||
if ciReactionAllowed ci
|
||||
then do
|
||||
@@ -2052,13 +2052,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- no delivery task - message already forwarded by relay
|
||||
pure Nothing
|
||||
Just m@GroupMember {memberId} -> do
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope cxt user gInfo m content msgScope_
|
||||
if blockedByAdmin m'
|
||||
then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing
|
||||
else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of
|
||||
Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing
|
||||
Nothing ->
|
||||
withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case
|
||||
withStore' (\db -> getCIModeration db cxt user gInfo' memberId sharedMsgId_) >>= \case
|
||||
Just ciModeration -> do
|
||||
applyModeration gInfo' m' scopeInfo ciModeration
|
||||
withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_
|
||||
@@ -2148,7 +2148,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
else case m_ of
|
||||
Just m -> do
|
||||
let mentions' = if memberBlocked m then [] else mentions
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope cxt user gInfo m mc msgScope_
|
||||
pure (gInfo', CDGroupRcv gInfo' scopeInfo m', mentions', scopeInfo)
|
||||
Nothing -> pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing)
|
||||
case m_ >>= \m -> prohibitedGroupContent gInfo' m scopeInfo mc ft_ (Nothing :: Maybe String) False of
|
||||
@@ -2179,7 +2179,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
else case m_ of
|
||||
Just m -> getGroupMemberCIBySharedMsgId db user gInfo (memberId' m) sharedMsgId
|
||||
Nothing -> getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId
|
||||
(cci,) <$> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci)
|
||||
(cci,) <$> getGroupChatScopeInfoForItem db cxt user gInfo (cChatItemId cci)
|
||||
case cci of
|
||||
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC}
|
||||
| isSender m' -> updateCI False ci scopeInfo oldMC itemLive (Just $ memberId' m')
|
||||
@@ -2291,7 +2291,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
| otherwise = a
|
||||
delete :: CChatItem 'CTGroup -> Bool -> Maybe GroupMember -> CM (Maybe DeliveryTaskContext)
|
||||
delete cci asGroup byGroupMember = do
|
||||
scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci)
|
||||
scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db cxt user gInfo (cChatItemId cci)
|
||||
let fullDelete
|
||||
| asGroup = groupFeatureAllowed SGFFullDelete gInfo
|
||||
| otherwise = maybe False (\m -> groupFeatureMemberAllowed SGFFullDelete m gInfo) m_
|
||||
@@ -2359,14 +2359,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(fileId,) <$> getRcvFileTransfer db user fileId
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
cancelRcvFileTransfer user ft
|
||||
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
||||
ci <- withStore $ \db -> getChatItemByFileId db cxt user fileId
|
||||
toView $ CEvtRcvFileSndCancelled user ci ft
|
||||
|
||||
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
|
||||
xFileAcptInv ct sharedMsgId fileConnReq_ fName = do
|
||||
(fileId, AChatItem _ _ _ ci) <- withStore $ \db -> do
|
||||
fileId <- getDirectFileIdBySharedMsgId db user ct sharedMsgId
|
||||
(fileId,) <$> getChatItemByFileId db vr user fileId
|
||||
(fileId,) <$> getChatItemByFileId db cxt user fileId
|
||||
assertSMPAcceptNotProhibited ci
|
||||
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
@@ -2375,7 +2375,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- receiving inline
|
||||
Nothing -> do
|
||||
event <- withStore $ \db -> do
|
||||
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
|
||||
ci' <- updateDirectCIFileStatus db cxt user fileId $ CIFSSndTransfer 0 1
|
||||
sft <- createSndDirectInlineFT db ct ft
|
||||
pure $ CEvtSndFileStart user ci' sft
|
||||
toView event
|
||||
@@ -2403,7 +2403,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
forM_ sft_ $ \sft@SndFileTransfer {fileId} -> do
|
||||
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
|
||||
liftIO $ updateSndFileStatus db sft FSComplete
|
||||
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
|
||||
updateDirectCIFileStatus db cxt user fileId CIFSSndComplete
|
||||
case file of
|
||||
Just CIFile {fileProtocol = FPXFTP} -> do
|
||||
ft <- withStore $ \db -> getFileTransferMeta db user fileId
|
||||
@@ -2441,7 +2441,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
xFileCancelGroup g@GroupInfo {groupId} m_ sharedMsgId = do
|
||||
(fileId, aci) <- withStore $ \db -> do
|
||||
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
(fileId,) <$> getChatItemByFileId db vr user fileId
|
||||
(fileId,) <$> getChatItemByFileId db cxt user fileId
|
||||
case aci of
|
||||
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir}
|
||||
| validSender m_ chatDir -> do
|
||||
@@ -2457,7 +2457,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
|
||||
(fileId, AChatItem _ _ _ ci) <- withStore $ \db -> do
|
||||
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
(fileId,) <$> getChatItemByFileId db vr user fileId
|
||||
(fileId,) <$> getChatItemByFileId db cxt user fileId
|
||||
assertSMPAcceptNotProhibited ci
|
||||
-- TODO check that it's not already accepted
|
||||
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
|
||||
@@ -2466,7 +2466,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(Nothing, Just conn) -> do
|
||||
-- receiving inline
|
||||
event <- withStore $ \db -> do
|
||||
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
|
||||
ci' <- updateDirectCIFileStatus db cxt user fileId $ CIFSSndTransfer 0 1
|
||||
sft <- liftIO $ createSndGroupInlineFT db m conn ft
|
||||
pure $ CEvtSndFileStart user ci' sft
|
||||
toView event
|
||||
@@ -2492,7 +2492,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
||||
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
||||
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId
|
||||
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart)
|
||||
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
|
||||
if sameGroupLinkId groupLinkId groupLinkId'
|
||||
@@ -2533,7 +2533,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
then do
|
||||
(ct', contactConns) <- withStore' $ \db -> do
|
||||
ct' <- updateContactStatus db user c CSDeleted
|
||||
(ct',) <$> getContactConnections db vr userId ct'
|
||||
(ct',) <$> getContactConnections db cxt userId ct'
|
||||
deleteAgentConnectionsAsync $ map aConnId contactConns
|
||||
forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
|
||||
activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted}
|
||||
@@ -2542,7 +2542,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci]
|
||||
toView $ CEvtContactDeletedByContact user ct''
|
||||
else do
|
||||
contactConns <- withStore' $ \db -> getContactConnections db vr userId c
|
||||
contactConns <- withStore' $ \db -> getContactConnections db cxt userId c
|
||||
deleteAgentConnectionsAsync $ map aConnId contactConns
|
||||
withStore $ \db -> deleteContact db user c
|
||||
where
|
||||
@@ -2611,7 +2611,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
messageError "x.grp.link.acpt with insufficient member permissions"
|
||||
| sameMemberId memberId membership = processUserAccepted
|
||||
| otherwise =
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memberId) >>= \case
|
||||
Left _ -> messageError "x.grp.link.acpt error: referenced member does not exist"
|
||||
Right referencedMember -> do
|
||||
(referencedMember', gInfo') <- withStore' $ \db -> do
|
||||
@@ -2655,7 +2655,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
GAPendingApproval ->
|
||||
messageWarning "x.grp.link.acpt: unexpected group acceptance - pending approval"
|
||||
introduceToRemainingMembers acceptedMember = do
|
||||
introduceToRemaining vr user gInfo acceptedMember
|
||||
introduceToRemaining cxt user gInfo acceptedMember
|
||||
when (groupFeatureAllowed SGFHistory gInfo) $ sendHistory user gInfo acceptedMember
|
||||
|
||||
maybeCreateGroupDescrLocal :: GroupInfo -> GroupMember -> CM ()
|
||||
@@ -2677,7 +2677,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
toView $ CEvtGroupMemberUpdated user gInfo m m'
|
||||
pure m'
|
||||
Just mContactId -> do
|
||||
mCt <- withStore $ \db -> getContact db vr user mContactId
|
||||
mCt <- withStore $ \db -> getContact db cxt user mContactId
|
||||
if canUpdateProfile mCt
|
||||
then do
|
||||
(m', ct') <- withStore $ \db -> updateContactMemberProfile db user m mCt p'
|
||||
@@ -2725,7 +2725,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
contactMerge <- readTVarIO =<< asks contactMergeEnabled
|
||||
-- [incognito] unless connected incognito
|
||||
when (contactMerge && not (contactOrMemberIncognito cgm2)) $ do
|
||||
cgm1s <- withStore' $ \db -> matchReceivedProbe db vr user cgm2 probe
|
||||
cgm1s <- withStore' $ \db -> matchReceivedProbe db cxt user cgm2 probe
|
||||
let cgm1s' = filter (not . contactOrMemberIncognito) cgm1s
|
||||
probeMatches cgm1s' cgm2
|
||||
where
|
||||
@@ -2741,7 +2741,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
contactMerge <- readTVarIO =<< asks contactMergeEnabled
|
||||
-- [incognito] unless connected incognito
|
||||
when (contactMerge && not (contactOrMemberIncognito cgm1)) $ do
|
||||
cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db vr user cgm1 probeHash
|
||||
cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db cxt user cgm1 probeHash
|
||||
forM_ cgm2Probe_ $ \(cgm2, probe) ->
|
||||
unless (contactOrMemberIncognito cgm2) . void $
|
||||
probeMatch cgm1 cgm2 probe
|
||||
@@ -2771,7 +2771,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
xInfoProbeOk :: ContactOrMember -> Probe -> CM ()
|
||||
xInfoProbeOk cgm1 probe = do
|
||||
cgm2 <- withStore' $ \db -> matchSentProbe db vr user cgm1 probe
|
||||
cgm2 <- withStore' $ \db -> matchSentProbe db cxt user cgm1 probe
|
||||
case cgm1 of
|
||||
COMContact c1 ->
|
||||
case cgm2 of
|
||||
@@ -2920,14 +2920,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
associateMemberWithContact c1 m2@GroupMember {groupId} = do
|
||||
g <- withStore $ \db -> do
|
||||
liftIO $ associateMemberWithContactRecord db user c1 m2
|
||||
getGroupInfo db vr user groupId
|
||||
getGroupInfo db cxt user groupId
|
||||
toView $ CEvtContactAndMemberAssociated user c1 g m2 c1
|
||||
pure c1
|
||||
|
||||
associateContactWithMember :: GroupMember -> Contact -> CM Contact
|
||||
associateContactWithMember m1@GroupMember {groupId} c2 = do
|
||||
(c2', g) <- withStore $ \db ->
|
||||
liftM2 (,) (associateContactWithMemberRecord db vr user m1 c2) (getGroupInfo db vr user groupId)
|
||||
liftM2 (,) (associateContactWithMemberRecord db cxt user m1 c2) (getGroupInfo db cxt user groupId)
|
||||
toView $ CEvtContactAndMemberAssociated user c2 g m1 c2'
|
||||
pure c2'
|
||||
|
||||
@@ -2937,15 +2937,15 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
conn' <- updatePeerChatVRange activeConn chatVRange
|
||||
case chatMsgEvent of
|
||||
XInfo p -> do
|
||||
ct <- withStore $ \db -> createDirectContact db vr user conn' p
|
||||
ct <- withStore $ \db -> createDirectContact db cxt user conn' p
|
||||
toView $ CEvtContactConnecting user ct
|
||||
pure (conn', Nothing)
|
||||
XGrpLinkInv glInv -> do
|
||||
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv
|
||||
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db cxt user conn' glInv
|
||||
toView $ CEvtGroupLinkConnecting user gInfo host
|
||||
pure (conn', Just gInfo)
|
||||
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
|
||||
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db vr user conn' glRjct
|
||||
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db cxt user conn' glRjct
|
||||
toView $ CEvtGroupLinkConnecting user gInfo host
|
||||
toViewTE $ TEGroupLinkRejected user gInfo rejectionReason
|
||||
pure (conn', Just gInfo)
|
||||
@@ -2958,10 +2958,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
if sameMemberId memId (membership gInfo)
|
||||
then pure Nothing
|
||||
else do
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
|
||||
Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do
|
||||
(updatedMember, gInfo') <- withStore $ \db -> do
|
||||
updatedMember <- updateUnknownMemberAnnounced db vr user m unknownMember memInfo initialStatus
|
||||
updatedMember <- updateUnknownMemberAnnounced db cxt user m unknownMember memInfo initialStatus
|
||||
gInfo' <-
|
||||
if memberPending updatedMember
|
||||
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
|
||||
@@ -3014,10 +3014,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _ _) memRestrictions = do
|
||||
case memberCategory m of
|
||||
GCHostMember ->
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
|
||||
Right existingMember
|
||||
| useRelays' gInfo -> do
|
||||
updatedMember <- withStore $ \db -> updatePreparedChannelMember db vr user existingMember memInfo
|
||||
updatedMember <- withStore $ \db -> updatePreparedChannelMember db cxt user existingMember memInfo
|
||||
toView $ CEvtGroupMemberUpdated user gInfo existingMember updatedMember
|
||||
| otherwise ->
|
||||
messageError "x.grp.mem.intro ignored: member already exists"
|
||||
@@ -3038,7 +3038,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
|
||||
groupConnIds <- createConn subMode
|
||||
let chatV = maybe (minVersion vr) (\peerVR -> vr `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
|
||||
let chatV = maybe (minVersion (vr cxt)) (\peerVR -> vr cxt `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
|
||||
void $ withStore $ \db -> do
|
||||
reMember <- createIntroReMember db user gInfo memInfo memRestrictions
|
||||
createIntroReMemberConn db user m reMember chatV memInfo groupConnIds subMode
|
||||
@@ -3049,7 +3049,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM ()
|
||||
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
|
||||
hostConn <- withStore $ \db -> getConnectionById db vr user hostConnId
|
||||
hostConn <- withStore $ \db -> getConnectionById db cxt user hostConnId
|
||||
let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq}
|
||||
void $ sendDirectMemberMessage hostConn msg groupId
|
||||
withStore' $ \db -> updateGroupMemberStatusById db userId groupMemberId GSMemIntroInvited
|
||||
@@ -3058,7 +3058,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
xGrpMemInv gInfo m memId introInv = do
|
||||
case memberCategory m of
|
||||
GCInviteeMember ->
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
|
||||
Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist"
|
||||
Right reMember -> sendGroupMemberMessage gInfo reMember $ XGrpMemFwd (memberInfo gInfo m) introInv
|
||||
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
|
||||
@@ -3069,7 +3069,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
checkHostRole m memRole
|
||||
toMember <- withStore $ \db -> do
|
||||
toMember <-
|
||||
getGroupMemberByMemberId db vr user gInfo memId
|
||||
getGroupMemberByMemberId db cxt user gInfo memId
|
||||
-- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
|
||||
-- the situation when member does not exist is an error
|
||||
-- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
|
||||
@@ -3093,7 +3093,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user Nothing True dcr dm subMode
|
||||
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
|
||||
mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
|
||||
chatV = vr `peerConnChatVersion` mcvr
|
||||
chatV = vr cxt `peerConnChatVersion` mcvr
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode
|
||||
|
||||
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
|
||||
@@ -3102,7 +3102,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
|
||||
in changeMemberRole gInfo' membership $ RGEUserRole memRole
|
||||
| otherwise =
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
|
||||
Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
|
||||
Left _ -> messageError "x.grp.mem.role with unknown member ID" $> Nothing
|
||||
where
|
||||
@@ -3133,7 +3133,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
| membershipMemId == memId = pure Nothing -- ignore - XGrpMemRestrict can be sent to restricted member for efficiency
|
||||
| otherwise = do
|
||||
unknownRole <- unknownMemberRole gInfo
|
||||
withStore (\db -> getCreateUnknownGMByMemberId db vr user gInfo memId "" unknownRole True) >>= \case
|
||||
withStore (\db -> getCreateUnknownGMByMemberId db cxt user gInfo memId "" unknownRole True) >>= \case
|
||||
Nothing -> messageError "x.grp.mem.restrict: no member" $> Nothing -- shouldn't happen
|
||||
Just (bm, unknown) -> do
|
||||
let GroupMember {groupMemberId = bmId, memberRole, blockedByAdmin, memberProfile = bmp} = bm
|
||||
@@ -3157,7 +3157,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM ()
|
||||
xGrpMemCon gInfo sendingMem memId = do
|
||||
refMem <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo memId
|
||||
refMem <- withStore $ \db -> getGroupMemberByMemberId db cxt user gInfo memId
|
||||
-- Updating vectors in separate transactions to avoid deadlocks.
|
||||
withStore $ \db -> setMemberVectorRelationConnected db sendingMem refMem MRSubjectConnected
|
||||
withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected
|
||||
@@ -3179,7 +3179,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned
|
||||
pure $ Just DJSGroup {jobSpec = DJRelayRemoved}
|
||||
else
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
|
||||
Left _ -> do
|
||||
messageError "x.grp.mem.del with unknown member ID"
|
||||
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
|
||||
@@ -3323,7 +3323,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
case memberContactId of
|
||||
Nothing -> createNewContact subMode
|
||||
Just mContactId -> do
|
||||
mCt <- withStore $ \db -> getContact db vr user mContactId
|
||||
mCt <- withStore $ \db -> getContact db cxt user mContactId
|
||||
let Contact {activeConn, contactGrpInvSent} = mCt
|
||||
forM_ activeConn $ \Connection {connId} ->
|
||||
if contactGrpInvSent
|
||||
@@ -3350,7 +3350,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
mCt' <- withStore $ \db -> do
|
||||
updateMemberContactInvited db user mCt groupDirectInv
|
||||
void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode
|
||||
getContact db vr user mContactId
|
||||
getContact db cxt user mContactId
|
||||
securityCodeChanged mCt'
|
||||
createItems mCt' m
|
||||
| otherwise = do
|
||||
@@ -3358,7 +3358,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
mCt' <- withStore $ \db -> do
|
||||
updateMemberContactInvited db user mCt groupDirectInv
|
||||
void $ liftIO $ createMemberContactConn db user acId Nothing g mConn ConnPrepared mContactId subMode
|
||||
getContact db vr user mContactId
|
||||
getContact db cxt user mContactId
|
||||
securityCodeChanged mCt'
|
||||
createInternalChatItem user (CDDirectRcv mCt') (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing
|
||||
createItems mCt' m
|
||||
@@ -3369,7 +3369,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(mCt, m') <- withStore $ \db -> do
|
||||
(mContactId, m') <- liftIO $ createMemberContactInvited db user g m groupDirectInv
|
||||
void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode
|
||||
mCt <- getContact db vr user mContactId
|
||||
mCt <- getContact db cxt user mContactId
|
||||
pure (mCt, m')
|
||||
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
|
||||
createItems mCt m'
|
||||
@@ -3378,7 +3378,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(mCt, m') <- withStore $ \db -> do
|
||||
(mContactId, m') <- liftIO $ createMemberContactInvited db user g m groupDirectInv
|
||||
void $ liftIO $ createMemberContactConn db user acId Nothing g mConn ConnPrepared mContactId subMode
|
||||
mCt <- getContact db vr user mContactId
|
||||
mCt <- getContact db cxt user mContactId
|
||||
pure (mCt, m')
|
||||
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
|
||||
createInternalChatItem user (CDDirectRcv mCt) (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing
|
||||
@@ -3409,7 +3409,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
FwdMember memberId memberName -> do
|
||||
unknownRole <- unknownMemberRole gInfo
|
||||
let allowCreate = toCMEventTag chatMsgEvent /= XGrpLeave_
|
||||
withStore (\db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownRole allowCreate) >>= \case
|
||||
withStore (\db -> getCreateUnknownGMByMemberId db cxt user gInfo memberId memberName unknownRole allowCreate) >>= \case
|
||||
Just (author, unknown) -> do
|
||||
when unknown $ toView $ CEvtUnknownMemberCreated user gInfo m author
|
||||
void $ withVerifiedMsg gInfo scopeInfo author parsedMsg msgTs $
|
||||
@@ -3536,7 +3536,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- SENT and RCVD events are received for messages that may be batched in single scope,
|
||||
-- so we can look up scope of first item
|
||||
scopeInfo <- case cis of
|
||||
(ci : _) -> getGroupChatScopeInfoForItem db vr user gInfo (chatItemId' ci)
|
||||
(ci : _) -> getGroupChatScopeInfoForItem db cxt user gInfo (chatItemId' ci)
|
||||
_ -> pure Nothing
|
||||
pure $ map (gItem scopeInfo) cis
|
||||
unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis
|
||||
@@ -3560,14 +3560,14 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
deleteGroupConnections :: User -> GroupInfo -> Bool -> CM ()
|
||||
deleteGroupConnections user gInfo@GroupInfo {membership} waitDelivery = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
-- member records are not deleted to keep history
|
||||
members <- getMembers vr
|
||||
members <- getMembers cxt
|
||||
deleteMembersConnections' user members waitDelivery
|
||||
where
|
||||
getMembers vr
|
||||
| useRelays' gInfo, not (isRelay membership) = withStore' $ \db -> getGroupRelayMembers db vr user gInfo
|
||||
| otherwise = withStore' $ \db -> getGroupMembers db vr user gInfo
|
||||
getMembers cxt
|
||||
| useRelays' gInfo, not (isRelay membership) = withStore' $ \db -> getGroupRelayMembers db cxt user gInfo
|
||||
| otherwise = withStore' $ \db -> getGroupMembers db cxt user gInfo
|
||||
|
||||
startDeliveryTaskWorkers :: CM ()
|
||||
startDeliveryTaskWorkers = do
|
||||
@@ -3587,20 +3587,20 @@ getDeliveryTaskWorker hasWork deliveryKey = do
|
||||
runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
|
||||
runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
|
||||
delay <- asks $ deliveryWorkerDelay . config
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
-- TODO [relays] in future may be required to read groupInfo and user on each iteration for up to date state
|
||||
-- TODO - same for delivery jobs (runDeliveryJobWorker)
|
||||
gInfo <- withStore $ \db -> do
|
||||
user <- getUserByGroupId db groupId
|
||||
getGroupInfo db vr user groupId
|
||||
getGroupInfo db cxt user groupId
|
||||
forever $ do
|
||||
unless (delay == 0) $ liftIO $ threadDelay' delay
|
||||
lift $ waitForWork doWork
|
||||
runDeliveryTaskOperation vr gInfo
|
||||
runDeliveryTaskOperation cxt gInfo
|
||||
where
|
||||
(groupId, workerScope) = deliveryKey
|
||||
runDeliveryTaskOperation :: VersionRangeChat -> GroupInfo -> CM ()
|
||||
runDeliveryTaskOperation vr gInfo = do
|
||||
runDeliveryTaskOperation :: StoreCxt -> GroupInfo -> CM ()
|
||||
runDeliveryTaskOperation cxt gInfo = do
|
||||
withWork_ a doWork (withStore' $ \db -> getNextDeliveryTask db deliveryKey) $ \task ->
|
||||
processDeliveryTask task
|
||||
`catchAllErrors` \e -> do
|
||||
@@ -3616,7 +3616,7 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
|
||||
withStore' $ \db -> setDeliveryTaskErrStatus db (deliveryTaskId task) "relay inactive"
|
||||
| otherwise ->
|
||||
withWorkItems a doWork (withStore' $ \db -> getNextDeliveryTasks db gInfo task) $ \nextTasks -> do
|
||||
let (body, taskIds, largeTaskIds) = batchDeliveryTasks1 vr maxEncodedMsgLength nextTasks
|
||||
let (body, taskIds, largeTaskIds) = batchDeliveryTasks1 (vr cxt) maxEncodedMsgLength nextTasks
|
||||
withStore' $ \db -> do
|
||||
createMsgDeliveryJob db gInfo jobScope (singleSenderGMId_ nextTasks) body
|
||||
forM_ taskIds $ \taskId -> updateDeliveryTaskStatus db taskId DTSProcessed
|
||||
@@ -3658,19 +3658,19 @@ getDeliveryJobWorker hasWork deliveryKey = do
|
||||
runDeliveryJobWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM ()
|
||||
runDeliveryJobWorker a deliveryKey Worker {doWork} = do
|
||||
delay <- asks $ deliveryWorkerDelay . config
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
(user, gInfo) <- withStore $ \db -> do
|
||||
user <- getUserByGroupId db groupId
|
||||
gInfo <- getGroupInfo db vr user groupId
|
||||
gInfo <- getGroupInfo db cxt user groupId
|
||||
pure (user, gInfo)
|
||||
forever $ do
|
||||
unless (delay == 0) $ liftIO $ threadDelay' delay
|
||||
lift $ waitForWork doWork
|
||||
runDeliveryJobOperation vr user gInfo
|
||||
runDeliveryJobOperation cxt user gInfo
|
||||
where
|
||||
(groupId, workerScope) = deliveryKey
|
||||
runDeliveryJobOperation :: VersionRangeChat -> User -> GroupInfo -> CM ()
|
||||
runDeliveryJobOperation vr user gInfo = do
|
||||
runDeliveryJobOperation :: StoreCxt -> User -> GroupInfo -> CM ()
|
||||
runDeliveryJobOperation cxt user gInfo = do
|
||||
withWork_ a doWork (withStore' $ \db -> getNextDeliveryJob db deliveryKey) $ \job ->
|
||||
processDeliveryJob job
|
||||
`catchAllErrors` \e -> do
|
||||
@@ -3708,7 +3708,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
|
||||
where
|
||||
sendLoop :: Int -> Maybe GroupMemberId -> CM ()
|
||||
sendLoop bucketSize cursorGMId_ = do
|
||||
mems <- withStore' $ \db -> getGroupMembersByCursor db vr user gInfo cursorGMId_ singleSenderGMId_ bucketSize
|
||||
mems <- withStore' $ \db -> getGroupMembersByCursor db cxt user gInfo cursorGMId_ singleSenderGMId_ bucketSize
|
||||
unless (null mems) $ do
|
||||
deliver body mems
|
||||
let cursorGMId' = groupMemberId' $ last mems
|
||||
@@ -3716,7 +3716,7 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
|
||||
unless (length mems < bucketSize) $ sendLoop bucketSize (Just cursorGMId')
|
||||
DJSMemberSupport scopeGMId -> do
|
||||
-- for member support scope we just load all recipients in one go, without cursor
|
||||
modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo
|
||||
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
|
||||
let moderatorFilter m =
|
||||
memberCurrent m
|
||||
&& maxVersion (memberChatVRange m) >= groupKnockingVersion
|
||||
@@ -3726,14 +3726,14 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
|
||||
if Just scopeGMId == singleSenderGMId_
|
||||
then pure modMs'
|
||||
else do
|
||||
scopeMem <- withStore $ \db -> getGroupMemberById db vr user scopeGMId
|
||||
scopeMem <- withStore $ \db -> getGroupMemberById db cxt user scopeGMId
|
||||
pure $ scopeMem : modMs'
|
||||
unless (null mems) $ deliver body mems
|
||||
-- fully connected group
|
||||
| otherwise = case singleSenderGMId_ of
|
||||
Nothing -> throwChatError $ CEInternalError "delivery job worker: singleSenderGMId is required when not using relays"
|
||||
Just singleSenderGMId -> do
|
||||
sender <- withStore $ \db -> getGroupMemberById db vr user singleSenderGMId
|
||||
sender <- withStore $ \db -> getGroupMemberById db cxt user singleSenderGMId
|
||||
ms <- buildMemberList sender
|
||||
unless (null ms) $ deliver body ms
|
||||
where
|
||||
@@ -3743,14 +3743,14 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
|
||||
let introducedMemsIdxs = getRelationsIndexes MRIntroduced vec
|
||||
case jobScope of
|
||||
DJSGroup {jobSpec} -> do
|
||||
ms <- withStore' $ \db -> getGroupMembersByIndexes db vr user gInfo introducedMemsIdxs
|
||||
ms <- withStore' $ \db -> getGroupMembersByIndexes db cxt user gInfo introducedMemsIdxs
|
||||
pure $ filter shouldForwardTo ms
|
||||
where
|
||||
shouldForwardTo m
|
||||
| jobSpecImpliedPending jobSpec = memberCurrentOrPending m
|
||||
| otherwise = memberCurrent m
|
||||
DJSMemberSupport scopeGMId -> do
|
||||
ms <- withStore' $ \db -> getSupportScopeMembersByIndexes db vr user gInfo scopeGMId introducedMemsIdxs
|
||||
ms <- withStore' $ \db -> getSupportScopeMembersByIndexes db cxt user gInfo scopeGMId introducedMemsIdxs
|
||||
pure $ filter shouldForwardTo ms
|
||||
where
|
||||
shouldForwardTo m = groupMemberId' m == scopeGMId || currentModerator m
|
||||
@@ -3801,7 +3801,7 @@ getRelayRequestWorker hasWork = do
|
||||
|
||||
runRelayRequestWorker :: AgentClient -> Worker -> CM ()
|
||||
runRelayRequestWorker a Worker {doWork} = do
|
||||
vr <- chatVersionRange
|
||||
cxt <- chatStoreCxt
|
||||
(user, uclId) <- withStore $ \db -> do
|
||||
user <- getRelayUser db
|
||||
UserContactLink {userContactLinkId} <- getUserAddress db user
|
||||
@@ -3809,10 +3809,10 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
delayThreads <- liftIO TM.emptyIO
|
||||
forever $ do
|
||||
lift $ waitForWork doWork
|
||||
runRelayRequestOperation delayThreads vr user uclId
|
||||
runRelayRequestOperation delayThreads cxt user uclId
|
||||
where
|
||||
runRelayRequestOperation :: TM.TMap GroupId (TMVar (Weak ThreadId)) -> VersionRangeChat -> User -> Int64 -> CM ()
|
||||
runRelayRequestOperation delayThreads vr user uclId =
|
||||
runRelayRequestOperation :: TM.TMap GroupId (TMVar (Weak ThreadId)) -> StoreCxt -> User -> Int64 -> CM ()
|
||||
runRelayRequestOperation delayThreads cxt user uclId =
|
||||
withWork_ a doWork getReadyRelayRequest $
|
||||
\(groupId, rrd) -> do
|
||||
ChatConfig {relayRequestExpiry} <- asks config
|
||||
@@ -3861,7 +3861,7 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
processRelayRequest :: GroupId -> RelayRequestData -> CM ()
|
||||
processRelayRequest groupId rrd = do
|
||||
(gInfo, groupLink_) <- withStore $ \db -> do
|
||||
gInfo <- getGroupInfo db vr user groupId
|
||||
gInfo <- getGroupInfo db cxt user groupId
|
||||
groupLink_ <- liftIO $ runExceptT $ getGroupLink db user gInfo
|
||||
pure (gInfo, groupLink_)
|
||||
-- Check if relay link already exists (recovery case)
|
||||
@@ -3889,7 +3889,7 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
gInfo' <- withStore $ \db -> do
|
||||
void $ updateGroupProfile db user gInfo gp
|
||||
updateRelayGroupKeys db user gInfo pg rootKey memberPrivKey owners
|
||||
getGroupInfo db vr user groupId
|
||||
getGroupInfo db cxt user groupId
|
||||
pure (gInfo', sLnk)
|
||||
where
|
||||
validateGroupProfile :: GroupProfile -> CM ()
|
||||
@@ -3921,5 +3921,5 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
pure (sigKeys, sLnk)
|
||||
acceptOwnerConnection :: RelayRequestData -> GroupInfo -> ShortLinkContact -> CM ()
|
||||
acceptOwnerConnection RelayRequestData {relayInvId, reqChatVRange} gi relayLink = do
|
||||
ownerMember <- withStore $ \db -> getHostMember db vr user groupId
|
||||
ownerMember <- withStore $ \db -> getHostMember db cxt user groupId
|
||||
void $ acceptRelayJoinRequestAsync user uclId gi ownerMember relayInvId reqChatVRange relayLink
|
||||
|
||||
@@ -74,8 +74,8 @@ getChatLockEntity db agentConnId = do
|
||||
-- TODO consider whether ConnFailed connections should be excluded:
|
||||
-- - from receiving: getConnectionEntity, getContactConnEntityByConnReqHash
|
||||
-- - from subscribing: getContactConnsToSub, getUCLConnsToSub, getMemberConnsToSub, getPendingConnsToSub
|
||||
getConnectionEntity :: DB.Connection -> VersionRangeChat -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
|
||||
getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
|
||||
getConnectionEntity :: DB.Connection -> StoreCxt -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
|
||||
getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
|
||||
c@Connection {connType, entityId} <- getConnection_
|
||||
case entityId of
|
||||
Nothing ->
|
||||
@@ -90,7 +90,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
|
||||
where
|
||||
getConnection_ :: ExceptT StoreError IO Connection
|
||||
getConnection_ = ExceptT $ do
|
||||
firstRow (toConnection vr) (SEConnectionNotFound agentConnId) $
|
||||
firstRow (toConnection cxt) (SEConnectionNotFound agentConnId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -172,7 +172,7 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
|
||||
liftIO $ bitraverse (addGroupChatTags db) pure gm
|
||||
toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
|
||||
toGroupAndMember c (groupInfoRow :. memberRow) =
|
||||
let groupInfo = toGroupInfo vr userContactId [] groupInfoRow
|
||||
let groupInfo = toGroupInfo cxt userContactId [] groupInfoRow
|
||||
member = toGroupMember userContactId memberRow
|
||||
in (groupInfo, (member :: GroupMember) {activeConn = Just c})
|
||||
getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact
|
||||
@@ -191,17 +191,17 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
|
||||
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
|
||||
userContact_ _ = Left SEUserContactLinkNotFound
|
||||
|
||||
getConnectionEntityByConnReq :: DB.Connection -> VersionRangeChat -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
|
||||
getConnectionEntityByConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
getConnectionEntityByConnReq :: DB.Connection -> StoreCxt -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
|
||||
getConnectionEntityByConnReq db cxt user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
connId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv IN (?,?) LIMIT 1" (userId, cReqSchema1, cReqSchema2)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db cxt user) connId_
|
||||
|
||||
getConnectionEntityViaShortLink :: DB.Connection -> VersionRangeChat -> User -> ShortLinkInvitation -> IO (Maybe (ConnReqInvitation, ConnectionEntity))
|
||||
getConnectionEntityViaShortLink db vr user@User {userId} shortLink = fmap eitherToMaybe $ runExceptT $ do
|
||||
getConnectionEntityViaShortLink :: DB.Connection -> StoreCxt -> User -> ShortLinkInvitation -> IO (Maybe (ConnReqInvitation, ConnectionEntity))
|
||||
getConnectionEntityViaShortLink db cxt user@User {userId} shortLink = fmap eitherToMaybe $ runExceptT $ do
|
||||
(cReq, connId) <- ExceptT getConnReqConnId
|
||||
(cReq,) <$> getConnectionEntity db vr user connId
|
||||
(cReq,) <$> getConnectionEntity db cxt user connId
|
||||
where
|
||||
getConnReqConnId =
|
||||
firstRow' toConnReqConnId (SEInternalError "connection not found") $
|
||||
@@ -222,8 +222,8 @@ getConnectionEntityViaShortLink db vr user@User {userId} shortLink = fmap either
|
||||
-- multiple connections can have same via_contact_uri_hash if request was repeated;
|
||||
-- this function searches for latest connection with contact so that "known contact" plan would be chosen;
|
||||
-- deleted connections are filtered out to allow re-connecting via same contact address
|
||||
getContactConnEntityByConnReqHash :: DB.Connection -> VersionRangeChat -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
|
||||
getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2) = do
|
||||
getContactConnEntityByConnReqHash :: DB.Connection -> StoreCxt -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
|
||||
getContactConnEntityByConnReqHash db cxt user@User {userId} (cReqHash1, cReqHash2) = do
|
||||
connId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
@@ -240,7 +240,7 @@ getContactConnEntityByConnReqHash db vr user@User {userId} (cReqHash1, cReqHash2
|
||||
) c
|
||||
|]
|
||||
(userId, cReqHash1, cReqHash2, ConnDeleted)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db vr user) connId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db cxt user) connId_
|
||||
|
||||
getContactConnsToSub :: DB.Connection -> User -> Bool -> IO [ConnId]
|
||||
getContactConnsToSub db User {userId} filterToSubscribe =
|
||||
|
||||
@@ -49,7 +49,7 @@ import Database.SQLite.Simple.QQ (sql)
|
||||
createOrUpdateContactRequest ::
|
||||
DB.Connection ->
|
||||
TVar ChaChaDRG ->
|
||||
VersionRangeChat ->
|
||||
StoreCxt ->
|
||||
User ->
|
||||
Int64 ->
|
||||
UserContactLink ->
|
||||
@@ -65,7 +65,7 @@ createOrUpdateContactRequest ::
|
||||
createOrUpdateContactRequest
|
||||
db
|
||||
gVar
|
||||
vr
|
||||
cxt
|
||||
user@User {userId, userContactId}
|
||||
uclId
|
||||
UserContactLink {addressSettings = AddressSettings {businessAddress}}
|
||||
@@ -89,7 +89,7 @@ createOrUpdateContactRequest
|
||||
Nothing ->
|
||||
liftIO (getAcceptedBusinessChat xContactId) >>= \case
|
||||
Just gInfo@GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
|
||||
clientMember <- getGroupMemberByMemberId db vr user gInfo customerId
|
||||
clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
|
||||
cr <- liftIO $ getContactRequestByXContactId xContactId
|
||||
pure $ RSAcceptedRequest cr (REBusinessChat gInfo clientMember)
|
||||
Just GroupInfo {businessChat = Nothing} -> throwError SEInvalidBusinessChatContactRequest
|
||||
@@ -104,7 +104,7 @@ createOrUpdateContactRequest
|
||||
getAcceptedContact :: XContactId -> IO (Maybe Contact)
|
||||
getAcceptedContact xContactId = do
|
||||
ct_ <-
|
||||
maybeFirstRow (toContact vr user []) $
|
||||
maybeFirstRow (toContact cxt user []) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -128,7 +128,7 @@ createOrUpdateContactRequest
|
||||
getAcceptedBusinessChat :: XContactId -> IO (Maybe GroupInfo)
|
||||
getAcceptedBusinessChat xContactId = do
|
||||
g_ <-
|
||||
maybeFirstRow (toGroupInfo vr userContactId []) $
|
||||
maybeFirstRow (toGroupInfo cxt userContactId []) $
|
||||
DB.query
|
||||
db
|
||||
(groupInfoQuery <> " WHERE g.business_xcontact_id = ? AND g.user_id = ? AND mu.contact_id = ?")
|
||||
@@ -200,12 +200,12 @@ createOrUpdateContactRequest
|
||||
"UPDATE contact_requests SET contact_id = ? WHERE contact_request_id = ?"
|
||||
(contactId, contactRequestId)
|
||||
ucr <- getContactRequest db user contactRequestId
|
||||
ct <- getContact db vr user contactId
|
||||
ct <- getContact db cxt user contactId
|
||||
pure $ RSCurrentRequest Nothing ucr (Just $ REContact ct)
|
||||
createBusinessChat = do
|
||||
let groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs $ preferences' user
|
||||
(gInfo@GroupInfo {groupId}, clientMember) <-
|
||||
createBusinessRequestGroup db vr gVar user cReqChatVRange profile profileId ldn groupPreferences
|
||||
createBusinessRequestGroup db cxt gVar user cReqChatVRange profile profileId ldn groupPreferences
|
||||
liftIO $
|
||||
DB.execute
|
||||
db
|
||||
@@ -278,13 +278,13 @@ createOrUpdateContactRequest
|
||||
getRequestEntity UserContactRequest {contactRequestId, contactId_, businessGroupId_} =
|
||||
case (contactId_, businessGroupId_) of
|
||||
(Just contactId, Nothing) -> do
|
||||
ct <- getContact db vr user contactId
|
||||
ct <- getContact db cxt user contactId
|
||||
pure $ Just (REContact ct)
|
||||
(Nothing, Just businessGroupId) -> do
|
||||
gInfo <- getGroupInfo db vr user businessGroupId
|
||||
gInfo <- getGroupInfo db cxt user businessGroupId
|
||||
case gInfo of
|
||||
GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
|
||||
clientMember <- getGroupMemberByMemberId db vr user gInfo customerId
|
||||
clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
|
||||
pure $ Just (REBusinessChat gInfo clientMember)
|
||||
_ -> throwError SEInvalidBusinessChatContactRequest
|
||||
(Nothing, Nothing) -> pure Nothing
|
||||
|
||||
@@ -332,8 +332,8 @@ updateDeliveryJobStatus_ db jobId status errReason_ = do
|
||||
(status, errReason_, currentTs, jobId)
|
||||
|
||||
-- TODO [relays] possible improvement is to prioritize owners and "active" members
|
||||
getGroupMembersByCursor :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupMemberId -> Maybe GroupMemberId -> Int -> IO [GroupMember]
|
||||
getGroupMembersByCursor db vr user@User {userContactId} GroupInfo {groupId} cursorGMId_ singleSenderGMId_ count = do
|
||||
getGroupMembersByCursor :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe GroupMemberId -> Maybe GroupMemberId -> Int -> IO [GroupMember]
|
||||
getGroupMembersByCursor db cxt user@User {userContactId} GroupInfo {groupId} cursorGMId_ singleSenderGMId_ count = do
|
||||
gmIds :: [Int64] <-
|
||||
map fromOnly <$> case cursorGMId_ of
|
||||
Nothing ->
|
||||
@@ -351,13 +351,13 @@ getGroupMembersByCursor db vr user@User {userContactId} GroupInfo {groupId} curs
|
||||
:. (cursorGMId, count)
|
||||
)
|
||||
#if defined(dbPostgres)
|
||||
map (toContactMember vr user) <$>
|
||||
map (toContactMember cxt user) <$>
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_member_id IN ?")
|
||||
(Only (In gmIds))
|
||||
#else
|
||||
rights <$> mapM (runExceptT . getGroupMemberById db vr user) gmIds
|
||||
rights <$> mapM (runExceptT . getGroupMemberById db cxt user) gmIds
|
||||
#endif
|
||||
where
|
||||
query =
|
||||
|
||||
@@ -243,8 +243,8 @@ createRelayMemberConnectionAsync db user@User {userId} gInfo GroupMember {groupM
|
||||
where
|
||||
customUserProfileId_ = localProfileId <$> incognitoMembershipProfile gInfo
|
||||
|
||||
createRelayTestConnection :: DB.Connection -> VersionRangeChat -> User -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
|
||||
createRelayTestConnection db vr user@User {userId} agentConnId connStatus chatV subMode = do
|
||||
createRelayTestConnection :: DB.Connection -> StoreCxt -> User -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
|
||||
createRelayTestConnection db cxt user@User {userId} agentConnId connStatus chatV subMode = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -261,7 +261,7 @@ createRelayTestConnection db vr user@User {userId} agentConnId connStatus chatV
|
||||
:. (BI True, currentTs, currentTs)
|
||||
)
|
||||
connId <- liftIO $ insertedRowId db
|
||||
getConnectionById db vr user connId
|
||||
getConnectionById db cxt user connId
|
||||
|
||||
updateConnLinkData :: DB.Connection -> User -> Connection -> ConnReqContact -> ConnReqUriHash -> Maybe GroupLinkId -> VersionChat -> PQSupport -> IO ()
|
||||
updateConnLinkData db User {userId} Connection {connId} cReq cReqHash groupLinkId_ chatV pqSup = do
|
||||
@@ -285,13 +285,13 @@ setPreparedGroupStartedConnection db groupId = do
|
||||
"UPDATE groups SET conn_link_started_connection = ?, updated_at = ? WHERE group_id = ?"
|
||||
(BI True, currentTs, groupId)
|
||||
|
||||
getConnReqContactXContactId :: DB.Connection -> VersionRangeChat -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Either (Maybe Connection) Contact)
|
||||
getConnReqContactXContactId db vr user@User {userId} cReqHash1 cReqHash2 =
|
||||
getContactByConnReqHash db vr user cReqHash1 cReqHash2 >>= maybe (Left <$> getConnection) (pure . Right)
|
||||
getConnReqContactXContactId :: DB.Connection -> StoreCxt -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Either (Maybe Connection) Contact)
|
||||
getConnReqContactXContactId db cxt user@User {userId} cReqHash1 cReqHash2 =
|
||||
getContactByConnReqHash db cxt user cReqHash1 cReqHash2 >>= maybe (Left <$> getConnection) (pure . Right)
|
||||
where
|
||||
getConnection :: IO (Maybe Connection)
|
||||
getConnection =
|
||||
maybeFirstRow (toConnection vr) $
|
||||
maybeFirstRow (toConnection cxt) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -305,10 +305,10 @@ getConnReqContactXContactId db vr user@User {userId} cReqHash1 cReqHash2 =
|
||||
|]
|
||||
(userId, cReqHash1, userId, cReqHash2)
|
||||
|
||||
getContactByConnReqHash :: DB.Connection -> VersionRangeChat -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Maybe Contact)
|
||||
getContactByConnReqHash db vr user@User {userId} cReqHash1 cReqHash2 = do
|
||||
getContactByConnReqHash :: DB.Connection -> StoreCxt -> User -> ConnReqUriHash -> ConnReqUriHash -> IO (Maybe Contact)
|
||||
getContactByConnReqHash db cxt user@User {userId} cReqHash1 cReqHash2 = do
|
||||
ct <-
|
||||
maybeFirstRow (toContact vr user []) $
|
||||
maybeFirstRow (toContact cxt user []) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -394,18 +394,18 @@ createIncognitoProfile db User {userId} p = do
|
||||
createdAt <- getCurrentTime
|
||||
createIncognitoProfile_ db userId createdAt p
|
||||
|
||||
createPreparedContact :: DB.Connection -> VersionRangeChat -> User -> Profile -> ACreatedConnLink -> Maybe SharedMsgId -> ExceptT StoreError IO Contact
|
||||
createPreparedContact db vr user p connLinkToConnect welcomeSharedMsgId = do
|
||||
createPreparedContact :: DB.Connection -> StoreCxt -> User -> Profile -> ACreatedConnLink -> Maybe SharedMsgId -> ExceptT StoreError IO Contact
|
||||
createPreparedContact db cxt user p connLinkToConnect welcomeSharedMsgId = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
|
||||
ctUserPreferences = newContactUserPrefs user p
|
||||
contactId <- createContact_ db user p ctUserPreferences prepared "" currentTs
|
||||
getContact db vr user contactId
|
||||
getContact db cxt user contactId
|
||||
|
||||
updatePreparedContactUser :: DB.Connection -> VersionRangeChat -> User -> Contact -> User -> ExceptT StoreError IO Contact
|
||||
updatePreparedContactUser :: DB.Connection -> StoreCxt -> User -> Contact -> User -> ExceptT StoreError IO Contact
|
||||
updatePreparedContactUser
|
||||
db
|
||||
vr
|
||||
cxt
|
||||
user
|
||||
Contact {contactId, localDisplayName = oldLDN, profile = profile@LocalProfile {profileId, displayName}}
|
||||
newUser@User {userId = newUserId} = do
|
||||
@@ -438,15 +438,15 @@ updatePreparedContactUser
|
||||
|]
|
||||
(newUserId, currentTs, contactId)
|
||||
safeDeleteLDN db user oldLDN
|
||||
getContact db vr newUser contactId
|
||||
getContact db cxt newUser contactId
|
||||
|
||||
createDirectContact :: DB.Connection -> VersionRangeChat -> User -> Connection -> Profile -> ExceptT StoreError IO Contact
|
||||
createDirectContact db vr user Connection {connId, localAlias} p = do
|
||||
createDirectContact :: DB.Connection -> StoreCxt -> User -> Connection -> Profile -> ExceptT StoreError IO Contact
|
||||
createDirectContact db cxt user Connection {connId, localAlias} p = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let ctUserPreferences = newContactUserPrefs user p
|
||||
contactId <- createContact_ db user p ctUserPreferences Nothing localAlias currentTs
|
||||
liftIO $ DB.execute db "UPDATE connections SET contact_id = ?, updated_at = ? WHERE connection_id = ?" (contactId, currentTs, connId)
|
||||
getContact db vr user contactId
|
||||
getContact db cxt user contactId
|
||||
|
||||
deleteContactConnections :: DB.Connection -> User -> Contact -> IO ()
|
||||
deleteContactConnections db User {userId} Contact {contactId} = do
|
||||
@@ -500,13 +500,13 @@ deleteContactWithoutGroups db user@User {userId} ct@Contact {contactId, localDis
|
||||
deleteUnusedIncognitoProfileById_ db user profileId
|
||||
|
||||
-- TODO remove in future versions: only used for legacy contact cleanup
|
||||
getDeletedContacts :: DB.Connection -> VersionRangeChat -> User -> IO [Contact]
|
||||
getDeletedContacts db vr user@User {userId} = do
|
||||
getDeletedContacts :: DB.Connection -> StoreCxt -> User -> IO [Contact]
|
||||
getDeletedContacts db cxt user@User {userId} = do
|
||||
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 1" (Only userId)
|
||||
rights <$> mapM (runExceptT . getDeletedContact db vr user) contactIds
|
||||
rights <$> mapM (runExceptT . getDeletedContact db cxt user) contactIds
|
||||
|
||||
getDeletedContact :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO Contact
|
||||
getDeletedContact db vr user contactId = getContact_ db vr user contactId True
|
||||
getDeletedContact :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO Contact
|
||||
getDeletedContact db cxt user contactId = getContact_ db cxt user contactId True
|
||||
|
||||
deleteContactProfile_ :: DB.Connection -> UserId -> ContactId -> IO ()
|
||||
deleteContactProfile_ db userId contactId =
|
||||
@@ -756,15 +756,15 @@ updateContactLDN_ db user@User {userId} contactId displayName newName updatedAt
|
||||
(newName, updatedAt, userId, contactId)
|
||||
safeDeleteLDN db user displayName
|
||||
|
||||
getContactByName :: DB.Connection -> VersionRangeChat -> User -> ContactName -> ExceptT StoreError IO Contact
|
||||
getContactByName db vr user localDisplayName = do
|
||||
getContactByName :: DB.Connection -> StoreCxt -> User -> ContactName -> ExceptT StoreError IO Contact
|
||||
getContactByName db cxt user localDisplayName = do
|
||||
cId <- getContactIdByName db user localDisplayName
|
||||
getContact db vr user cId
|
||||
getContact db cxt user cId
|
||||
|
||||
getUserContacts :: DB.Connection -> VersionRangeChat -> User -> IO [Contact]
|
||||
getUserContacts db vr user@User {userId} = do
|
||||
getUserContacts :: DB.Connection -> StoreCxt -> User -> IO [Contact]
|
||||
getUserContacts db cxt user@User {userId} = do
|
||||
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId)
|
||||
contacts <- rights <$> mapM (runExceptT . getContact db vr user) contactIds
|
||||
contacts <- rights <$> mapM (runExceptT . getContact db cxt user) contactIds
|
||||
pure $ filter (\Contact {activeConn} -> isJust activeConn) contacts
|
||||
|
||||
getUserContactLinkIdByCReq :: DB.Connection -> Int64 -> ExceptT StoreError IO (Maybe Int64)
|
||||
@@ -890,22 +890,22 @@ getContactIdByName db User {userId} cName =
|
||||
ExceptT . firstRow fromOnly (SEContactNotFoundByName cName) $
|
||||
DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND local_display_name = ? AND deleted = 0" (userId, cName)
|
||||
|
||||
getContactViaShortLinkToConnect :: forall c. ConnectionModeI c => DB.Connection -> VersionRangeChat -> User -> ConnShortLink c -> ExceptT StoreError IO (Maybe (ConnectionRequestUri c, Contact))
|
||||
getContactViaShortLinkToConnect db vr user@User {userId} shortLink = do
|
||||
getContactViaShortLinkToConnect :: forall c. ConnectionModeI c => DB.Connection -> StoreCxt -> User -> ConnShortLink c -> ExceptT StoreError IO (Maybe (ConnectionRequestUri c, Contact))
|
||||
getContactViaShortLinkToConnect db cxt user@User {userId} shortLink = do
|
||||
liftIO (maybeFirstRow id $ DB.query db "SELECT contact_id, conn_full_link_to_connect FROM contacts WHERE user_id = ? AND conn_short_link_to_connect = ?" (userId, shortLink)) >>= \case
|
||||
Just (ctId :: Int64, Just (ACR cMode cReq)) ->
|
||||
case testEquality cMode (sConnectionMode @c) of
|
||||
Just Refl -> Just . (cReq,) <$> getContact db vr user ctId
|
||||
Just Refl -> Just . (cReq,) <$> getContact db cxt user ctId
|
||||
Nothing -> pure Nothing
|
||||
_ -> pure Nothing
|
||||
|
||||
getContact :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO Contact
|
||||
getContact db vr user contactId = getContact_ db vr user contactId False
|
||||
getContact :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO Contact
|
||||
getContact db cxt user contactId = getContact_ db cxt user contactId False
|
||||
|
||||
getContact_ :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
|
||||
getContact_ db vr user@User {userId} contactId deleted = do
|
||||
getContact_ :: DB.Connection -> StoreCxt -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
|
||||
getContact_ db cxt user@User {userId} contactId deleted = do
|
||||
chatTags <- liftIO $ getDirectChatTags db contactId
|
||||
ExceptT . firstRow (toContact vr user chatTags) (SEContactNotFound contactId) $
|
||||
ExceptT . firstRow (toContact cxt user chatTags) (SEContactNotFound contactId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -932,8 +932,8 @@ getUserByContactRequestId db contactRequestId =
|
||||
ExceptT . firstRow toUser (SEUserNotFoundByContactRequestId contactRequestId) $
|
||||
DB.query db (userQuery <> " JOIN contact_requests cr ON cr.user_id = u.user_id WHERE cr.contact_request_id = ?") (Only contactRequestId)
|
||||
|
||||
getContactConnections :: DB.Connection -> VersionRangeChat -> UserId -> Contact -> IO [Connection]
|
||||
getContactConnections db vr userId Contact {contactId} =
|
||||
getContactConnections :: DB.Connection -> StoreCxt -> UserId -> Contact -> IO [Connection]
|
||||
getContactConnections db cxt userId Contact {contactId} =
|
||||
connections =<< liftIO getConnections_
|
||||
where
|
||||
getConnections_ =
|
||||
@@ -950,11 +950,11 @@ getContactConnections db vr userId Contact {contactId} =
|
||||
|]
|
||||
(userId, userId, contactId)
|
||||
connections [] = pure []
|
||||
connections rows = pure $ map (toConnection vr) rows
|
||||
connections rows = pure $ map (toConnection cxt) rows
|
||||
|
||||
getConnectionById :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO Connection
|
||||
getConnectionById db vr User {userId} connId = ExceptT $ do
|
||||
firstRow (toConnection vr) (SEConnectionNotFoundById connId) $
|
||||
getConnectionById :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO Connection
|
||||
getConnectionById db cxt User {userId} connId = ExceptT $ do
|
||||
firstRow (toConnection cxt) (SEConnectionNotFoundById connId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
|
||||
@@ -570,19 +570,19 @@ getRcvFileTransfer_ db userId fileId = do
|
||||
Just fp -> pure fp
|
||||
cancelled = maybe False unBI cancelled_
|
||||
|
||||
acceptRcvInlineFT :: DB.Connection -> VersionRangeChat -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
|
||||
acceptRcvInlineFT db vr user fileId filePath = do
|
||||
acceptRcvInlineFT :: DB.Connection -> StoreCxt -> User -> FileTransferId -> FilePath -> ExceptT StoreError IO AChatItem
|
||||
acceptRcvInlineFT db cxt user fileId filePath = do
|
||||
liftIO $ acceptRcvFT_ db user fileId filePath False (Just IFMOffer) =<< getCurrentTime
|
||||
getChatItemByFileId db vr user fileId
|
||||
getChatItemByFileId db cxt user fileId
|
||||
|
||||
startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> Maybe InlineFileMode -> IO ()
|
||||
startRcvInlineFT db user RcvFileTransfer {fileId} filePath rcvFileInline =
|
||||
acceptRcvFT_ db user fileId filePath False rcvFileInline =<< getCurrentTime
|
||||
|
||||
xftpAcceptRcvFT :: DB.Connection -> VersionRangeChat -> User -> FileTransferId -> FilePath -> Bool -> ExceptT StoreError IO AChatItem
|
||||
xftpAcceptRcvFT db vr user fileId filePath userApprovedRelays = do
|
||||
xftpAcceptRcvFT :: DB.Connection -> StoreCxt -> User -> FileTransferId -> FilePath -> Bool -> ExceptT StoreError IO AChatItem
|
||||
xftpAcceptRcvFT db cxt user fileId filePath userApprovedRelays = do
|
||||
liftIO $ acceptRcvFT_ db user fileId filePath userApprovedRelays Nothing =<< getCurrentTime
|
||||
getChatItemByFileId db vr user fileId
|
||||
getChatItemByFileId db cxt user fileId
|
||||
|
||||
acceptRcvFT_ :: DB.Connection -> User -> FileTransferId -> FilePath -> Bool -> Maybe InlineFileMode -> UTCTime -> IO ()
|
||||
acceptRcvFT_ db User {userId} fileId filePath userApprovedRelays rcvFileInline currentTs = do
|
||||
@@ -860,9 +860,9 @@ getLocalCryptoFile db userId fileId sent =
|
||||
pure $ CryptoFile filePath fileCryptoArgs
|
||||
_ -> throwError $ SEFileNotFound fileId
|
||||
|
||||
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> VersionRangeChat -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
|
||||
updateDirectCIFileStatus db vr user fileId fileStatus = do
|
||||
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db vr user fileId
|
||||
updateDirectCIFileStatus :: forall d. MsgDirectionI d => DB.Connection -> StoreCxt -> User -> Int64 -> CIFileStatus d -> ExceptT StoreError IO AChatItem
|
||||
updateDirectCIFileStatus db cxt user fileId fileStatus = do
|
||||
aci@(AChatItem cType d cInfo ci) <- getChatItemByFileId db cxt user fileId
|
||||
case (cType, testEquality d $ msgDirection @d) of
|
||||
(SCTDirect, Just Refl) -> do
|
||||
liftIO $ updateCIFileStatus db user fileId fileStatus
|
||||
|
||||
+207
-207
@@ -247,9 +247,9 @@ createGroupLink db gVar user@User {userId} groupInfo@GroupInfo {groupId, localDi
|
||||
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId ConnNew initialChatVersion chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode PQSupportOff
|
||||
getGroupLink db user groupInfo
|
||||
|
||||
getGroupLinkConnection :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> ExceptT StoreError IO Connection
|
||||
getGroupLinkConnection db vr User {userId} groupInfo@GroupInfo {groupId} =
|
||||
ExceptT . firstRow (toConnection vr) (SEGroupLinkNotFound groupInfo) $
|
||||
getGroupLinkConnection :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ExceptT StoreError IO Connection
|
||||
getGroupLinkConnection db cxt User {userId} groupInfo@GroupInfo {groupId} =
|
||||
ExceptT . firstRow (toConnection cxt) (SEGroupLinkNotFound groupInfo) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -344,8 +344,8 @@ setGroupLinkShortLink db gLnk@GroupLink {userContactLinkId, connLinkContact = CC
|
||||
pure gLnk {connLinkContact = CCLink connFullLink (Just shortLink), shortLinkDataSet = True, shortLinkLargeDataSet = BoolDef True}
|
||||
|
||||
-- | creates completely new group with a single member - the current user
|
||||
createNewGroup :: DB.Connection -> VersionRangeChat -> User -> GroupProfile -> Maybe Profile -> Bool -> MemberId -> Maybe GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
|
||||
createNewGroup db vr user@User {userId} groupProfile incognitoProfile useRelays memberId groupKeys publicMemberCount_ = ExceptT $ do
|
||||
createNewGroup :: DB.Connection -> StoreCxt -> User -> GroupProfile -> Maybe Profile -> Bool -> MemberId -> Maybe GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
|
||||
createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays memberId groupKeys publicMemberCount_ = ExceptT $ do
|
||||
let GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission} = groupProfile
|
||||
(groupType_, groupLink_, publicGroupId_) = case publicGroup of
|
||||
Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
|
||||
@@ -389,7 +389,7 @@ createNewGroup db vr user@User {userId} groupProfile incognitoProfile useRelays
|
||||
)
|
||||
insertedRowId db
|
||||
let memberPubKey = C.publicKey . memberPrivKey <$> groupKeys
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole memberId GROwner) GCUserMember GSMemCreator IBUser customUserProfileId memberPubKey currentTs vr
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole memberId GROwner) GCUserMember GSMemCreator IBUser customUserProfileId memberPubKey currentTs (vr cxt)
|
||||
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
|
||||
pure
|
||||
GroupInfo
|
||||
@@ -419,13 +419,13 @@ createNewGroup db vr user@User {userId} groupProfile incognitoProfile useRelays
|
||||
}
|
||||
|
||||
-- | creates a new group record for the group the current user was invited to, or returns an existing one
|
||||
createGroupInvitation :: DB.Connection -> VersionRangeChat -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
|
||||
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
|
||||
createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile, business} incognitoProfileId = do
|
||||
createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile, business} incognitoProfileId = do
|
||||
liftIO getInvitationGroupId_ >>= \case
|
||||
Nothing -> createGroupInvitation_
|
||||
Just gId -> do
|
||||
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db vr user gId
|
||||
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db cxt user gId
|
||||
hostId <- getHostMemberId_ db user gId
|
||||
let GroupMember {groupMemberId, memberId, memberRole} = membership
|
||||
MemberIdRole {memberId = invMemberId, memberRole = invMemberRole} = invitedMember
|
||||
@@ -464,9 +464,9 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ
|
||||
|]
|
||||
((profileId, localDisplayName, connRequest, userId, BI True, currentTs, currentTs, currentTs, currentTs) :. businessChatInfoRow business)
|
||||
insertedRowId db
|
||||
let hostVRange = adjustedMemberVRange vr peerChatVRange
|
||||
let hostVRange = adjustedMemberVRange (vr cxt) peerChatVRange
|
||||
GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId Nothing contact fromMember GCHostMember GSMemInvited IBUnknown Nothing Nothing currentTs hostVRange
|
||||
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId Nothing currentTs vr
|
||||
membership <- createContactMemberInv_ db user groupId (Just groupMemberId) user invitedMember GCUserMember GSMemInvited (IBContact contactId) incognitoProfileId Nothing currentTs (vr cxt)
|
||||
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
|
||||
pure
|
||||
( GroupInfo
|
||||
@@ -608,8 +608,8 @@ deleteContactCardKeepConn db connId Contact {contactId, profile = LocalProfile {
|
||||
DB.execute db "DELETE FROM contacts WHERE contact_id = ?" (Only contactId)
|
||||
DB.execute db "DELETE FROM contact_profiles WHERE contact_profile_id = ?" (Only profileId)
|
||||
|
||||
createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> VersionRangeChat -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> GroupMemberRole -> Maybe Int64 -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember)
|
||||
createPreparedGroup db gVar vr user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays userMemberRole publicMemberCount_ = do
|
||||
createPreparedGroup :: DB.Connection -> TVar ChaChaDRG -> StoreCxt -> User -> GroupProfile -> Bool -> CreatedLinkContact -> Maybe SharedMsgId -> Bool -> GroupMemberRole -> Maybe Int64 -> ExceptT StoreError IO (GroupInfo, Maybe GroupMember)
|
||||
createPreparedGroup db gVar cxt user@User {userId, userContactId} groupProfile business connLinkToConnect welcomeSharedMsgId useRelays userMemberRole publicMemberCount_ = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let prepared = Just (connLinkToConnect, welcomeSharedMsgId)
|
||||
(groupId, groupLDN) <- createGroup_ db userId groupProfile prepared Nothing useRelays Nothing publicMemberCount_ currentTs
|
||||
@@ -623,11 +623,11 @@ createPreparedGroup db gVar vr user@User {userId, userContactId} groupProfile bu
|
||||
else pure $ MemberId $ encodeUtf8 groupLDN <> "_user_unknown_id"
|
||||
let userMember = MemberIdRole userMemberId userMemberRole
|
||||
-- TODO [member keys] user key must be included here. Should key be added when group is prepared?
|
||||
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs vr
|
||||
hostMember_ <- forM hostMemberId_ $ getGroupMember db vr user groupId
|
||||
membership <- createContactMemberInv_ db user groupId hostMemberId_ user userMember GCUserMember GSMemUnknown IBUnknown Nothing Nothing currentTs (vr cxt)
|
||||
hostMember_ <- forM hostMemberId_ $ getGroupMember db cxt user groupId
|
||||
forM_ hostMember_ $ \hostMember ->
|
||||
when business $ liftIO $ setGroupBusinessChatInfo groupId membership hostMember
|
||||
g <- getGroupInfo db vr user groupId
|
||||
g <- getGroupInfo db cxt user groupId
|
||||
pure (g, hostMember_)
|
||||
where
|
||||
insertHost_ currentTs groupId groupLDN = do
|
||||
@@ -667,13 +667,13 @@ updateBusinessChatInfo db groupId businessChatInfo =
|
||||
|]
|
||||
(businessChatInfoRow businessChatInfo :. (Only groupId))
|
||||
|
||||
updatePreparedGroupUser :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupMember -> User -> ExceptT StoreError IO GroupInfo
|
||||
updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMember_ newUser@User {userId = newUserId} = do
|
||||
updatePreparedGroupUser :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe GroupMember -> User -> ExceptT StoreError IO GroupInfo
|
||||
updatePreparedGroupUser db cxt user gInfo@GroupInfo {groupId, membership} hostMember_ newUser@User {userId = newUserId} = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
updateGroup gInfo currentTs
|
||||
liftIO $ updateMembership membership currentTs
|
||||
forM_ hostMember_ $ \hostMember -> updateHostMember hostMember currentTs
|
||||
getGroupInfo db vr newUser groupId
|
||||
getGroupInfo db cxt newUser groupId
|
||||
where
|
||||
updateGroup GroupInfo {localDisplayName = oldGroupLDN, groupProfile = GroupProfile {displayName = groupDisplayName}} currentTs =
|
||||
ExceptT . withLocalDisplayName db newUserId groupDisplayName $ \newGroupLDN -> runExceptT $ do
|
||||
@@ -739,21 +739,21 @@ updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMem
|
||||
(newUserId, currentTs, hostProfileId)
|
||||
safeDeleteLDN db user oldHostLDN
|
||||
|
||||
updatePreparedUserAndHostMembersInvited :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
updatePreparedUserAndHostMembersInvited db vr user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
updatePreparedUserAndHostMembersInvited :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
updatePreparedUserAndHostMembersInvited db cxt user gInfo hostMember GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
let fromMemberProfile = profileFromName fromMemberName
|
||||
initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
|
||||
updatePreparedUserAndHostMembers' db vr user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
|
||||
updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile business initialStatus
|
||||
|
||||
updatePreparedUserAndHostMembersRejected :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
updatePreparedUserAndHostMembersRejected db vr user gInfo hostMember GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
|
||||
updatePreparedUserAndHostMembersRejected :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
updatePreparedUserAndHostMembersRejected db cxt user gInfo hostMember GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
|
||||
let fromMemberProfile = profileFromName $ nameFromMemberId memberId
|
||||
updatePreparedUserAndHostMembers' db vr user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
|
||||
updatePreparedUserAndHostMembers' db cxt user gInfo hostMember fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
|
||||
|
||||
updatePreparedUserAndHostMembers' :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
updatePreparedUserAndHostMembers' :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
updatePreparedUserAndHostMembers'
|
||||
db
|
||||
vr
|
||||
cxt
|
||||
user
|
||||
gInfo@GroupInfo {groupId, membership, groupProfile = gp, businessChat}
|
||||
hostMember
|
||||
@@ -772,7 +772,7 @@ updatePreparedUserAndHostMembers'
|
||||
void $ updateGroupProfile db user gInfo groupProfile
|
||||
when (isJust businessChat && isJust business) $
|
||||
liftIO $ updateBusinessChatInfo db groupId business
|
||||
gInfo' <- getGroupInfo db vr user groupId
|
||||
gInfo' <- getGroupInfo db cxt user groupId
|
||||
pure (gInfo', hostMember')
|
||||
where
|
||||
updateUserMember currentTs = do
|
||||
@@ -803,23 +803,23 @@ updatePreparedUserAndHostMembers'
|
||||
WHERE group_member_id = ?
|
||||
|]
|
||||
(memberId, memberRole, currentTs, gmId)
|
||||
getGroupMemberById db vr user gmId
|
||||
getGroupMemberById db cxt user gmId
|
||||
|
||||
createGroupInvitedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupInvitedViaLink db vr user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
createGroupInvitedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkInvitation -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupInvitedViaLink db cxt user conn GroupLinkInvitation {fromMember, fromMemberName, invitedMember, groupProfile, accepted, business} = do
|
||||
let fromMemberProfile = profileFromName fromMemberName
|
||||
initialStatus = maybe GSMemAccepted (acceptanceToStatus $ memberAdmission groupProfile) accepted
|
||||
createGroupViaLink' db vr user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus
|
||||
createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile business initialStatus
|
||||
|
||||
createGroupRejectedViaLink :: DB.Connection -> VersionRangeChat -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupRejectedViaLink db vr user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
|
||||
createGroupRejectedViaLink :: DB.Connection -> StoreCxt -> User -> Connection -> GroupLinkRejection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupRejectedViaLink db cxt user conn GroupLinkRejection {fromMember = fromMember@MemberIdRole {memberId}, invitedMember, groupProfile} = do
|
||||
let fromMemberProfile = profileFromName $ nameFromMemberId memberId
|
||||
createGroupViaLink' db vr user conn fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
|
||||
createGroupViaLink' db cxt user conn fromMember fromMemberProfile invitedMember groupProfile Nothing GSMemRejected
|
||||
|
||||
createGroupViaLink' :: DB.Connection -> VersionRangeChat -> User -> Connection -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupViaLink' :: DB.Connection -> StoreCxt -> User -> Connection -> MemberIdRole -> Profile -> MemberIdRole -> GroupProfile -> Maybe BusinessChatInfo -> GroupMemberStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createGroupViaLink'
|
||||
db
|
||||
vr
|
||||
cxt
|
||||
user@User {userId, userContactId}
|
||||
Connection {connId, customUserProfileId}
|
||||
fromMember
|
||||
@@ -834,9 +834,9 @@ createGroupViaLink'
|
||||
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
|
||||
-- TODO [member keys] this is currently not used with public groups. If it needs to be used, member keys need to be added
|
||||
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId Nothing currentTs vr
|
||||
void $ createContactMemberInv_ db user groupId (Just hostMemberId) user invitedMember GCUserMember membershipStatus IBUnknown customUserProfileId Nothing currentTs (vr cxt)
|
||||
liftIO $ setViaGroupLinkUri db groupId connId
|
||||
(,) <$> getGroupInfo db vr user groupId <*> getGroupMemberById db vr user hostMemberId
|
||||
(,) <$> getGroupInfo db cxt user groupId <*> getGroupMemberById db cxt user hostMemberId
|
||||
where
|
||||
insertHost_ currentTs groupId = do
|
||||
(localDisplayName, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
|
||||
@@ -897,10 +897,10 @@ setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
|
||||
|
||||
-- TODO return the last connection that is ready, not any last connection
|
||||
-- requires updating connection status
|
||||
getGroup :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO Group
|
||||
getGroup db vr user groupId = do
|
||||
gInfo <- getGroupInfo db vr user groupId
|
||||
members <- liftIO $ getGroupMembers db vr user gInfo
|
||||
getGroup :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO Group
|
||||
getGroup db cxt user groupId = do
|
||||
gInfo <- getGroupInfo db cxt user groupId
|
||||
members <- liftIO $ getGroupMembers db cxt user gInfo
|
||||
pure $ Group gInfo members
|
||||
|
||||
deleteGroupChatItems :: DB.Connection -> User -> GroupInfo -> IO ()
|
||||
@@ -994,18 +994,18 @@ deleteGroupProfile_ db userId groupId =
|
||||
|]
|
||||
(userId, groupId)
|
||||
|
||||
getInProgressGroups :: DB.Connection -> VersionRangeChat -> User -> UTCTime -> IO [GroupInfo]
|
||||
getInProgressGroups db vr user@User {userId} createdAtCutoff = do
|
||||
getInProgressGroups :: DB.Connection -> StoreCxt -> User -> UTCTime -> IO [GroupInfo]
|
||||
getInProgressGroups db cxt user@User {userId} createdAtCutoff = do
|
||||
groupIds <- map fromOnly <$>
|
||||
DB.query
|
||||
db
|
||||
"SELECT group_id FROM groups WHERE user_id = ? AND creating_in_progress = 1 AND created_at <= ?"
|
||||
(userId, createdAtCutoff)
|
||||
rights <$> mapM (runExceptT . getGroupInfo db vr user) groupIds
|
||||
rights <$> mapM (runExceptT . getGroupInfo db cxt user) groupIds
|
||||
|
||||
getBaseGroupDetails :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe Text -> IO [GroupInfo]
|
||||
getBaseGroupDetails db vr User {userId, userContactId} _contactId_ search_ = do
|
||||
map (toGroupInfo vr userContactId [])
|
||||
getBaseGroupDetails :: DB.Connection -> StoreCxt -> User -> Maybe ContactId -> Maybe Text -> IO [GroupInfo]
|
||||
getBaseGroupDetails db cxt User {userId, userContactId} _contactId_ search_ = do
|
||||
map (toGroupInfo cxt userContactId [])
|
||||
<$> DB.query db (groupInfoQuery <> " " <> condition) (userId, userContactId, search, search, search, search)
|
||||
where
|
||||
condition =
|
||||
@@ -1033,22 +1033,22 @@ getContactGroupPreferences db User {userId} Contact {contactId} = do
|
||||
|]
|
||||
(userId, contactId)
|
||||
|
||||
getGroupInfoByName :: DB.Connection -> VersionRangeChat -> User -> GroupName -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfoByName db vr user gName = do
|
||||
getGroupInfoByName :: DB.Connection -> StoreCxt -> User -> GroupName -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfoByName db cxt user gName = do
|
||||
gId <- getGroupIdByName db user gName
|
||||
getGroupInfo db vr user gId
|
||||
getGroupInfo db cxt user gId
|
||||
|
||||
getGroupMember :: DB.Connection -> VersionRangeChat -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember
|
||||
getGroupMember db vr user@User {userId} groupId groupMemberId =
|
||||
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $
|
||||
getGroupMember :: DB.Connection -> StoreCxt -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember
|
||||
getGroupMember db cxt user@User {userId} groupId groupMemberId =
|
||||
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFound groupMemberId) $
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.group_member_id = ? AND m.user_id = ?")
|
||||
(groupId, groupMemberId, userId)
|
||||
|
||||
getHostMember :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO GroupMember
|
||||
getHostMember db vr user groupId =
|
||||
ExceptT . firstRow (toContactMember vr user) (SEGroupHostMemberNotFound groupId) $
|
||||
getHostMember :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO GroupMember
|
||||
getHostMember db cxt user groupId =
|
||||
ExceptT . firstRow (toContactMember cxt user) (SEGroupHostMemberNotFound groupId) $
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.member_category = ?")
|
||||
@@ -1087,46 +1087,46 @@ toMentionedMember (groupMemberId, memberId, memberRole, displayName, localAlias)
|
||||
let memberRef = Just CIMentionMember {groupMemberId, displayName, localAlias, memberRole}
|
||||
in CIMention {memberId, memberRef}
|
||||
|
||||
getGroupMemberById :: DB.Connection -> VersionRangeChat -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
|
||||
getGroupMemberById db vr user@User {userId} groupMemberId =
|
||||
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFound groupMemberId) $
|
||||
getGroupMemberById :: DB.Connection -> StoreCxt -> User -> GroupMemberId -> ExceptT StoreError IO GroupMember
|
||||
getGroupMemberById db cxt user@User {userId} groupMemberId =
|
||||
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFound groupMemberId) $
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_member_id = ? AND m.user_id = ?")
|
||||
(groupMemberId, userId)
|
||||
|
||||
getGroupMemberByIndex :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupMember
|
||||
getGroupMemberByIndex db vr user GroupInfo {groupId} indexInGroup =
|
||||
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFoundByIndex indexInGroup) $
|
||||
getGroupMemberByIndex :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupMember
|
||||
getGroupMemberByIndex db cxt user GroupInfo {groupId} indexInGroup =
|
||||
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByIndex indexInGroup) $
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group = ?")
|
||||
(groupId, indexInGroup)
|
||||
|
||||
getSupportScopeMemberByIndex :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMemberId -> Int64 -> ExceptT StoreError IO GroupMember
|
||||
getSupportScopeMemberByIndex db vr user GroupInfo {groupId} scopeGMId indexInGroup =
|
||||
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFoundByIndex indexInGroup) $
|
||||
getSupportScopeMemberByIndex :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMemberId -> Int64 -> ExceptT StoreError IO GroupMember
|
||||
getSupportScopeMemberByIndex db cxt user GroupInfo {groupId} scopeGMId indexInGroup =
|
||||
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByIndex indexInGroup) $
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group = ? AND (m.member_role IN (?,?,?) OR m.group_member_id = ?)")
|
||||
(groupId, indexInGroup, GRModerator, GRAdmin, GROwner, scopeGMId)
|
||||
|
||||
getGroupMemberByMemberId :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMember
|
||||
getGroupMemberByMemberId db vr user GroupInfo {groupId} memberId =
|
||||
ExceptT . firstRow (toContactMember vr user) (SEGroupMemberNotFoundByMemberId memberId) $
|
||||
getGroupMemberByMemberId :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> ExceptT StoreError IO GroupMember
|
||||
getGroupMemberByMemberId db cxt user GroupInfo {groupId} memberId =
|
||||
ExceptT . firstRow (toContactMember cxt user) (SEGroupMemberNotFoundByMemberId memberId) $
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.member_id = ?")
|
||||
(groupId, memberId)
|
||||
|
||||
getCreateUnknownGMByMemberId :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> ContactName -> GroupMemberRole -> Bool -> ExceptT StoreError IO (Maybe (GroupMember, Bool))
|
||||
getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownMemberRole allowCreate = do
|
||||
liftIO (runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case
|
||||
getCreateUnknownGMByMemberId :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> ContactName -> GroupMemberRole -> Bool -> ExceptT StoreError IO (Maybe (GroupMember, Bool))
|
||||
getCreateUnknownGMByMemberId db cxt user gInfo memberId memberName unknownMemberRole allowCreate = do
|
||||
liftIO (runExceptT $ getGroupMemberByMemberId db cxt user gInfo memberId) >>= \case
|
||||
Right m -> pure $ Just (m, False)
|
||||
Left (SEGroupMemberNotFoundByMemberId _)
|
||||
| allowCreate -> do
|
||||
let name = if T.null memberName then nameFromMemberId memberId else memberName
|
||||
m <- createNewUnknownGroupMember db vr user gInfo memberId name unknownMemberRole
|
||||
m <- createNewUnknownGroupMember db cxt user gInfo memberId name unknownMemberRole
|
||||
pure $ Just (m, True)
|
||||
| otherwise -> pure Nothing
|
||||
Left e -> throwError e
|
||||
@@ -1145,59 +1145,59 @@ getGroupMemberIdViaMemberId db User {userId} GroupInfo {groupId} memberId =
|
||||
"SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND member_id = ?"
|
||||
(userId, groupId, memberId)
|
||||
|
||||
getGroupMembers :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupMembers db vr user@User {userId, userContactId} GroupInfo {groupId} =
|
||||
map (toContactMember vr user)
|
||||
getGroupMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} =
|
||||
map (toContactMember cxt user)
|
||||
<$> DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?)")
|
||||
(userId, groupId, userContactId)
|
||||
|
||||
getGroupMembersByIndexes :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> [Int64] -> IO [GroupMember]
|
||||
getGroupMembersByIndexes db vr user gInfo indexesInGroup = do
|
||||
getGroupMembersByIndexes :: DB.Connection -> StoreCxt -> User -> GroupInfo -> [Int64] -> IO [GroupMember]
|
||||
getGroupMembersByIndexes db cxt user gInfo indexesInGroup = do
|
||||
#if defined(dbPostgres)
|
||||
let GroupInfo {groupId} = gInfo
|
||||
map (toContactMember vr user) <$>
|
||||
map (toContactMember cxt user) <$>
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group IN ?")
|
||||
(groupId, In indexesInGroup)
|
||||
#else
|
||||
rights <$> mapM (runExceptT . getGroupMemberByIndex db vr user gInfo) indexesInGroup
|
||||
rights <$> mapM (runExceptT . getGroupMemberByIndex db cxt user gInfo) indexesInGroup
|
||||
#endif
|
||||
|
||||
getSupportScopeMembersByIndexes :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMemberId -> [Int64] -> IO [GroupMember]
|
||||
getSupportScopeMembersByIndexes db vr user gInfo scopeGMId indexesInGroup = do
|
||||
getSupportScopeMembersByIndexes :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMemberId -> [Int64] -> IO [GroupMember]
|
||||
getSupportScopeMembersByIndexes db cxt user gInfo scopeGMId indexesInGroup = do
|
||||
#if defined(dbPostgres)
|
||||
let GroupInfo {groupId} = gInfo
|
||||
map (toContactMember vr user) <$>
|
||||
map (toContactMember cxt user) <$>
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.index_in_group IN ? AND (m.member_role IN (?,?,?) OR m.group_member_id = ?)")
|
||||
(groupId, In indexesInGroup, GRModerator, GRAdmin, GROwner, scopeGMId)
|
||||
#else
|
||||
rights <$> mapM (runExceptT . getSupportScopeMemberByIndex db vr user gInfo scopeGMId) indexesInGroup
|
||||
rights <$> mapM (runExceptT . getSupportScopeMemberByIndex db cxt user gInfo scopeGMId) indexesInGroup
|
||||
#endif
|
||||
|
||||
getGroupModerators :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupModerators db vr user@User {userId, userContactId} GroupInfo {groupId} = do
|
||||
map (toContactMember vr user)
|
||||
getGroupModerators :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupModerators db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
|
||||
map (toContactMember cxt user)
|
||||
<$> DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND (m.contact_id IS NULL OR m.contact_id != ?) AND m.member_role IN (?,?,?)")
|
||||
(userId, groupId, userContactId, GRModerator, GRAdmin, GROwner)
|
||||
|
||||
getGroupRelayMembers :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupRelayMembers db vr user@User {userId, userContactId} GroupInfo {groupId} = do
|
||||
map (toContactMember vr user)
|
||||
getGroupRelayMembers :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupRelayMembers db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
|
||||
map (toContactMember cxt user)
|
||||
<$> DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.user_id = ? AND m.group_id = ? AND m.contact_id IS DISTINCT FROM ? AND m.member_role = ?")
|
||||
(userId, groupId, userContactId, GRRelay)
|
||||
|
||||
getGroupMembersForExpiration :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupMembersForExpiration db vr user@User {userId, userContactId} GroupInfo {groupId} = do
|
||||
map (toContactMember vr user)
|
||||
getGroupMembersForExpiration :: DB.Connection -> StoreCxt -> User -> GroupInfo -> IO [GroupMember]
|
||||
getGroupMembersForExpiration db cxt user@User {userId, userContactId} GroupInfo {groupId} = do
|
||||
map (toContactMember cxt user)
|
||||
<$> DB.query
|
||||
db
|
||||
( groupMemberQuery
|
||||
@@ -1212,14 +1212,14 @@ getGroupMembersForExpiration db vr user@User {userId, userContactId} GroupInfo {
|
||||
)
|
||||
(groupId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown)
|
||||
|
||||
getGroupInvitation :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
|
||||
getGroupInvitation db vr user groupId =
|
||||
getGroupInvitation :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO ReceivedGroupInvitation
|
||||
getGroupInvitation db cxt user groupId =
|
||||
getConnRec_ user >>= \case
|
||||
Just connRequest -> do
|
||||
groupInfo@GroupInfo {membership} <- getGroupInfo db vr user groupId
|
||||
groupInfo@GroupInfo {membership} <- getGroupInfo db cxt user groupId
|
||||
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
|
||||
hostId <- getHostMemberId_ db user groupId
|
||||
fromMember <- getGroupMember db vr user groupId hostId
|
||||
fromMember <- getGroupMember db cxt user groupId hostId
|
||||
pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo}
|
||||
_ -> throwError SEGroupInvitationNotFound
|
||||
where
|
||||
@@ -1357,8 +1357,8 @@ toGroupRelay ((groupRelayId, groupMemberId, chatRelayId, address, displayName, f
|
||||
relayCap = RelayCapabilities {webDomain}
|
||||
in GroupRelay {groupRelayId, groupMemberId, userChatRelay, relayStatus, relayLink, relayCap}
|
||||
|
||||
createRelayForOwner :: DB.Connection -> VersionRangeChat -> TVar ChaChaDRG -> User -> GroupInfo -> UserChatRelay -> ExceptT StoreError IO GroupMember
|
||||
createRelayForOwner db vr gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {relayProfile = RelayProfile {displayName}} = do
|
||||
createRelayForOwner :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> UserChatRelay -> ExceptT StoreError IO GroupMember
|
||||
createRelayForOwner db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, membership} UserChatRelay {relayProfile = RelayProfile {displayName}} = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let relayProfile = profileFromName displayName
|
||||
(localDisplayName, memProfileId) <- createNewMemberProfile_ db user relayProfile currentTs
|
||||
@@ -1377,14 +1377,14 @@ createRelayForOwner db vr gVar user@User {userId, userContactId} GroupInfo {grou
|
||||
:. (userId, localDisplayName, memProfileId, currentTs, currentTs)
|
||||
)
|
||||
liftIO $ insertedRowId db
|
||||
getGroupMemberById db vr user groupMemberId
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
|
||||
getCreateRelayForMember :: DB.Connection -> VersionRangeChat -> TVar ChaChaDRG -> User -> GroupInfo -> ShortLinkContact -> ExceptT StoreError IO GroupMember
|
||||
getCreateRelayForMember db vr gVar user@User {userId, userContactId} GroupInfo {groupId, localDisplayName = groupLDN} relayLink =
|
||||
getCreateRelayForMember :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> GroupInfo -> ShortLinkContact -> ExceptT StoreError IO GroupMember
|
||||
getCreateRelayForMember db cxt gVar user@User {userId, userContactId} GroupInfo {groupId, localDisplayName = groupLDN} relayLink =
|
||||
liftIO getGroupMemberByRelayLink >>= maybe createRelayMember pure
|
||||
where
|
||||
getGroupMemberByRelayLink =
|
||||
maybeFirstRow (toContactMember vr user) $
|
||||
maybeFirstRow (toContactMember cxt user) $
|
||||
DB.query
|
||||
db
|
||||
#if defined(dbPostgres)
|
||||
@@ -1415,10 +1415,10 @@ getCreateRelayForMember db vr gVar user@User {userId, userContactId} GroupInfo {
|
||||
:. (userId, localDisplayName, profileId, currentTs, currentTs, relayLink)
|
||||
)
|
||||
insertedRowId db
|
||||
getGroupMember db vr user groupId groupMemberId
|
||||
getGroupMember db cxt user groupId groupMemberId
|
||||
|
||||
createRelayConnection :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
|
||||
createRelayConnection db vr user@User {userId} groupMemberId agentConnId connStatus chatV subMode = do
|
||||
createRelayConnection :: DB.Connection -> StoreCxt -> User -> Int64 -> ConnId -> ConnStatus -> VersionChat -> SubscriptionMode -> ExceptT StoreError IO Connection
|
||||
createRelayConnection db cxt user@User {userId} groupMemberId agentConnId connStatus chatV subMode = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -1435,7 +1435,7 @@ createRelayConnection db vr user@User {userId} groupMemberId agentConnId connSta
|
||||
:. (currentTs, currentTs)
|
||||
)
|
||||
connId <- liftIO $ insertedRowId db
|
||||
getConnectionById db vr user connId
|
||||
getConnectionById db cxt user connId
|
||||
|
||||
updateRelayStatus :: DB.Connection -> GroupRelay -> RelayStatus -> IO GroupRelay
|
||||
updateRelayStatus db relay@GroupRelay {groupRelayId} relayStatus =
|
||||
@@ -1452,8 +1452,8 @@ updateRelayStatus_ db relayId relayStatus = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE group_relays SET relay_status = ?, updated_at = ? WHERE group_relay_id = ?" (relayStatus, currentTs, relayId)
|
||||
|
||||
setRelayLinkAccepted :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> MemberKey -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
|
||||
setRelayLinkAccepted db vr user m (MemberKey relayKey) profile = do
|
||||
setRelayLinkAccepted :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberKey -> Profile -> ExceptT StoreError IO (GroupMember, GroupRelay)
|
||||
setRelayLinkAccepted db cxt user m (MemberKey relayKey) profile = do
|
||||
let gmId = groupMemberId' m
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $ DB.execute
|
||||
@@ -1473,7 +1473,7 @@ setRelayLinkAccepted db vr user m (MemberKey relayKey) profile = do
|
||||
|]
|
||||
(relayKey, currentTs, gmId)
|
||||
void $ updateMemberProfile db user m profile
|
||||
(,) <$> getGroupMemberById db vr user gmId <*> getGroupRelayByGMId db gmId
|
||||
(,) <$> getGroupMemberById db cxt user gmId <*> getGroupRelayByGMId db gmId
|
||||
|
||||
setRelayLinkConfId :: DB.Connection -> GroupMember -> ConfirmationId -> ShortLinkContact -> IO ()
|
||||
setRelayLinkConfId db m confId relayLink = do
|
||||
@@ -1541,8 +1541,8 @@ setGroupInProgressDone db GroupInfo {groupId} = do
|
||||
"UPDATE groups SET creating_in_progress = 0, updated_at = ? WHERE group_id = ?"
|
||||
(currentTs, groupId)
|
||||
|
||||
createRelayRequestGroup :: DB.Connection -> VersionRangeChat -> User -> GroupRelayInvitation -> InvitationId -> VersionRangeChat -> Int64 -> GroupMemberStatus -> RelayStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMember, fromMemberProfile, relayMemberId, groupLink} invId reqChatVRange initialDelay memberStatus relayStatus = do
|
||||
createRelayRequestGroup :: DB.Connection -> StoreCxt -> User -> GroupRelayInvitation -> InvitationId -> VersionRangeChat -> Int64 -> GroupMemberStatus -> RelayStatus -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMember, fromMemberProfile, relayMemberId, groupLink} invId reqChatVRange initialDelay memberStatus relayStatus = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
-- Create group with placeholder profile
|
||||
let Profile {displayName = fromMemberLDN} = fromMemberProfile
|
||||
@@ -1562,9 +1562,9 @@ createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMembe
|
||||
ownerMemberId <- insertOwner_ currentTs groupId
|
||||
let relayMember = MemberIdRole relayMemberId GRRelay
|
||||
-- TODO [member keys] should relays use member keys?
|
||||
_membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing Nothing currentTs vr
|
||||
ownerMember <- getGroupMember db vr user groupId ownerMemberId
|
||||
g <- getGroupInfo db vr user groupId
|
||||
_membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing Nothing currentTs (vr cxt)
|
||||
ownerMember <- getGroupMember db cxt user groupId ownerMemberId
|
||||
g <- getGroupInfo db cxt user groupId
|
||||
pure (g, ownerMember)
|
||||
where
|
||||
setRelayRequestData_ groupId currentTs =
|
||||
@@ -1616,8 +1616,8 @@ updateRelayOwnStatus_ db GroupInfo {groupId} relayStatus = do
|
||||
|
||||
-- Flip every RSRejected row sharing the targeted group's relay_request_group_link
|
||||
-- to RSInactive in one statement; returns the refreshed GroupInfo for the targeted groupId.
|
||||
allowRelayGroup :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO GroupInfo
|
||||
allowRelayGroup db vr user@User {userId} groupId = do
|
||||
allowRelayGroup :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO GroupInfo
|
||||
allowRelayGroup db cxt user@User {userId} groupId = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
DB.execute
|
||||
@@ -1630,7 +1630,7 @@ allowRelayGroup db vr user@User {userId} groupId = do
|
||||
AND relay_own_status = ?
|
||||
|]
|
||||
(RSInactive, currentTs, currentTs, userId, groupId, RSRejected)
|
||||
getGroupInfo db vr user groupId
|
||||
getGroupInfo db cxt user groupId
|
||||
|
||||
isRelayGroupRejected :: DB.Connection -> User -> ShortLinkContact -> IO Bool
|
||||
isRelayGroupRejected db User {userId} groupLink =
|
||||
@@ -1649,9 +1649,9 @@ isRelayGroupRejected db User {userId} groupLink =
|
||||
(userId, groupLink, RSRejected)
|
||||
)
|
||||
|
||||
getRelayServedGroups :: DB.Connection -> VersionRangeChat -> User -> IO [GroupInfo]
|
||||
getRelayServedGroups db vr User {userId, userContactId} = do
|
||||
map (toGroupInfo vr userContactId [])
|
||||
getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> IO [GroupInfo]
|
||||
getRelayServedGroups db cxt User {userId, userContactId} = do
|
||||
map (toGroupInfo cxt userContactId [])
|
||||
<$> DB.query
|
||||
db
|
||||
( groupInfoQuery
|
||||
@@ -1659,10 +1659,10 @@ getRelayServedGroups db vr User {userId, userContactId} = do
|
||||
)
|
||||
(userId, userContactId, RSAccepted, RSActive)
|
||||
|
||||
getRelayInactiveGroups :: DB.Connection -> VersionRangeChat -> User -> NominalDiffTime -> IO [GroupInfo]
|
||||
getRelayInactiveGroups db vr User {userId, userContactId} ttl = do
|
||||
getRelayInactiveGroups :: DB.Connection -> StoreCxt -> User -> NominalDiffTime -> IO [GroupInfo]
|
||||
getRelayInactiveGroups db cxt User {userId, userContactId} ttl = do
|
||||
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
|
||||
map (toGroupInfo vr userContactId [])
|
||||
map (toGroupInfo cxt userContactId [])
|
||||
<$> DB.query
|
||||
db
|
||||
( groupInfoQuery
|
||||
@@ -1774,10 +1774,10 @@ createJoiningMemberConnection
|
||||
Connection {connId} <- createConnection_ db userId ConnMember (Just groupMemberId) agentConnId ConnNew chatV cReqChatVRange Nothing (Just uclId) Nothing 0 createdAt subMode PQSupportOff
|
||||
setCommandConnId db user cmdId connId
|
||||
|
||||
createBusinessRequestGroup :: DB.Connection -> VersionRangeChat -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createBusinessRequestGroup :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createBusinessRequestGroup
|
||||
db
|
||||
vr
|
||||
cxt
|
||||
gVar
|
||||
user@User {userId, userContactId}
|
||||
cReqChatVRange
|
||||
@@ -1789,8 +1789,8 @@ createBusinessRequestGroup
|
||||
(groupId, membership@GroupMember {memberId = userMemberId}) <- insertGroup_ currentTs
|
||||
(groupMemberId, memberId) <- insertClientMember_ currentTs groupId membership
|
||||
liftIO $ DB.execute db "UPDATE groups SET business_member_id = ?, customer_member_id = ? WHERE group_id = ?" (userMemberId, memberId, groupId)
|
||||
groupInfo <- getGroupInfo db vr user groupId
|
||||
clientMember <- getGroupMemberById db vr user groupMemberId
|
||||
groupInfo <- getGroupInfo db cxt user groupId
|
||||
clientMember <- getGroupMemberById db cxt user groupMemberId
|
||||
pure (groupInfo, clientMember)
|
||||
where
|
||||
insertGroup_ currentTs = do
|
||||
@@ -1813,7 +1813,7 @@ createBusinessRequestGroup
|
||||
groupId <- liftIO $ insertedRowId db
|
||||
memberId <- liftIO $ encodedRandomBytes gVar 12
|
||||
-- TODO [member keys] we could support member keys in business groups to allow binding agreements (though identity keys would be better for it.
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing Nothing currentTs vr
|
||||
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser Nothing Nothing currentTs (vr cxt)
|
||||
pure (groupId, membership)
|
||||
VersionRange minV maxV = cReqChatVRange
|
||||
insertClientMember_ currentTs groupId membership =
|
||||
@@ -1837,8 +1837,8 @@ createBusinessRequestGroup
|
||||
groupMemberId <- liftIO $ insertedRowId db
|
||||
pure (groupMemberId, MemberId memId)
|
||||
|
||||
getContactViaMember :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> ExceptT StoreError IO Contact
|
||||
getContactViaMember db vr user@User {userId} GroupMember {groupMemberId} = do
|
||||
getContactViaMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> ExceptT StoreError IO Contact
|
||||
getContactViaMember db cxt user@User {userId} GroupMember {groupMemberId} = do
|
||||
contactId <-
|
||||
ExceptT $
|
||||
firstRow fromOnly (SEContactNotFoundByMemberId groupMemberId) $
|
||||
@@ -1852,7 +1852,7 @@ getContactViaMember db vr user@User {userId} GroupMember {groupMemberId} = do
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupMemberId)
|
||||
getContact db vr user contactId
|
||||
getContact db cxt user contactId
|
||||
|
||||
setNewContactMemberConnRequest :: DB.Connection -> User -> GroupMember -> ConnReqInvitation -> IO ()
|
||||
setNewContactMemberConnRequest db User {userId} GroupMember {groupMemberId} connRequest = do
|
||||
@@ -1879,18 +1879,18 @@ createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentCon
|
||||
-- This is called once before connecting to relays, unlike createConnReqConnection -> setPreparedGroupLinkInfo_,
|
||||
-- which is used in single-connection flows.
|
||||
updatePreparedRelayedGroup ::
|
||||
DB.Connection -> VersionRangeChat -> User -> GroupInfo -> ConnReqContact -> ConnReqUriHash -> Maybe Profile ->
|
||||
DB.Connection -> StoreCxt -> User -> GroupInfo -> ConnReqContact -> ConnReqUriHash -> Maybe Profile ->
|
||||
C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> Maybe Int64 ->
|
||||
ExceptT StoreError IO GroupInfo
|
||||
updatePreparedRelayedGroup db vr user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey memberPrivKey publicMemberCount_ = do
|
||||
updatePreparedRelayedGroup db cxt user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey memberPrivKey publicMemberCount_ = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
customUserProfileId <- liftIO $ mapM (createIncognitoProfile_ db userId currentTs) incognitoProfile
|
||||
liftIO $ setPreparedGroupLinkInfo_ db gInfo cReq cReqHash customUserProfileId publicMemberCount_ currentTs
|
||||
liftIO $ updateGroupMemberKeys db (groupId' gInfo) rootPubKey memberPrivKey (groupMemberId' $ membership gInfo)
|
||||
getGroupInfo db vr user (groupId' gInfo)
|
||||
getGroupInfo db cxt user (groupId' gInfo)
|
||||
|
||||
updatePublicMemberCount :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> ExceptT StoreError IO GroupInfo
|
||||
updatePublicMemberCount db vr user GroupInfo {groupId} = do
|
||||
updatePublicMemberCount :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ExceptT StoreError IO GroupInfo
|
||||
updatePublicMemberCount db cxt user GroupInfo {groupId} = do
|
||||
liftIO $ do
|
||||
totalCount <- fromMaybe 0 <$> maybeFirstRow fromOnly
|
||||
(DB.query db "SELECT summary_current_members_count FROM groups WHERE group_id = ?" (Only groupId))
|
||||
@@ -1906,13 +1906,13 @@ updatePublicMemberCount db vr user GroupInfo {groupId} = do
|
||||
let publicCount = max 0 (totalCount - relayCount) :: Int64
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE groups SET public_member_count = ?, updated_at = ? WHERE group_id = ?" (publicCount, currentTs, groupId)
|
||||
getGroupInfo db vr user groupId
|
||||
getGroupInfo db cxt user groupId
|
||||
|
||||
setPublicMemberCount :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupInfo
|
||||
setPublicMemberCount db vr user GroupInfo {groupId} publicCount = do
|
||||
setPublicMemberCount :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Int64 -> ExceptT StoreError IO GroupInfo
|
||||
setPublicMemberCount db cxt user GroupInfo {groupId} publicCount = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $ DB.execute db "UPDATE groups SET public_member_count = ?, updated_at = ? WHERE group_id = ?" (publicCount, currentTs, groupId)
|
||||
getGroupInfo db vr user groupId
|
||||
getGroupInfo db cxt user groupId
|
||||
|
||||
updateGroupMemberKeys :: DB.Connection -> GroupId -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> GroupMemberId -> IO ()
|
||||
updateGroupMemberKeys db groupId rootPubKey memberPrivKey membershipGMId = do
|
||||
@@ -2402,8 +2402,8 @@ updateGroupProfileFromMember db user g@GroupInfo {groupId} Profile {displayName
|
||||
let publicGroupAccess = toPublicGroupAccess accessRow
|
||||
in GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup = toPublicGroupProfile groupType_ groupLink_ publicGroupId_ publicGroupAccess, groupPreferences, memberAdmission}
|
||||
|
||||
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> VersionRangeChat -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> StoreCxt -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByUserContactLinkConnReq db cxt user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
-- fmap join is to support group_id = NULL if non-group contact request is sent to this function (e.g., if client data is appended).
|
||||
groupId_ <-
|
||||
fmap join . maybeFirstRow fromOnly $
|
||||
@@ -2415,12 +2415,12 @@ getGroupInfoByUserContactLinkConnReq db vr user@User {userId} (cReqSchema1, cReq
|
||||
WHERE user_id = ? AND conn_req_contact IN (?,?)
|
||||
|]
|
||||
(userId, cReqSchema1, cReqSchema2)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db cxt user) groupId_
|
||||
|
||||
getGroupInfoViaUserShortLink :: DB.Connection -> VersionRangeChat -> User -> ShortLinkContact -> IO (Maybe (ConnReqContact, GroupInfo))
|
||||
getGroupInfoViaUserShortLink db vr user@User {userId} shortLink = fmap eitherToMaybe $ runExceptT $ do
|
||||
getGroupInfoViaUserShortLink :: DB.Connection -> StoreCxt -> User -> ShortLinkContact -> IO (Maybe (ConnReqContact, GroupInfo))
|
||||
getGroupInfoViaUserShortLink db cxt user@User {userId} shortLink = fmap eitherToMaybe $ runExceptT $ do
|
||||
(cReq, groupId) <- ExceptT getConnReqGroup
|
||||
(cReq,) <$> getGroupInfo db vr user groupId
|
||||
(cReq,) <$> getGroupInfo db cxt user groupId
|
||||
where
|
||||
getConnReqGroup =
|
||||
firstRow' toConnReqGroupId (SEInternalError "group link not found") $
|
||||
@@ -2437,14 +2437,14 @@ getGroupInfoViaUserShortLink db vr user@User {userId} shortLink = fmap eitherToM
|
||||
(cReq, Just groupId) -> Right (cReq, groupId)
|
||||
_ -> Left $ SEInternalError "no conn req or group ID"
|
||||
|
||||
getGroupViaShortLinkToConnect :: DB.Connection -> VersionRangeChat -> User -> ShortLinkContact -> ExceptT StoreError IO (Maybe (ConnReqContact, GroupInfo))
|
||||
getGroupViaShortLinkToConnect db vr user@User {userId} shortLink =
|
||||
getGroupViaShortLinkToConnect :: DB.Connection -> StoreCxt -> User -> ShortLinkContact -> ExceptT StoreError IO (Maybe (ConnReqContact, GroupInfo))
|
||||
getGroupViaShortLinkToConnect db cxt user@User {userId} shortLink =
|
||||
liftIO (maybeFirstRow id $ DB.query db "SELECT group_id, conn_full_link_to_connect FROM groups WHERE user_id = ? AND conn_short_link_to_connect = ?" (userId, shortLink)) >>= \case
|
||||
Just (gId :: Int64, Just cReq) -> Just . (cReq,) <$> getGroupInfo db vr user gId
|
||||
Just (gId :: Int64, Just cReq) -> Just . (cReq,) <$> getGroupInfo db cxt user gId
|
||||
_ -> pure Nothing
|
||||
|
||||
getGroupInfoByGroupLinkHash :: DB.Connection -> VersionRangeChat -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
|
||||
getGroupInfoByGroupLinkHash :: DB.Connection -> StoreCxt -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByGroupLinkHash db cxt user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
|
||||
groupId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
@@ -2458,7 +2458,7 @@ getGroupInfoByGroupLinkHash db vr user@User {userId, userContactId} (groupLinkHa
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted, GSMemUnknown)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db vr user) groupId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db cxt user) groupId_
|
||||
|
||||
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
|
||||
getGroupIdByName db User {userId} gName =
|
||||
@@ -2470,8 +2470,8 @@ getGroupMemberIdByName db User {userId} groupId groupMemberName =
|
||||
ExceptT . firstRow fromOnly (SEGroupMemberNameNotFound groupId groupMemberName) $
|
||||
DB.query db "SELECT group_member_id FROM group_members WHERE user_id = ? AND group_id = ? AND local_display_name = ?" (userId, groupId, groupMemberName)
|
||||
|
||||
getActiveMembersByName :: DB.Connection -> VersionRangeChat -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
|
||||
getActiveMembersByName db vr user@User {userId} groupMemberName = do
|
||||
getActiveMembersByName :: DB.Connection -> StoreCxt -> User -> ContactName -> ExceptT StoreError IO [(GroupInfo, GroupMember)]
|
||||
getActiveMembersByName db cxt user@User {userId} groupMemberName = do
|
||||
groupMemberIds :: [(GroupId, GroupMemberId)] <-
|
||||
liftIO $
|
||||
DB.query
|
||||
@@ -2484,17 +2484,17 @@ getActiveMembersByName db vr user@User {userId} groupMemberName = do
|
||||
|]
|
||||
(userId, groupMemberName, GSMemConnected, GSMemComplete, GCUserMember)
|
||||
possibleMembers <- forM groupMemberIds $ \(groupId, groupMemberId) -> do
|
||||
groupInfo <- getGroupInfo db vr user groupId
|
||||
groupMember <- getGroupMember db vr user groupId groupMemberId
|
||||
groupInfo <- getGroupInfo db cxt user groupId
|
||||
groupMember <- getGroupMember db cxt user groupId groupMemberId
|
||||
pure (groupInfo, groupMember)
|
||||
pure $ sortOn (Down . ts . fst) possibleMembers
|
||||
where
|
||||
ts GroupInfo {chatTs, updatedAt} = fromMaybe updatedAt chatTs
|
||||
|
||||
getMatchingContacts :: DB.Connection -> VersionRangeChat -> User -> Contact -> IO [Contact]
|
||||
getMatchingContacts db vr user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, shortDescr, image}} = do
|
||||
getMatchingContacts :: DB.Connection -> StoreCxt -> User -> Contact -> IO [Contact]
|
||||
getMatchingContacts db cxt user@User {userId} Contact {contactId, profile = LocalProfile {displayName, fullName, shortDescr, image}} = do
|
||||
contactIds <- map fromOnly <$> DB.query db q (userId, contactId, CSActive, displayName, fullName, shortDescr, image)
|
||||
rights <$> mapM (runExceptT . getContact db vr user) contactIds
|
||||
rights <$> mapM (runExceptT . getContact db cxt user) contactIds
|
||||
where
|
||||
-- this query is different from one in getMatchingMemberContacts
|
||||
-- it checks that it's not the same contact
|
||||
@@ -2509,10 +2509,10 @@ getMatchingContacts db vr user@User {userId} Contact {contactId, profile = Local
|
||||
AND p.short_descr IS NOT DISTINCT FROM ? AND p.image IS NOT DISTINCT FROM ?
|
||||
|]
|
||||
|
||||
getMatchingMembers :: DB.Connection -> VersionRangeChat -> User -> Contact -> IO [GroupMember]
|
||||
getMatchingMembers db vr user@User {userId} Contact {profile = LocalProfile {displayName, fullName, shortDescr, image}} = do
|
||||
getMatchingMembers :: DB.Connection -> StoreCxt -> User -> Contact -> IO [GroupMember]
|
||||
getMatchingMembers db cxt user@User {userId} Contact {profile = LocalProfile {displayName, fullName, shortDescr, image}} = do
|
||||
memberIds <- map fromOnly <$> DB.query db q (userId, GCUserMember, displayName, fullName, shortDescr, image)
|
||||
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db vr user) memberIds
|
||||
filter memberCurrent . rights <$> mapM (runExceptT . getGroupMemberById db cxt user) memberIds
|
||||
where
|
||||
-- only match with members without associated contact
|
||||
q =
|
||||
@@ -2526,11 +2526,11 @@ getMatchingMembers db vr user@User {userId} Contact {profile = LocalProfile {dis
|
||||
AND p.short_descr IS NOT DISTINCT FROM ? AND p.image IS NOT DISTINCT FROM ?
|
||||
|]
|
||||
|
||||
getMatchingMemberContacts :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> IO [Contact]
|
||||
getMatchingMemberContacts :: DB.Connection -> StoreCxt -> User -> GroupMember -> IO [Contact]
|
||||
getMatchingMemberContacts _ _ _ GroupMember {memberContactId = Just _} = pure []
|
||||
getMatchingMemberContacts db vr user@User {userId} GroupMember {memberProfile = LocalProfile {displayName, fullName, shortDescr, image}} = do
|
||||
getMatchingMemberContacts db cxt user@User {userId} GroupMember {memberProfile = LocalProfile {displayName, fullName, shortDescr, image}} = do
|
||||
contactIds <- map fromOnly <$> DB.query db q (userId, CSActive, displayName, fullName, shortDescr, image)
|
||||
rights <$> mapM (runExceptT . getContact db vr user) contactIds
|
||||
rights <$> mapM (runExceptT . getContact db cxt user) contactIds
|
||||
where
|
||||
q =
|
||||
[sql|
|
||||
@@ -2563,8 +2563,8 @@ createSentProbeHash db userId probeId to = do
|
||||
"INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, group_member_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
||||
(probeId, ctId, gmId, userId, currentTs, currentTs)
|
||||
|
||||
matchReceivedProbe :: DB.Connection -> VersionRangeChat -> User -> ContactOrMember -> Probe -> IO [ContactOrMember]
|
||||
matchReceivedProbe db vr user@User {userId} from (Probe probe) = do
|
||||
matchReceivedProbe :: DB.Connection -> StoreCxt -> User -> ContactOrMember -> Probe -> IO [ContactOrMember]
|
||||
matchReceivedProbe db cxt user@User {userId} from (Probe probe) = do
|
||||
let probeHash = C.sha256Hash probe
|
||||
cgmIds <-
|
||||
DB.query
|
||||
@@ -2585,7 +2585,7 @@ matchReceivedProbe db vr user@User {userId} from (Probe probe) = do
|
||||
"INSERT INTO received_probes (contact_id, group_member_id, probe, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
|
||||
(ctId, gmId, Binary probe, Binary probeHash, userId, currentTs, currentTs)
|
||||
let cgmIds' = filterFirstContactId cgmIds
|
||||
catMaybes <$> mapM (getContactOrMember_ db vr user) cgmIds'
|
||||
catMaybes <$> mapM (getContactOrMember_ db cxt user) cgmIds'
|
||||
where
|
||||
filterFirstContactId :: [(Maybe ContactId, Maybe GroupId, Maybe GroupMemberId)] -> [(Maybe ContactId, Maybe GroupId, Maybe GroupMemberId)]
|
||||
filterFirstContactId cgmIds = do
|
||||
@@ -2595,8 +2595,8 @@ matchReceivedProbe db vr user@User {userId} from (Probe probe) = do
|
||||
(x : _) -> [x]
|
||||
ctIds' <> memIds
|
||||
|
||||
matchReceivedProbeHash :: DB.Connection -> VersionRangeChat -> User -> ContactOrMember -> ProbeHash -> IO (Maybe (ContactOrMember, Probe))
|
||||
matchReceivedProbeHash db vr user@User {userId} from (ProbeHash probeHash) = do
|
||||
matchReceivedProbeHash :: DB.Connection -> StoreCxt -> User -> ContactOrMember -> ProbeHash -> IO (Maybe (ContactOrMember, Probe))
|
||||
matchReceivedProbeHash db cxt user@User {userId} from (ProbeHash probeHash) = do
|
||||
probeIds <-
|
||||
maybeFirstRow id $
|
||||
DB.query
|
||||
@@ -2616,11 +2616,11 @@ matchReceivedProbeHash db vr user@User {userId} from (ProbeHash probeHash) = do
|
||||
db
|
||||
"INSERT INTO received_probes (contact_id, group_member_id, probe_hash, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
|
||||
(ctId, gmId, Binary probeHash, userId, currentTs, currentTs)
|
||||
pure probeIds $>>= \(Only probe :. cgmIds) -> (,Probe probe) <$$> getContactOrMember_ db vr user cgmIds
|
||||
pure probeIds $>>= \(Only probe :. cgmIds) -> (,Probe probe) <$$> getContactOrMember_ db cxt user cgmIds
|
||||
|
||||
matchSentProbe :: DB.Connection -> VersionRangeChat -> User -> ContactOrMember -> Probe -> IO (Maybe ContactOrMember)
|
||||
matchSentProbe db vr user@User {userId} _from (Probe probe) = do
|
||||
cgmIds $>>= getContactOrMember_ db vr user
|
||||
matchSentProbe :: DB.Connection -> StoreCxt -> User -> ContactOrMember -> Probe -> IO (Maybe ContactOrMember)
|
||||
matchSentProbe db cxt user@User {userId} _from (Probe probe) = do
|
||||
cgmIds $>>= getContactOrMember_ db cxt user
|
||||
where
|
||||
(ctId, gmId) = contactOrMemberIds _from
|
||||
cgmIds =
|
||||
@@ -2639,11 +2639,11 @@ matchSentProbe db vr user@User {userId} _from (Probe probe) = do
|
||||
|]
|
||||
(userId, Binary probe, ctId, gmId)
|
||||
|
||||
getContactOrMember_ :: DB.Connection -> VersionRangeChat -> User -> (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId) -> IO (Maybe ContactOrMember)
|
||||
getContactOrMember_ db vr user ids =
|
||||
getContactOrMember_ :: DB.Connection -> StoreCxt -> User -> (Maybe ContactId, Maybe GroupId, Maybe GroupMemberId) -> IO (Maybe ContactOrMember)
|
||||
getContactOrMember_ db cxt user ids =
|
||||
fmap eitherToMaybe . runExceptT $ case ids of
|
||||
(Just ctId, _, _) -> COMContact <$> getContact db vr user ctId
|
||||
(_, Just gId, Just gmId) -> COMGroupMember <$> getGroupMember db vr user gId gmId
|
||||
(Just ctId, _, _) -> COMContact <$> getContact db cxt user ctId
|
||||
(_, Just gId, Just gmId) -> COMGroupMember <$> getGroupMember db cxt user gId gmId
|
||||
_ -> throwError $ SEInternalError ""
|
||||
|
||||
associateMemberWithContactRecord :: DB.Connection -> User -> Contact -> GroupMember -> IO ()
|
||||
@@ -2664,10 +2664,10 @@ associateMemberWithContactRecord
|
||||
when (memProfileId /= profileId) $ deleteUnusedProfile_ db userId memProfileId
|
||||
when (memLDN /= localDisplayName) $ deleteUnusedDisplayName_ db userId memLDN
|
||||
|
||||
associateContactWithMemberRecord :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> Contact -> ExceptT StoreError IO Contact
|
||||
associateContactWithMemberRecord :: DB.Connection -> StoreCxt -> User -> GroupMember -> Contact -> ExceptT StoreError IO Contact
|
||||
associateContactWithMemberRecord
|
||||
db
|
||||
vr
|
||||
cxt
|
||||
user@User {userId}
|
||||
GroupMember {groupId, groupMemberId, localDisplayName = memLDN, memberProfile = LocalProfile {profileId = memProfileId}}
|
||||
Contact {contactId, localDisplayName, profile = LocalProfile {profileId}} = do
|
||||
@@ -2691,7 +2691,7 @@ associateContactWithMemberRecord
|
||||
(memLDN, memProfileId, currentTs, userId, contactId)
|
||||
when (profileId /= memProfileId) $ deleteUnusedProfile_ db userId profileId
|
||||
when (localDisplayName /= memLDN) $ deleteUnusedDisplayName_ db userId localDisplayName
|
||||
getContact db vr user contactId
|
||||
getContact db cxt user contactId
|
||||
|
||||
deleteUnusedDisplayName_ :: DB.Connection -> UserId -> ContactName -> IO ()
|
||||
deleteUnusedDisplayName_ db userId localDisplayName =
|
||||
@@ -2847,15 +2847,15 @@ createMemberContact
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
|
||||
pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, preparedContact = Nothing, contactRequestId = Nothing, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False, groupDirectInv = Nothing, chatTags = [], chatItemTTL = Nothing, uiThemes = Nothing, chatDeleted = False, customData = Nothing}
|
||||
|
||||
getMemberContact :: DB.Connection -> VersionRangeChat -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
|
||||
getMemberContact db vr user contactId = do
|
||||
ct <- getContact db vr user contactId
|
||||
getMemberContact :: DB.Connection -> StoreCxt -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
|
||||
getMemberContact db cxt user contactId = do
|
||||
ct <- getContact db cxt user contactId
|
||||
let Contact {contactGroupMemberId, activeConn} = ct
|
||||
case (activeConn, contactGroupMemberId) of
|
||||
(Just Connection {connId}, Just groupMemberId) -> do
|
||||
cReq <- getConnReqInv db connId
|
||||
m@GroupMember {groupId} <- getGroupMemberById db vr user groupMemberId
|
||||
g <- getGroupInfo db vr user groupId
|
||||
m@GroupMember {groupId} <- getGroupMemberById db cxt user groupMemberId
|
||||
g <- getGroupInfo db cxt user groupId
|
||||
pure (g, m, ct, cReq)
|
||||
_ ->
|
||||
throwError $ SEMemberContactGroupMemberNotFound contactId
|
||||
@@ -2964,13 +2964,13 @@ createMemberContactConn
|
||||
forM_ cmdId_ $ \cmdId -> setCommandConnId db user cmdId connId
|
||||
pure connId
|
||||
|
||||
getMemberContactInvited :: DB.Connection -> VersionRangeChat -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, Connection, Contact, GroupDirectInvitation)
|
||||
getMemberContactInvited db vr user contactId = do
|
||||
ct@Contact {groupDirectInv = groupDirectInv_} <- getContact db vr user contactId
|
||||
getMemberContactInvited :: DB.Connection -> StoreCxt -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, Connection, Contact, GroupDirectInvitation)
|
||||
getMemberContactInvited db cxt user contactId = do
|
||||
ct@Contact {groupDirectInv = groupDirectInv_} <- getContact db cxt user contactId
|
||||
case groupDirectInv_ of
|
||||
Just groupDirectInv@GroupDirectInvitation {fromGroupId_ = Just groupId, fromGroupMemberId_ = Just _gmId, fromGroupMemberConnId_ = Just mConnId} -> do
|
||||
g <- getGroupInfo db vr user groupId
|
||||
mConn <- getConnectionById db vr user mConnId
|
||||
g <- getGroupInfo db cxt user groupId
|
||||
mConn <- getConnectionById db cxt user mConnId
|
||||
pure (g, mConn, ct, groupDirectInv)
|
||||
_ ->
|
||||
throwError $ SEMemberContactGroupMemberNotFound contactId
|
||||
@@ -3032,8 +3032,8 @@ setXGrpLinkMemReceived db mId xGrpLinkMemReceived = do
|
||||
"UPDATE group_members SET xgrplinkmem_received = ?, updated_at = ? WHERE group_member_id = ?"
|
||||
(BI xGrpLinkMemReceived, currentTs, mId)
|
||||
|
||||
createNewUnknownGroupMember :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> Text -> GroupMemberRole -> ExceptT StoreError IO GroupMember
|
||||
createNewUnknownGroupMember db vr user@User {userId, userContactId} GroupInfo {groupId} memberId memberName unknownMemberRole = do
|
||||
createNewUnknownGroupMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> Text -> GroupMemberRole -> ExceptT StoreError IO GroupMember
|
||||
createNewUnknownGroupMember db cxt user@User {userId, userContactId} GroupInfo {groupId} memberId memberName unknownMemberRole = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let memberProfile = profileFromName memberName
|
||||
(localDisplayName, profileId) <- createNewMemberProfile_ db user memberProfile currentTs
|
||||
@@ -3053,12 +3053,12 @@ createNewUnknownGroupMember db vr user@User {userId, userContactId} GroupInfo {g
|
||||
:. (minV, maxV)
|
||||
)
|
||||
groupMemberId <- liftIO $ insertedRowId db
|
||||
getGroupMemberById db vr user groupMemberId
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
where
|
||||
VersionRange minV maxV = vr
|
||||
VersionRange minV maxV = vr cxt
|
||||
|
||||
createLinkOwnerMember :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe ContactId -> MemberId -> C.PublicKeyEd25519 -> ExceptT StoreError IO GroupMember
|
||||
createLinkOwnerMember db vr user@User {userId, userContactId} GroupInfo {groupId} contactId_ memberId ownerKey = do
|
||||
createLinkOwnerMember :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe ContactId -> MemberId -> C.PublicKeyEd25519 -> ExceptT StoreError IO GroupMember
|
||||
createLinkOwnerMember db cxt user@User {userId, userContactId} GroupInfo {groupId} contactId_ memberId ownerKey = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let memberProfile = profileFromName $ nameFromMemberId memberId
|
||||
(localDisplayName, profileId) <- createNewMemberProfile_ db user memberProfile currentTs
|
||||
@@ -3078,15 +3078,15 @@ createLinkOwnerMember db vr user@User {userId, userContactId} GroupInfo {groupId
|
||||
:. (minV, maxV)
|
||||
)
|
||||
groupMemberId <- liftIO $ insertedRowId db
|
||||
getGroupMemberById db vr user groupMemberId
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
where
|
||||
VersionRange minV maxV = vr
|
||||
VersionRange minV maxV = vr cxt
|
||||
|
||||
-- member_pub_key is not updated here — introduced members are owners
|
||||
-- whose keys are loaded from link data (trusted out-of-band).
|
||||
-- Updating from an in-band message would allow a compromised relay to substitute keys.
|
||||
updatePreparedChannelMember :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember
|
||||
updatePreparedChannelMember db vr user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile} = do
|
||||
updatePreparedChannelMember :: DB.Connection -> StoreCxt -> User -> GroupMember -> MemberInfo -> ExceptT StoreError IO GroupMember
|
||||
updatePreparedChannelMember db cxt user@User {userId} member@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile} = do
|
||||
_ <- updateMemberProfile db user member profile
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
@@ -3102,12 +3102,12 @@ updatePreparedChannelMember db vr user@User {userId} member@GroupMember {groupMe
|
||||
WHERE user_id = ? AND group_member_id = ?
|
||||
|]
|
||||
(memberRole, GSMemIntroduced, minV, maxV, currentTs, userId, groupMemberId)
|
||||
getGroupMemberById db vr user groupMemberId
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
where
|
||||
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
|
||||
|
||||
updateUnknownMemberAnnounced :: DB.Connection -> VersionRangeChat -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
|
||||
updateUnknownMemberAnnounced db vr user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} status = do
|
||||
updateUnknownMemberAnnounced :: DB.Connection -> StoreCxt -> User -> GroupMember -> GroupMember -> MemberInfo -> GroupMemberStatus -> ExceptT StoreError IO GroupMember
|
||||
updateUnknownMemberAnnounced db cxt user@User {userId} invitingMember unknownMember@GroupMember {groupMemberId, memberChatVRange} MemberInfo {memberRole, v, profile, memberKey} status = do
|
||||
_ <- updateMemberProfile db user unknownMember profile
|
||||
currentTs <- liftIO getCurrentTime
|
||||
liftIO $
|
||||
@@ -3128,7 +3128,7 @@ updateUnknownMemberAnnounced db vr user@User {userId} invitingMember unknownMemb
|
||||
( (memberRole, GCPostMember, status, groupMemberId' invitingMember)
|
||||
:. (minV, maxV, memberPubKey_, currentTs, userId, groupMemberId)
|
||||
)
|
||||
getGroupMemberById db vr user groupMemberId
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
where
|
||||
VersionRange minV maxV = maybe memberChatVRange fromChatVRange v
|
||||
memberPubKey_ = (\(MemberKey k) -> k) <$> memberKey
|
||||
|
||||
@@ -396,8 +396,8 @@ data MemberAttention
|
||||
| MAReset
|
||||
deriving (Show)
|
||||
|
||||
updateChatTsStats :: DB.Connection -> VersionRangeChat -> User -> ChatDirection c d -> UTCTime -> Maybe (Int, MemberAttention, Int) -> IO (ChatInfo c)
|
||||
updateChatTsStats db vr user@User {userId} chatDirection chatTs chatStats_ = case toChatInfo chatDirection of
|
||||
updateChatTsStats :: DB.Connection -> StoreCxt -> User -> ChatDirection c d -> UTCTime -> Maybe (Int, MemberAttention, Int) -> IO (ChatInfo c)
|
||||
updateChatTsStats db cxt user@User {userId} chatDirection chatTs chatStats_ = case toChatInfo chatDirection of
|
||||
DirectChat ct@Contact {contactId} -> do
|
||||
DB.execute
|
||||
db
|
||||
@@ -506,7 +506,7 @@ updateChatTsStats db vr user@User {userId} chatDirection chatTs chatStats_ = cas
|
||||
WHERE group_member_id = ?
|
||||
|]
|
||||
(chatTs, unread, mentions, groupMemberId)
|
||||
m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
|
||||
m_ <- runExceptT $ getGroupMemberById db cxt user groupMemberId
|
||||
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
|
||||
LocalChat nf@NoteFolder {noteFolderId} -> do
|
||||
DB.execute
|
||||
@@ -520,8 +520,8 @@ setSupportChatTs :: DB.Connection -> GroupMemberId -> UTCTime -> IO ()
|
||||
setSupportChatTs db groupMemberId chatTs =
|
||||
DB.execute db "UPDATE group_members SET support_chat_ts = ? WHERE group_member_id = ?" (chatTs, groupMemberId)
|
||||
|
||||
setSupportChatMemberAttention :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupMember -> Int64 -> IO (GroupInfo, GroupMember)
|
||||
setSupportChatMemberAttention db vr user g m memberAttention = do
|
||||
setSupportChatMemberAttention :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupMember -> Int64 -> IO (GroupInfo, GroupMember)
|
||||
setSupportChatMemberAttention db cxt user g m memberAttention = do
|
||||
m' <- updateGMAttention
|
||||
g' <- updateGroupMembersRequireAttention db user g m m'
|
||||
pure (g', m')
|
||||
@@ -532,7 +532,7 @@ setSupportChatMemberAttention db vr user g m memberAttention = do
|
||||
db
|
||||
"UPDATE group_members SET support_chat_items_member_attention = ?, updated_at = ? WHERE group_member_id = ?"
|
||||
(memberAttention, currentTs, groupMemberId' m)
|
||||
m_ <- runExceptT $ getGroupMemberById db vr user (groupMemberId' m)
|
||||
m_ <- runExceptT $ getGroupMemberById db cxt user (groupMemberId' m)
|
||||
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
|
||||
|
||||
createNewSndChatItem :: DB.Connection -> User -> ChatDirection c 'MDSnd -> ShowGroupAsSender -> SndMessage -> CIContent 'MDSnd -> Maybe (CIQuote c) -> Maybe CIForwardedFrom -> Maybe CITimed -> Bool -> Bool -> UTCTime -> IO ChatItemId
|
||||
@@ -723,8 +723,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe
|
||||
ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing
|
||||
ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow
|
||||
|
||||
getChatPreviews :: DB.Connection -> VersionRangeChat -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
|
||||
getChatPreviews db vr user withPCC pagination query = do
|
||||
getChatPreviews :: DB.Connection -> StoreCxt -> User -> Bool -> PaginationByTime -> ChatListQuery -> IO [Either StoreError AChat]
|
||||
getChatPreviews db cxt user withPCC pagination query = do
|
||||
directChats <- findDirectChatPreviews_ db user pagination query
|
||||
groupChats <- findGroupChatPreviews_ db user pagination query
|
||||
localChats <- findLocalChatPreviews_ db user pagination query
|
||||
@@ -746,8 +746,8 @@ getChatPreviews db vr user withPCC pagination query = do
|
||||
PTBefore _ count -> take count . sortBy (comparing $ Down . ts)
|
||||
getChatPreview :: AChatPreviewData -> ExceptT StoreError IO AChat
|
||||
getChatPreview (ACPD cType cpd) = case cType of
|
||||
SCTDirect -> getDirectChatPreview_ db vr user cpd
|
||||
SCTGroup -> getGroupChatPreview_ db vr user cpd
|
||||
SCTDirect -> getDirectChatPreview_ db cxt user cpd
|
||||
SCTGroup -> getGroupChatPreview_ db cxt user cpd
|
||||
SCTLocal -> getLocalChatPreview_ db user cpd
|
||||
SCTContactRequest -> let (ContactRequestPD _ chat) = cpd in pure chat
|
||||
SCTContactConnection -> let (ContactConnectionPD _ chat) = cpd in pure chat
|
||||
@@ -864,9 +864,9 @@ findDirectChatPreviews_ db User {userId} pagination clq =
|
||||
PTAfter ts count -> DB.query db (query <> " AND ct.chat_ts > ? ORDER BY ct.chat_ts ASC LIMIT ?") (params :. (ts, count))
|
||||
PTBefore ts count -> DB.query db (query <> " AND ct.chat_ts < ? ORDER BY ct.chat_ts DESC LIMIT ?") (params :. (ts, count))
|
||||
|
||||
getDirectChatPreview_ :: DB.Connection -> VersionRangeChat -> User -> ChatPreviewData 'CTDirect -> ExceptT StoreError IO AChat
|
||||
getDirectChatPreview_ db vr user (DirectChatPD _ contactId lastItemId_ stats) = do
|
||||
contact <- getContact db vr user contactId
|
||||
getDirectChatPreview_ :: DB.Connection -> StoreCxt -> User -> ChatPreviewData 'CTDirect -> ExceptT StoreError IO AChat
|
||||
getDirectChatPreview_ db cxt user (DirectChatPD _ contactId lastItemId_ stats) = do
|
||||
contact <- getContact db cxt user contactId
|
||||
ts <- liftIO getCurrentTime
|
||||
lastItem <- case lastItemId_ of
|
||||
Just lastItemId -> do
|
||||
@@ -975,9 +975,9 @@ findGroupChatPreviews_ db User {userId} pagination clq =
|
||||
PTAfter ts count -> DB.query db (query <> " AND g.chat_ts > ? ORDER BY g.chat_ts ASC LIMIT ?") (params :. (ts, count))
|
||||
PTBefore ts count -> DB.query db (query <> " AND g.chat_ts < ? ORDER BY g.chat_ts DESC LIMIT ?") (params :. (ts, count))
|
||||
|
||||
getGroupChatPreview_ :: DB.Connection -> VersionRangeChat -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
|
||||
getGroupChatPreview_ db vr user (GroupChatPD _ groupId lastItemId_ stats) = do
|
||||
groupInfo <- getGroupInfo db vr user groupId
|
||||
getGroupChatPreview_ :: DB.Connection -> StoreCxt -> User -> ChatPreviewData 'CTGroup -> ExceptT StoreError IO AChat
|
||||
getGroupChatPreview_ db cxt user (GroupChatPD _ groupId lastItemId_ stats) = do
|
||||
groupInfo <- getGroupInfo db cxt user groupId
|
||||
ts <- liftIO getCurrentTime
|
||||
lastItem <- case lastItemId_ of
|
||||
Just lastItemId -> do
|
||||
@@ -1213,10 +1213,10 @@ getChatContentTypes db User {userId} (ChatRef cType chatId chatScope_) = case cT
|
||||
("SELECT DISTINCT msg_content_tag FROM chat_items WHERE user_id = ? AND " <> cond <> " AND msg_content_tag IS NOT NULL ORDER BY msg_content_tag")
|
||||
((userId, chatId) :. params)
|
||||
|
||||
getDirectChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTDirect, Maybe NavigationInfo)
|
||||
getDirectChat db vr user contactId contentFilter pagination search_ = do
|
||||
getDirectChat :: DB.Connection -> StoreCxt -> User -> Int64 -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTDirect, Maybe NavigationInfo)
|
||||
getDirectChat db cxt user contactId contentFilter pagination search_ = do
|
||||
let search = fromMaybe "" search_
|
||||
ct <- getContact db vr user contactId
|
||||
ct <- getContact db cxt user contactId
|
||||
case pagination of
|
||||
CPLast count -> (,Nothing) <$> getDirectChatLast_ db user ct contentFilter count search
|
||||
CPAfter afterId count -> (,Nothing) <$> getDirectChatAfter_ db user ct contentFilter afterId count search
|
||||
@@ -1433,11 +1433,11 @@ getContactNavInfo_ db User {userId} Contact {contactId} afterCI = do
|
||||
:. (userId, contactId, ciCreatedAt afterCI, cChatItemId afterCI)
|
||||
)
|
||||
|
||||
getGroupChat :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Maybe GroupChatScope -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChat db vr user groupId scope_ contentFilter pagination search_ = do
|
||||
getGroupChat :: DB.Connection -> StoreCxt -> User -> Int64 -> Maybe GroupChatScope -> Maybe MsgContentTag -> ChatPagination -> Maybe Text -> ExceptT StoreError IO (Chat 'CTGroup, Maybe NavigationInfo)
|
||||
getGroupChat db cxt user groupId scope_ contentFilter pagination search_ = do
|
||||
let search = fromMaybe "" search_
|
||||
g <- getGroupInfo db vr user groupId
|
||||
scopeInfo <- mapM (getCreateGroupChatScopeInfo db vr user g) scope_
|
||||
g <- getGroupInfo db cxt user groupId
|
||||
scopeInfo <- mapM (getCreateGroupChatScopeInfo db cxt user g) scope_
|
||||
case pagination of
|
||||
CPLast count -> (,Nothing) <$> getGroupChatLast_ db user g scopeInfo contentFilter count search emptyChatStats
|
||||
CPAfter afterId count -> (,Nothing) <$> getGroupChatAfter_ db user g scopeInfo contentFilter afterId count search
|
||||
@@ -1447,31 +1447,31 @@ getGroupChat db vr user groupId scope_ contentFilter pagination search_ = do
|
||||
unless (T.null search) $ throwError $ SEInternalError "initial chat pagination doesn't support search"
|
||||
getGroupChatInitial_ db user g scopeInfo contentFilter count
|
||||
|
||||
getCreateGroupChatScopeInfo :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
|
||||
getCreateGroupChatScopeInfo db vr user GroupInfo {membership} = \case
|
||||
getCreateGroupChatScopeInfo :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
|
||||
getCreateGroupChatScopeInfo db cxt user GroupInfo {membership} = \case
|
||||
GCSMemberSupport Nothing -> do
|
||||
when (isNothing $ supportChat membership) $ do
|
||||
ts <- liftIO getCurrentTime
|
||||
liftIO $ setSupportChatTs db (groupMemberId' membership) ts
|
||||
pure $ GCSIMemberSupport {groupMember_ = Nothing}
|
||||
GCSMemberSupport (Just gmId) -> do
|
||||
m <- getGroupMemberById db vr user gmId
|
||||
m <- getGroupMemberById db cxt user gmId
|
||||
when (isNothing $ supportChat m) $ do
|
||||
ts <- liftIO getCurrentTime
|
||||
liftIO $ setSupportChatTs db gmId ts
|
||||
pure GCSIMemberSupport {groupMember_ = Just m}
|
||||
|
||||
getGroupChatScopeInfoForItem :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> ChatItemId -> ExceptT StoreError IO (Maybe GroupChatScopeInfo)
|
||||
getGroupChatScopeInfoForItem db vr user g itemId =
|
||||
getGroupChatScopeForItem_ db itemId >>= mapM (getGroupChatScopeInfo db vr user g)
|
||||
getGroupChatScopeInfoForItem :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ChatItemId -> ExceptT StoreError IO (Maybe GroupChatScopeInfo)
|
||||
getGroupChatScopeInfoForItem db cxt user g itemId =
|
||||
getGroupChatScopeForItem_ db itemId >>= mapM (getGroupChatScopeInfo db cxt user g)
|
||||
|
||||
getGroupChatScopeInfo :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
|
||||
getGroupChatScopeInfo db vr user GroupInfo {membership} = \case
|
||||
getGroupChatScopeInfo :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupChatScope -> ExceptT StoreError IO GroupChatScopeInfo
|
||||
getGroupChatScopeInfo db cxt user GroupInfo {membership} = \case
|
||||
GCSMemberSupport Nothing -> case supportChat membership of
|
||||
Nothing -> throwError $ SEInternalError "no moderators support chat"
|
||||
Just _supportChat -> pure $ GCSIMemberSupport {groupMember_ = Nothing}
|
||||
GCSMemberSupport (Just gmId) -> do
|
||||
m <- getGroupMemberById db vr user gmId
|
||||
m <- getGroupMemberById db cxt user gmId
|
||||
case supportChat m of
|
||||
Nothing -> throwError $ SEInternalError "no support chat"
|
||||
Just _supportChat -> pure GCSIMemberSupport {groupMember_ = Just m}
|
||||
@@ -2077,8 +2077,8 @@ updateGroupChatItemsRead db User {userId} GroupInfo {groupId} = do
|
||||
|]
|
||||
(CISRcvRead, currentTs, userId, groupId, CISRcvNew)
|
||||
|
||||
updateSupportChatItemsRead :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScopeInfo -> IO (GroupInfo, GroupMember)
|
||||
updateSupportChatItemsRead db vr user@User {userId} g@GroupInfo {groupId, membership} scopeInfo = do
|
||||
updateSupportChatItemsRead :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupChatScopeInfo -> IO (GroupInfo, GroupMember)
|
||||
updateSupportChatItemsRead db cxt user@User {userId} g@GroupInfo {groupId, membership} scopeInfo = do
|
||||
currentTs <- getCurrentTime
|
||||
case scopeInfo of
|
||||
GCSIMemberSupport {groupMember_} -> do
|
||||
@@ -2116,7 +2116,7 @@ updateSupportChatItemsRead db vr user@User {userId} g@GroupInfo {groupId, member
|
||||
WHERE group_member_id = ?
|
||||
|]
|
||||
(currentTs, groupMemberId)
|
||||
m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
|
||||
m_ <- runExceptT $ getGroupMemberById db cxt user groupMemberId
|
||||
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
|
||||
|
||||
getGroupUnreadTimedItems :: DB.Connection -> User -> GroupId -> Maybe GroupChatScope -> IO [(ChatItemId, Int)]
|
||||
@@ -2144,8 +2144,8 @@ getGroupUnreadTimedItems db User {userId} groupId scope =
|
||||
|]
|
||||
(userId, groupId, GCSTMemberSupport_, groupMemberId_, CISRcvNew)
|
||||
|
||||
updateGroupChatItemsReadList :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> NonEmpty ChatItemId -> ExceptT StoreError IO ([(ChatItemId, Int)], GroupInfo)
|
||||
updateGroupChatItemsReadList db vr user@User {userId} g@GroupInfo {groupId} scopeInfo_ itemIds = do
|
||||
updateGroupChatItemsReadList :: DB.Connection -> StoreCxt -> User -> GroupInfo -> Maybe GroupChatScopeInfo -> NonEmpty ChatItemId -> ExceptT StoreError IO ([(ChatItemId, Int)], GroupInfo)
|
||||
updateGroupChatItemsReadList db cxt user@User {userId} g@GroupInfo {groupId} scopeInfo_ itemIds = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
-- Possible improvement is to differentiate retrieval queries for each scope,
|
||||
-- but we rely on UI to not pass item IDs from incorrect scope.
|
||||
@@ -2154,7 +2154,7 @@ updateGroupChatItemsReadList db vr user@User {userId} g@GroupInfo {groupId} scop
|
||||
Nothing -> pure g
|
||||
Just scopeInfo@GCSIMemberSupport {groupMember_} -> do
|
||||
let decStats = countReadItems groupMember_ readItemsData
|
||||
liftIO $ updateGroupScopeUnreadStats db vr user g scopeInfo decStats
|
||||
liftIO $ updateGroupScopeUnreadStats db cxt user g scopeInfo decStats
|
||||
pure (timedItems readItemsData, g')
|
||||
where
|
||||
getUpdateGroupItem :: UTCTime -> ChatItemId -> IO (Maybe (ChatItemId, Maybe Int, Maybe UTCTime, Maybe GroupMemberId, Maybe BoolInt))
|
||||
@@ -2189,8 +2189,8 @@ updateGroupChatItemsReadList db vr user@User {userId} g@GroupInfo {groupId} scop
|
||||
addTimedItem acc (itemId, Just ttl, Nothing, _, _) = (itemId, ttl) : acc
|
||||
addTimedItem acc _ = acc
|
||||
|
||||
updateGroupScopeUnreadStats :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> GroupChatScopeInfo -> (Int, Int, Int) -> IO GroupInfo
|
||||
updateGroupScopeUnreadStats db vr user g@GroupInfo {membership} scopeInfo (unread, unanswered, mentions) =
|
||||
updateGroupScopeUnreadStats :: DB.Connection -> StoreCxt -> User -> GroupInfo -> GroupChatScopeInfo -> (Int, Int, Int) -> IO GroupInfo
|
||||
updateGroupScopeUnreadStats db cxt user g@GroupInfo {membership} scopeInfo (unread, unanswered, mentions) =
|
||||
case scopeInfo of
|
||||
GCSIMemberSupport {groupMember_} -> case groupMember_ of
|
||||
Nothing -> do
|
||||
@@ -2228,7 +2228,7 @@ updateGroupScopeUnreadStats db vr user g@GroupInfo {membership} scopeInfo (unrea
|
||||
|]
|
||||
#endif
|
||||
(unread, unanswered, mentions, currentTs, groupMemberId)
|
||||
m_ <- runExceptT $ getGroupMemberById db vr user groupMemberId
|
||||
m_ <- runExceptT $ getGroupMemberById db cxt user groupMemberId
|
||||
pure $ either (const m) id m_ -- Left shouldn't happen, but types require it
|
||||
|
||||
setGroupChatItemsDeleteAt :: DB.Connection -> User -> GroupId -> [(ChatItemId, Int)] -> UTCTime -> IO [(ChatItemId, UTCTime)]
|
||||
@@ -2403,8 +2403,8 @@ toGroupChatItem
|
||||
ciTimed :: Maybe CITimed
|
||||
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
|
||||
|
||||
getAllChatItems :: DB.Connection -> VersionRangeChat -> User -> ChatPagination -> Maybe Text -> ExceptT StoreError IO [AChatItem]
|
||||
getAllChatItems db vr user@User {userId} pagination search_ = do
|
||||
getAllChatItems :: DB.Connection -> StoreCxt -> User -> ChatPagination -> Maybe Text -> ExceptT StoreError IO [AChatItem]
|
||||
getAllChatItems db cxt user@User {userId} pagination search_ = do
|
||||
itemRefs <-
|
||||
rights . map toChatItemRef <$> case pagination of
|
||||
CPLast count -> liftIO $ getAllChatItemsLast_ count
|
||||
@@ -2416,12 +2416,12 @@ getAllChatItems db vr user@User {userId} pagination search_ = do
|
||||
liftIO getFirstUnreadItemId_ >>= \case
|
||||
Just itemId -> liftIO . getAllChatItemsAround_ itemId count . aChatItemTs =<< getAChatItem_ itemId
|
||||
Nothing -> liftIO $ getAllChatItemsLast_ count
|
||||
mapM (uncurry (getAChatItem db vr user)) itemRefs
|
||||
mapM (uncurry (getAChatItem db cxt user)) itemRefs
|
||||
where
|
||||
search = fromMaybe "" search_
|
||||
getAChatItem_ itemId = do
|
||||
chatRef <- getChatRefViaItemId db user itemId
|
||||
getAChatItem db vr user chatRef itemId
|
||||
getAChatItem db cxt user chatRef itemId
|
||||
getAllChatItemsLast_ count =
|
||||
reverse
|
||||
<$> DB.query
|
||||
@@ -3208,8 +3208,8 @@ deleteLocalChatItem db User {userId} NoteFolder {noteFolderId} ci = do
|
||||
|]
|
||||
(userId, noteFolderId, itemId)
|
||||
|
||||
getChatItemByFileId :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByFileId db vr user@User {userId} fileId = do
|
||||
getChatItemByFileId :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByFileId db cxt user@User {userId} fileId = do
|
||||
(chatRef, itemId) <-
|
||||
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByFileId fileId) $
|
||||
DB.query
|
||||
@@ -3222,16 +3222,16 @@ getChatItemByFileId db vr user@User {userId} fileId = do
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, fileId)
|
||||
getAChatItem db vr user chatRef itemId
|
||||
getAChatItem db cxt user chatRef itemId
|
||||
|
||||
lookupChatItemByFileId :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO (Maybe AChatItem)
|
||||
lookupChatItemByFileId db vr user fileId = do
|
||||
fmap Just (getChatItemByFileId db vr user fileId) `catchError` \case
|
||||
lookupChatItemByFileId :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO (Maybe AChatItem)
|
||||
lookupChatItemByFileId db cxt user fileId = do
|
||||
fmap Just (getChatItemByFileId db cxt user fileId) `catchError` \case
|
||||
SEChatItemNotFoundByFileId {} -> pure Nothing
|
||||
e -> throwError e
|
||||
|
||||
getChatItemByGroupId :: DB.Connection -> VersionRangeChat -> User -> GroupId -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByGroupId db vr user@User {userId} groupId = do
|
||||
getChatItemByGroupId :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO AChatItem
|
||||
getChatItemByGroupId db cxt user@User {userId} groupId = do
|
||||
(chatRef, itemId) <-
|
||||
ExceptT . firstRow' toChatItemRef (SEChatItemNotFoundByGroupId groupId) $
|
||||
DB.query
|
||||
@@ -3244,7 +3244,7 @@ getChatItemByGroupId db vr user@User {userId} groupId = do
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupId)
|
||||
getAChatItem db vr user chatRef itemId
|
||||
getAChatItem db cxt user chatRef itemId
|
||||
|
||||
getChatRefViaItemId :: DB.Connection -> User -> ChatItemId -> ExceptT StoreError IO ChatRef
|
||||
getChatRefViaItemId db User {userId} itemId = do
|
||||
@@ -3257,17 +3257,17 @@ getChatRefViaItemId db User {userId} itemId = do
|
||||
(Nothing, Just groupId) -> Right $ ChatRef CTGroup groupId Nothing
|
||||
(_, _) -> Left $ SEBadChatItem itemId Nothing
|
||||
|
||||
getAChatItem :: DB.Connection -> VersionRangeChat -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
|
||||
getAChatItem db vr user (ChatRef cType chatId scope) itemId = do
|
||||
getAChatItem :: DB.Connection -> StoreCxt -> User -> ChatRef -> ChatItemId -> ExceptT StoreError IO AChatItem
|
||||
getAChatItem db cxt user (ChatRef cType chatId scope) itemId = do
|
||||
aci <- case cType of
|
||||
CTDirect -> do
|
||||
ct <- getContact db vr user chatId
|
||||
ct <- getContact db cxt user chatId
|
||||
(CChatItem msgDir ci) <- getDirectChatItem db user chatId itemId
|
||||
pure $ AChatItem SCTDirect msgDir (DirectChat ct) ci
|
||||
CTGroup -> do
|
||||
gInfo <- getGroupInfo db vr user chatId
|
||||
gInfo <- getGroupInfo db cxt user chatId
|
||||
(CChatItem msgDir ci) <- getGroupChatItem db user chatId itemId
|
||||
scopeInfo <- mapM (getGroupChatScopeInfo db vr user gInfo) scope
|
||||
scopeInfo <- mapM (getGroupChatScopeInfo db cxt user gInfo) scope
|
||||
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo scopeInfo) ci
|
||||
CTLocal -> do
|
||||
nf <- getNoteFolder db user chatId
|
||||
@@ -3443,8 +3443,8 @@ setGroupReaction db GroupInfo {groupId} m itemMemberId itemSharedMId sent reacti
|
||||
|]
|
||||
(groupId, groupMemberId' m, itemSharedMId, itemMemberId, BI sent, reaction)
|
||||
|
||||
getReactionMembers :: DB.Connection -> VersionRangeChat -> User -> GroupId -> SharedMsgId -> MsgReaction -> IO [MemberReaction]
|
||||
getReactionMembers db vr user groupId itemSharedMId reaction = do
|
||||
getReactionMembers :: DB.Connection -> StoreCxt -> User -> GroupId -> SharedMsgId -> MsgReaction -> IO [MemberReaction]
|
||||
getReactionMembers db cxt user groupId itemSharedMId reaction = do
|
||||
reactions <-
|
||||
DB.query
|
||||
db
|
||||
@@ -3458,7 +3458,7 @@ getReactionMembers db vr user groupId itemSharedMId reaction = do
|
||||
where
|
||||
toMemberReaction :: (GroupMemberId, UTCTime) -> ExceptT StoreError IO MemberReaction
|
||||
toMemberReaction (groupMemberId, reactionTs) = do
|
||||
groupMember <- getGroupMemberById db vr user groupMemberId
|
||||
groupMember <- getGroupMemberById db cxt user groupMemberId
|
||||
pure MemberReaction {groupMember, reactionTs}
|
||||
|
||||
getTimedItems :: DB.Connection -> User -> UTCTime -> IO [((ChatRef, ChatItemId), UTCTime)]
|
||||
@@ -3556,9 +3556,9 @@ createCIModeration db GroupInfo {groupId} moderatorMember itemMemberId itemShare
|
||||
|]
|
||||
(groupId, groupMemberId' moderatorMember, itemMemberId, itemSharedMId, msgId, moderatedAtTs)
|
||||
|
||||
getCIModeration :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO (Maybe CIModeration)
|
||||
getCIModeration :: DB.Connection -> StoreCxt -> User -> GroupInfo -> MemberId -> Maybe SharedMsgId -> IO (Maybe CIModeration)
|
||||
getCIModeration _ _ _ _ _ Nothing = pure Nothing
|
||||
getCIModeration db vr user GroupInfo {groupId} itemMemberId (Just sharedMsgId) = do
|
||||
getCIModeration db cxt user GroupInfo {groupId} itemMemberId (Just sharedMsgId) = do
|
||||
r_ <-
|
||||
maybeFirstRow id $
|
||||
DB.query
|
||||
@@ -3572,7 +3572,7 @@ getCIModeration db vr user GroupInfo {groupId} itemMemberId (Just sharedMsgId) =
|
||||
(groupId, itemMemberId, sharedMsgId)
|
||||
case r_ of
|
||||
Just (moderationId, moderatorId, createdByMsgId, moderatedAt) -> do
|
||||
runExceptT (getGroupMember db vr user groupId moderatorId) >>= \case
|
||||
runExceptT (getGroupMember db cxt user groupId moderatorId) >>= \case
|
||||
Right moderatorMember -> pure (Just CIModeration {moderationId, moderatorMember, createdByMsgId, moderatedAt})
|
||||
_ -> pure Nothing
|
||||
_ -> pure Nothing
|
||||
|
||||
@@ -380,9 +380,9 @@ createUserContactLink db User {userId} agentConnId (CCLink cReq shortLink) subMo
|
||||
userContactLinkId <- insertedRowId db
|
||||
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId ConnNew initialChatVersion chatInitialVRange Nothing Nothing Nothing 0 currentTs subMode CR.PQSupportOff
|
||||
|
||||
getUserAddressConnection :: DB.Connection -> VersionRangeChat -> User -> ExceptT StoreError IO Connection
|
||||
getUserAddressConnection db vr User {userId} = do
|
||||
ExceptT . firstRow (toConnection vr) SEUserContactLinkNotFound $
|
||||
getUserAddressConnection :: DB.Connection -> StoreCxt -> User -> ExceptT StoreError IO Connection
|
||||
getUserAddressConnection db cxt User {userId} = do
|
||||
ExceptT . firstRow (toConnection cxt) SEUserContactLinkNotFound $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
@@ -525,8 +525,8 @@ setUserContactLinkShortLink db userContactLinkId shortLink =
|
||||
|]
|
||||
(shortLink, BI True, BI True, BI False, userContactLinkId)
|
||||
|
||||
getContactWithoutConnViaAddress :: DB.Connection -> VersionRangeChat -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
|
||||
getContactWithoutConnViaAddress db vr user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
getContactWithoutConnViaAddress :: DB.Connection -> StoreCxt -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe Contact)
|
||||
getContactWithoutConnViaAddress db cxt user@User {userId} (cReqSchema1, cReqSchema2) = do
|
||||
ctId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
@@ -539,10 +539,10 @@ getContactWithoutConnViaAddress db vr user@User {userId} (cReqSchema1, cReqSchem
|
||||
WHERE cp.user_id = ? AND cp.contact_link IN (?,?) AND c.connection_id IS NULL
|
||||
|]
|
||||
(userId, cReqSchema1, cReqSchema2)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db vr user) ctId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db cxt user) ctId_
|
||||
|
||||
getContactWithoutConnViaShortAddress :: DB.Connection -> VersionRangeChat -> User -> ShortLinkContact -> IO (Maybe Contact)
|
||||
getContactWithoutConnViaShortAddress db vr user@User {userId} shortLink = do
|
||||
getContactWithoutConnViaShortAddress :: DB.Connection -> StoreCxt -> User -> ShortLinkContact -> IO (Maybe Contact)
|
||||
getContactWithoutConnViaShortAddress db cxt user@User {userId} shortLink = do
|
||||
ctId_ <-
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
@@ -555,7 +555,7 @@ getContactWithoutConnViaShortAddress db vr user@User {userId} shortLink = do
|
||||
WHERE cp.user_id = ? AND cp.contact_link = ? AND c.connection_id IS NULL
|
||||
|]
|
||||
(userId, shortLink)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db vr user) ctId_
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getContact db cxt user) ctId_
|
||||
|
||||
updateUserAddressSettings :: DB.Connection -> Int64 -> AddressSettings -> IO ()
|
||||
updateUserAddressSettings db userContactLinkId AddressSettings {businessAddress, autoAccept, autoReply} =
|
||||
|
||||
@@ -228,12 +228,12 @@ type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, Maybe Int64, BoolInt, May
|
||||
|
||||
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe Int64, Maybe BoolInt, Maybe GroupLinkId, Maybe XContactId) :. (Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe BoolInt, Maybe LocalAlias) :. EntityIdsRow :. (Maybe UTCTime, Maybe Text, Maybe UTCTime, Maybe PQSupport, Maybe PQEncryption, Maybe PQEncryption, Maybe PQEncryption, Maybe Int, Maybe Int, Maybe VersionChat, Maybe VersionChat, Maybe VersionChat)
|
||||
|
||||
toConnection :: VersionRangeChat -> ConnectionRow -> Connection
|
||||
toConnection vr ((connId, acId, connLevel, viaContact, viaUserContactLink, BI viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, connStatus, connType, BI contactConnInitiated, localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled, pqRcvEnabled, authErrCounter, quotaErrCounter, chatV, minVer, maxVer)) =
|
||||
toConnection :: StoreCxt -> ConnectionRow -> Connection
|
||||
toConnection cxt ((connId, acId, connLevel, viaContact, viaUserContactLink, BI viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, connStatus, connType, BI contactConnInitiated, localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled, pqRcvEnabled, authErrCounter, quotaErrCounter, chatV, minVer, maxVer)) =
|
||||
Connection
|
||||
{ connId,
|
||||
agentConnId = AgentConnId acId,
|
||||
connChatVersion = fromMaybe (vr `peerConnChatVersion` peerChatVRange) chatV,
|
||||
connChatVersion = fromMaybe (vr cxt `peerConnChatVersion` peerChatVRange) chatV,
|
||||
peerChatVRange = peerChatVRange,
|
||||
connLevel,
|
||||
viaContact,
|
||||
@@ -263,9 +263,9 @@ toConnection vr ((connId, acId, connLevel, viaContact, viaUserContactLink, BI vi
|
||||
entityId_ ConnMember = groupMemberId
|
||||
entityId_ ConnUserContact = userContactLinkId
|
||||
|
||||
toMaybeConnection :: VersionRangeChat -> MaybeConnectionRow -> Maybe Connection
|
||||
toMaybeConnection vr ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, Just connStatus, Just connType, Just contactConnInitiated, Just localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just pqSupport, Just pqEncryption, pqSndEnabled_, pqRcvEnabled_, Just authErrCounter, Just quotaErrCounter, connChatVersion, Just minVer, Just maxVer)) =
|
||||
Just $ toConnection vr ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled_, pqRcvEnabled_, authErrCounter, quotaErrCounter, connChatVersion, minVer, maxVer))
|
||||
toMaybeConnection :: StoreCxt -> MaybeConnectionRow -> Maybe Connection
|
||||
toMaybeConnection cxt ((Just connId, Just agentConnId, Just connLevel, viaContact, viaUserContactLink, Just viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, Just connStatus, Just connType, Just contactConnInitiated, Just localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (Just createdAt, code_, verifiedAt_, Just pqSupport, Just pqEncryption, pqSndEnabled_, pqRcvEnabled_, Just authErrCounter, Just quotaErrCounter, connChatVersion, Just minVer, Just maxVer)) =
|
||||
Just $ toConnection cxt ((connId, agentConnId, connLevel, viaContact, viaUserContactLink, viaGroupLink, groupLinkId, xContactId) :. (customUserProfileId, connStatus, connType, contactConnInitiated, localAlias) :. (contactId, groupMemberId, userContactLinkId) :. (createdAt, code_, verifiedAt_, pqSupport, pqEncryption, pqSndEnabled_, pqRcvEnabled_, authErrCounter, quotaErrCounter, connChatVersion, minVer, maxVer))
|
||||
toMaybeConnection _ _ = Nothing
|
||||
|
||||
createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> ConnStatus -> VersionChat -> VersionRangeChat -> Maybe ContactId -> Maybe Int64 -> Maybe ProfileId -> Int -> UTCTime -> SubscriptionMode -> PQSupport -> IO Connection
|
||||
@@ -488,10 +488,10 @@ type ContactRow' = (ProfileId, ContactName, ContactName, Text, Maybe Text, Maybe
|
||||
|
||||
type ContactRow = Only ContactId :. ContactRow'
|
||||
|
||||
toContact :: VersionRangeChat -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
|
||||
toContact vr user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL)) :. connRow) =
|
||||
toContact :: StoreCxt -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
|
||||
toContact cxt user chatTags ((Only contactId :. (profileId, localDisplayName, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, BI contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, BI favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. preparedContactRow :. (contactRequestId, contactGroupMemberId, BI contactGrpInvSent) :. groupDirectInvRow :. (uiThemes, BI chatDeleted, customData, chatItemTTL)) :. connRow) =
|
||||
let profile = LocalProfile {profileId, displayName, fullName, shortDescr, image, contactLink, peerType, preferences, localAlias}
|
||||
activeConn = toMaybeConnection vr connRow
|
||||
activeConn = toMaybeConnection cxt connRow
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
|
||||
incognito = maybe False connIncognito activeConn
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences incognito
|
||||
@@ -673,9 +673,9 @@ type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, Ver
|
||||
|
||||
type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences)
|
||||
|
||||
toGroupInfo :: VersionRangeChat -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
|
||||
toGroupInfo vr userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri) :. groupKeysRow :. userMemberRow) =
|
||||
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr}
|
||||
toGroupInfo :: StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
|
||||
toGroupInfo cxt userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri) :. groupKeysRow :. userMemberRow) =
|
||||
let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr cxt}
|
||||
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
|
||||
fullGroupPreferences = mergeGroupPreferences groupPreferences
|
||||
publicGroup = toPublicGroupProfile groupType_ groupLink_ publicGroupId_ (toPublicGroupAccess accessRow)
|
||||
@@ -756,9 +756,9 @@ groupMemberQuery =
|
||||
LEFT JOIN connections c ON c.group_member_id = m.group_member_id
|
||||
|]
|
||||
|
||||
toContactMember :: VersionRangeChat -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
|
||||
toContactMember vr User {userContactId} (memberRow :. connRow) =
|
||||
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection vr connRow}
|
||||
toContactMember :: StoreCxt -> User -> (GroupMemberRow :. MaybeConnectionRow) -> GroupMember
|
||||
toContactMember cxt User {userContactId} (memberRow :. connRow) =
|
||||
(toGroupMember userContactId memberRow) {activeConn = toMaybeConnection cxt connRow}
|
||||
|
||||
rowToLocalProfile :: ProfileRow -> LocalProfile
|
||||
rowToLocalProfile (profileId, displayName, fullName, shortDescr, image, contactLink, peerType, localAlias, preferences) =
|
||||
@@ -875,10 +875,10 @@ addGroupChatTags db g@GroupInfo {groupId} = do
|
||||
chatTags <- getGroupChatTags db groupId
|
||||
pure (g :: GroupInfo) {chatTags}
|
||||
|
||||
getGroupInfo :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfo db vr User {userId, userContactId} groupId = ExceptT $ do
|
||||
getGroupInfo :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfo
|
||||
getGroupInfo db cxt User {userId, userContactId} groupId = ExceptT $ do
|
||||
chatTags <- getGroupChatTags db groupId
|
||||
firstRow (toGroupInfo vr userContactId chatTags) (SEGroupNotFound groupId) $
|
||||
firstRow (toGroupInfo cxt userContactId chatTags) (SEGroupNotFound groupId) $
|
||||
DB.query
|
||||
db
|
||||
(groupInfoQuery <> " WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ?")
|
||||
|
||||
@@ -2033,6 +2033,10 @@ type VersionChat = Version ChatVersion
|
||||
|
||||
type VersionRangeChat = VersionRange ChatVersion
|
||||
|
||||
-- | Store-wide context passed to store functions in place of the bare `vr`
|
||||
-- parameter. Built from config by mkStoreCxt; more fields are added here over time.
|
||||
newtype StoreCxt = StoreCxt {vr :: VersionRangeChat}
|
||||
|
||||
pattern VersionChat :: Word16 -> VersionChat
|
||||
pattern VersionChat v = Version v
|
||||
|
||||
|
||||
@@ -23,7 +23,7 @@ import Data.List (isPrefixOf, isSuffixOf)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.String
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..))
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), mkStoreCxt)
|
||||
import Simplex.Chat.Markdown (viewName)
|
||||
import Simplex.Chat.Messages.CIContent (e2eInfoNoPQText, e2eInfoPQText)
|
||||
import Simplex.Chat.Protocol
|
||||
@@ -699,10 +699,10 @@ getCtConn cc contactId = getTestCCContact cc contactId >>= maybe (fail "no conne
|
||||
|
||||
getTestCCContact :: TestCC -> ContactId -> IO Contact
|
||||
getTestCCContact cc contactId = do
|
||||
let TestCC {chatController = ChatController {config = ChatConfig {chatVRange = vr}}} = cc
|
||||
let TestCC {chatController = ChatController {config}} = cc
|
||||
withCCTransaction cc $ \db ->
|
||||
withCCUser cc $ \user ->
|
||||
runExceptT (getContact db vr user contactId) >>= either (fail . show) pure
|
||||
runExceptT (getContact db (mkStoreCxt config) user contactId) >>= either (fail . show) pure
|
||||
|
||||
lastItemId :: HasCallStack => TestCC -> IO String
|
||||
lastItemId cc = do
|
||||
|
||||
Reference in New Issue
Block a user