mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-08-29 03:18:37 +00:00
Merge branch 'master' into f/msg-signing
This commit is contained in:
spaced4ndy
@@ -529,7 +529,7 @@ data ChatCommand
|
||||
| AddContact IncognitoEnabled
|
||||
| APISetConnectionIncognito Int64 IncognitoEnabled
|
||||
| APIChangeConnectionUser Int64 UserId -- new user id to switch connection to
|
||||
| APIConnectPlan {userId :: UserId, connectTarget :: Maybe AConnectTarget, resolveKnown :: Bool, linkOwnerSig :: Maybe LinkOwnerSig} -- Maybe AConnectTarget is used to report parsing failure as special error
|
||||
| APIConnectPlan {userId :: UserId, connectTarget :: Maybe AConnectTarget, resolveMode :: PlanResolveMode, linkOwnerSig :: Maybe LinkOwnerSig} -- Maybe AConnectTarget is used to report parsing failure as special error
|
||||
| APIPrepareContact UserId ACreatedConnLink (Maybe SimplexDomain) ContactShortLinkData
|
||||
| APIPrepareGroup UserId CreatedLinkContact DirectLink (Maybe SimplexDomain) GroupShortLinkData
|
||||
| APIChangePreparedContactUser ContactId UserId
|
||||
@@ -670,6 +670,22 @@ data ChatCommand
|
||||
CustomChatCommand ByteString
|
||||
deriving (Show)
|
||||
|
||||
data PlanResolveMode
|
||||
= PRMAllGroups -- resolve all known groups and all unknown chats
|
||||
| PRMUnknown -- only resolve if chat is unknown (default)
|
||||
| PRMNever -- do not resolve links and names, only do local search
|
||||
deriving (Eq, Show)
|
||||
|
||||
planResolveModeP :: A.Parser PlanResolveMode
|
||||
planResolveModeP =
|
||||
A.takeTill (== ' ') >>= \case
|
||||
"allGroups" -> pure PRMAllGroups
|
||||
"on" -> pure PRMAllGroups
|
||||
"unknown" -> pure PRMUnknown
|
||||
"off" -> pure PRMUnknown
|
||||
"never" -> pure PRMNever
|
||||
_ -> fail "bad PlanResolveMode"
|
||||
|
||||
allowRemoteCommand :: ChatCommand -> Bool -- XXX: consider using Relay/Block/ForceLocal
|
||||
allowRemoteCommand = \case
|
||||
StartChat {} -> False
|
||||
@@ -820,7 +836,7 @@ data ChatResponse
|
||||
| CRInvitation {user :: User, connLinkInvitation :: CreatedLinkInvitation, connection :: PendingContactConnection}
|
||||
| CRConnectionIncognitoUpdated {user :: User, toConnection :: PendingContactConnection, customUserProfile :: Maybe Profile}
|
||||
| CRConnectionUserChanged {user :: User, fromConnection :: PendingContactConnection, toConnection :: PendingContactConnection, newUser :: User}
|
||||
| CRConnectionPlan {user :: User, connLink :: ACreatedConnLink, connectionPlan :: ConnectionPlan}
|
||||
| CRConnectionPlan {user :: User, connLink :: ACreatedConnLink, planSimplexName :: Maybe SimplexNameInfo, otherSimplexName :: Maybe SimplexNameInfo, connectionPlan :: ConnectionPlan}
|
||||
| CRNewPreparedChat {user :: User, chat :: AChat}
|
||||
| CRContactUserChanged {user :: User, fromContact :: Contact, newUser :: User, toContact :: Contact}
|
||||
| CRGroupUserChanged {user :: User, fromGroup :: GroupInfo, newUser :: User, toGroup :: GroupInfo}
|
||||
@@ -1096,7 +1112,7 @@ data InvitationLinkPlan
|
||||
deriving (Show)
|
||||
|
||||
data ContactAddressPlan
|
||||
= CAPOk {contactSLinkData_ :: Maybe ContactShortLinkData, ownerVerification :: Maybe OwnerVerification, verifiedDomain :: Maybe SimplexDomain}
|
||||
= CAPOk {contactSLinkData_ :: Maybe ContactShortLinkData, ownerVerification :: Maybe OwnerVerification}
|
||||
| CAPOwnLink
|
||||
| CAPConnectingConfirmReconnect
|
||||
| CAPConnectingProhibit {contact :: Contact}
|
||||
@@ -1105,11 +1121,11 @@ data ContactAddressPlan
|
||||
deriving (Show)
|
||||
|
||||
data GroupLinkPlan
|
||||
= GLPOk {groupSLinkInfo_ :: Maybe GroupShortLinkInfo, groupSLinkData_ :: Maybe GroupShortLinkData, ownerVerification :: Maybe OwnerVerification, verifiedDomain :: Maybe SimplexDomain}
|
||||
= GLPOk {groupSLinkInfo_ :: Maybe GroupShortLinkInfo, groupSLinkData_ :: Maybe GroupShortLinkData, ownerVerification :: Maybe OwnerVerification}
|
||||
| GLPOwnLink {groupInfo :: GroupInfo}
|
||||
| GLPConnectingConfirmReconnect
|
||||
| GLPConnectingProhibit {groupInfo_ :: Maybe GroupInfo}
|
||||
| GLPKnown {groupInfo :: GroupInfo, groupUpdated :: BoolDef, ownerVerification :: Maybe OwnerVerification, linkOwners :: ListDef GroupLinkOwner}
|
||||
| GLPKnown {groupInfo :: GroupInfo, groupUpdated :: Bool, ownerVerification :: Maybe OwnerVerification, linkOwners :: ListDef GroupLinkOwner}
|
||||
| GLPNoRelays {groupSLinkData_ :: Maybe GroupShortLinkData}
|
||||
| GLPUpdateRequired {groupSLinkData_ :: Maybe GroupShortLinkData}
|
||||
deriving (Show)
|
||||
@@ -1433,6 +1449,7 @@ data ChatErrorType
|
||||
| CEChatStoreChanged
|
||||
| CEInvalidConnReq
|
||||
| CESimplexDomainNotReady {simplexDomain :: SimplexDomain, simplexDomainError :: SimplexDomainError}
|
||||
| CENotResolvedLocally -- a name or link is not a known chat in the local store and online resolution is off (PRMNever)
|
||||
| CEUnsupportedConnReq
|
||||
| CEInvalidChatMessage {connection :: Connection, msgMeta :: Maybe MsgMetaJSON, messageData :: Text, message :: String}
|
||||
| CEConnReqMessageProhibited
|
||||
|
||||
@@ -2061,8 +2061,9 @@ processChatCommand cxt nm = \case
|
||||
createDirectConnection db newUser agConnId ccLink' Nothing ConnNew Nothing subMode initialChatVersion PQSupportOn
|
||||
deleteAgentConnectionAsync (aConnId' conn)
|
||||
pure conn'
|
||||
APIConnectPlan userId (Just ct) resolveKnown linkOwnerSig_ -> withUserId userId $ \user ->
|
||||
uncurry (CRConnectionPlan user) <$> connectPlan user ct resolveKnown linkOwnerSig_
|
||||
APIConnectPlan userId (Just ct) resolveMode linkOwnerSig_ -> withUserId userId $ \user -> do
|
||||
(ccLink, planSimplexName, otherSimplexName, plan) <- connectPlan user ct resolveMode linkOwnerSig_ Nothing
|
||||
pure $ CRConnectionPlan user ccLink planSimplexName otherSimplexName plan
|
||||
APIConnectPlan _ Nothing _ _ -> throwChatError CEInvalidConnReq
|
||||
APIPrepareContact userId accLink verifiedDomain contactSLinkData -> withUserId userId $ \user -> do
|
||||
let ContactShortLinkData {profile, message, business} = contactSLinkData
|
||||
@@ -2286,12 +2287,12 @@ processChatCommand cxt nm = \case
|
||||
CVRSentInvitation conn incognitoProfile -> pure $ CRSentInvitation user (mkPendingContactConnection conn Nothing) incognitoProfile
|
||||
APIConnect _ _ Nothing -> throwChatError CEInvalidConnReq
|
||||
Connect incognito (Just ct) -> withUser $ \user -> do
|
||||
let con m cReq = pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing Nothing))
|
||||
(ccLink, plan) <- connectPlan user ct False Nothing `catchAllErrors` \e -> case ct of
|
||||
let con m cReq = pure (ACCL m (CCLink cReq Nothing), Nothing, Nothing, CPInvitationLink (ILPOk Nothing Nothing))
|
||||
(ccLink, planSimplexName, otherSimplexName, plan) <- connectPlan user ct PRMUnknown Nothing Nothing `catchAllErrors` \e -> case ct of
|
||||
ACTarget m (CTFullContact cReq) -> con m cReq
|
||||
ACTarget m (CTInv (CLFull cReq)) -> con m cReq
|
||||
_ -> throwError e
|
||||
connectWithPlan user incognito ccLink plan
|
||||
connectWithPlan user incognito ccLink planSimplexName otherSimplexName plan
|
||||
Connect _ Nothing -> throwChatError CEInvalidConnReq
|
||||
APIVerifyContactDomain contactId -> withUser $ \user -> do
|
||||
ct@Contact {profile = LocalProfile {contactDomain}, preparedContact} <- withFastStore $ \db -> getContact db cxt user contactId
|
||||
@@ -2322,8 +2323,8 @@ processChatCommand cxt nm = \case
|
||||
toView $ CEvtChatInfoUpdated user (AChatInfo SCTDirect $ DirectChat ct')
|
||||
throwError e
|
||||
ConnectSimplex incognito -> withUser $ \user -> do
|
||||
plan <- contactRequestPlan user adminContactReq Nothing Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing Nothing Nothing))
|
||||
connectWithPlan user incognito (ACCL SCMContact (CCLink adminContactReq Nothing)) plan
|
||||
plan <- contactRequestPlan user adminContactReq Nothing Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing Nothing))
|
||||
connectWithPlan user incognito (ACCL SCMContact (CCLink adminContactReq Nothing)) Nothing Nothing plan
|
||||
DeleteContact cName cdm -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId Nothing) cdm
|
||||
ClearContact cName -> withContactName cName $ \chatId -> APIClearChat $ ChatRef CTDirect chatId Nothing
|
||||
APIListContacts userId -> withUserId userId $ \user ->
|
||||
@@ -4182,13 +4183,13 @@ processChatCommand cxt nm = \case
|
||||
pure (gId, chatSettings)
|
||||
_ -> throwCmdError "not supported"
|
||||
processChatCommand cxt nm $ APISetChatSettings (ChatRef cType chatId Nothing) $ updateSettings chatSettings
|
||||
connectPlan :: User -> AConnectTarget -> Bool -> Maybe LinkOwnerSig -> CM (ACreatedConnLink, ConnectionPlan)
|
||||
connectPlan user (ACTarget SCMInvitation (CTInv cLink)) _ sig_ = case cLink of
|
||||
connectPlan :: User -> AConnectTarget -> PlanResolveMode -> Maybe LinkOwnerSig -> Maybe (Either ChatError NameRecord) -> CM (ACreatedConnLink, Maybe SimplexNameInfo, Maybe SimplexNameInfo, ConnectionPlan)
|
||||
connectPlan user (ACTarget SCMInvitation (CTInv cLink)) _ sig_ _ = case cLink of
|
||||
CLFull cReq -> invitationReqAndPlan cReq Nothing Nothing Nothing
|
||||
CLShort l -> do
|
||||
let l' = serverShortLink l
|
||||
knownLinkPlans l' >>= \case
|
||||
Just r -> pure r
|
||||
Just (l, p) -> pure (l, Nothing, Nothing, p)
|
||||
Nothing -> do
|
||||
(FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l'
|
||||
contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData)
|
||||
@@ -4203,27 +4204,56 @@ processChatCommand cxt nm = \case
|
||||
Nothing -> bimap inv (CPInvitationLink . ILPKnown) <$$> getContactViaShortLinkToConnect db cxt user l'
|
||||
invitationReqAndPlan cReq sLnk_ cld ov = do
|
||||
plan <- invitationRequestPlan user cReq cld ov `catchAllErrors` (pure . CPError)
|
||||
pure (ACCL SCMInvitation (CCLink cReq sLnk_), plan)
|
||||
connectPlan user (ACTarget SCMContact ct) resolveKnown sig_ = case ct of
|
||||
pure (ACCL SCMInvitation (CCLink cReq sLnk_), Nothing, Nothing, plan)
|
||||
connectPlan user (ACTarget SCMContact ct) resolveMode sig_ nameRec = case ct of
|
||||
CTDomain d
|
||||
-- local search only: look up #d then @d in the store, without online name resolution
|
||||
| resolveMode == PRMNever -> connectPlanNoName $ ChatError CENotResolvedLocally
|
||||
| otherwise ->
|
||||
tryAllErrors (withAgent $ \a -> resolveSimplexName a nm (aUserId user) d) >>= \case
|
||||
Right nr
|
||||
| isJust (firstNameLink CCTChannel (nrSimplexChannel nr)) ->
|
||||
(addOther nr <$> connectPlanName NTPublicGroup (Right nr)) `catchAllErrors` \e ->
|
||||
(addOther nr <$> connectPlanName NTContact (Right nr) `catchAllErrors` \_ -> throwError e)
|
||||
| isJust (firstNameLink CCTContact (nrSimplexContact nr)) ->
|
||||
addOther nr <$> connectPlanName NTContact (Right nr)
|
||||
| otherwise -> connectPlanNoName $ ChatError $ CESimplexDomainNotReady d SDENoValidLink
|
||||
Left e -> connectPlanNoName e
|
||||
where
|
||||
connectPlanName nameType nr_ = connectPlan user connTarget resolveMode sig_ (Just nr_)
|
||||
where
|
||||
connTarget = ACTarget SCMContact $ CTShortContact $ CTName $ SimplexNameInfo nameType d
|
||||
connectPlanNoName e =
|
||||
connectPlanName NTPublicGroup (Left e) `catchAllErrors` \e' ->
|
||||
(connectPlanName NTContact (Left e) `catchAllErrors` \_ -> throwError e')
|
||||
-- the same domain can resolve to both an @ name (contact or business) and a # channel;
|
||||
-- keyed off the resolved name's type, so a contact name returning a business group still offers the channel
|
||||
addOther nr (l, planName, _, p) = (l, planName, otherName, p)
|
||||
where
|
||||
otherName = case planName of
|
||||
Just (SimplexNameInfo NTContact _) | isJust (firstNameLink CCTChannel (nrSimplexChannel nr)) -> Just $ SimplexNameInfo NTPublicGroup d
|
||||
Just (SimplexNameInfo NTPublicGroup _) | isJust (firstNameLink CCTContact (nrSimplexContact nr)) -> Just $ SimplexNameInfo NTContact d
|
||||
_ -> Nothing
|
||||
CTFullContact cReq -> do
|
||||
plan <- contactOrGroupRequestPlan user cReq `catchAllErrors` (pure . CPError)
|
||||
pure (ACCL SCMContact $ CCLink cReq Nothing, plan)
|
||||
pure (ACCL SCMContact $ CCLink cReq Nothing, Nothing, Nothing, plan)
|
||||
CTShortContact nl ->
|
||||
case ctType of
|
||||
(\(l, p) -> (l, simplexName_, Nothing, p)) <$> case ctType of
|
||||
CCTContact ->
|
||||
knownLinkPlans >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
when (resolveMode == PRMNever) $ throwChatError CENotResolvedLocally
|
||||
l' <- resolveSLink
|
||||
(FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l'
|
||||
contactSLinkData_ <- mapM linkDataBadge =<< liftIO (decodeLinkUserData cData)
|
||||
let linkProfile_ = (\ContactShortLinkData {profile} -> profile) <$> contactSLinkData_
|
||||
linkDomain_ = linkProfile_ >>= \Profile {contactDomain} -> claimDomain <$> contactDomain
|
||||
verifiedDomain = case nl of CTName ni -> Just (nameDomain ni); _ -> Nothing
|
||||
refreshContact ct' = case (verifiedDomain, linkProfile_) of
|
||||
planDomain = case nl of CTName ni -> Just (nameDomain ni); _ -> Nothing
|
||||
refreshContact ct' = case (planDomain, linkProfile_) of
|
||||
(Just _, Just p) -> updateContactFromLinkData user ct' p
|
||||
_ -> pure ct'
|
||||
forM_ verifiedDomain $ \nameDomain ->
|
||||
forM_ planDomain $ \nameDomain ->
|
||||
unless (linkDomain_ == Just nameDomain) $ throwChatError $ CESimplexDomainNotReady nameDomain SDEUnknownDomain
|
||||
withFastStore' (\db -> getContactWithoutConnViaShortAddress db cxt user l') >>= \case
|
||||
Just ct' | not (contactDeleted ct') -> do
|
||||
@@ -4234,15 +4264,15 @@ processChatCommand cxt nm = \case
|
||||
ov = verifyLinkOwner rootKey owners l' sig_
|
||||
plan <- contactRequestPlan user cReq contactSLinkData_ ov
|
||||
case plan of
|
||||
CPContactAddress cap@(CAPOk {}) -> pure (con l' cReq, CPContactAddress cap {verifiedDomain})
|
||||
CPContactAddress (CAPKnown ct') -> do
|
||||
ct'' <- refreshContact ct'
|
||||
pure (con l' cReq, CPContactAddress (CAPKnown ct''))
|
||||
pure (con l' cReq, plan {contactAddressPlan = CAPKnown ct''})
|
||||
CPContactAddress (CAPContactViaAddress ct') -> do
|
||||
ct'' <- refreshContact ct'
|
||||
pure (con l' cReq, CPContactAddress (CAPContactViaAddress ct''))
|
||||
pure (con l' cReq, plan {contactAddressPlan = CAPContactViaAddress ct''})
|
||||
_ -> pure (con l' cReq, plan)
|
||||
where
|
||||
knownLinkPlans :: CM (Maybe (ACreatedConnLink, ConnectionPlan))
|
||||
knownLinkPlans = withFastStore $ \db ->
|
||||
liftIO (getUserContactLinkViaTarget db user nl') >>= \case
|
||||
Just UserContactLink {connLinkContact} -> pure $ Just (ACCL SCMContact connLinkContact, CPContactAddress CAPOwnLink)
|
||||
@@ -4254,24 +4284,26 @@ processChatCommand cxt nm = \case
|
||||
CCTChannel -> groupShortLinkPlan
|
||||
CCTRelay -> throwCmdError "chat relay links are not supported in this version"
|
||||
where
|
||||
nl' = case nl of
|
||||
CTLink sl -> CTLink (serverShortLink sl)
|
||||
CTName _ -> nl
|
||||
(nl', simplexName_) = case nl of
|
||||
CTLink sl -> (CTLink (serverShortLink sl), Nothing)
|
||||
CTName ni -> (nl, Just ni)
|
||||
ctType = case nl of
|
||||
CTLink (CSLContact _ t _ _) -> t
|
||||
CTName SimplexNameInfo {nameType = NTContact} -> CCTContact
|
||||
CTName SimplexNameInfo {nameType = NTPublicGroup} -> CCTChannel
|
||||
resolveSLink = case nl' of
|
||||
CTLink l' -> pure l'
|
||||
CTName n -> serverShortLink <$> resolveNameLink user n
|
||||
CTName n -> serverShortLink <$> resolveNameLink n
|
||||
con l' cReq = ACCL SCMContact $ CCLink cReq (Just l')
|
||||
gPlan (ccl, g) = if memberRemoved (membership g) then Nothing else Just (ACCL SCMContact ccl, CPGroupLink (GLPKnown g (BoolDef False) Nothing (ListDef [])))
|
||||
gPlan (ccl, g) = if memberRemoved (membership g) then Nothing else Just (ACCL SCMContact ccl, CPGroupLink (GLPKnown g False Nothing (ListDef [])))
|
||||
groupShortLinkPlan :: CM (ACreatedConnLink, ConnectionPlan)
|
||||
groupShortLinkPlan =
|
||||
knownLinkPlans >>= \case
|
||||
Just (_, CPGroupLink (GLPKnown g _ _ _))
|
||||
| resolveKnown -> resolveKnownGroup g
|
||||
| resolveMode == PRMAllGroups -> resolveKnownGroup g
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
when (resolveMode == PRMNever) $ throwChatError CENotResolvedLocally
|
||||
l' <- resolveSLink
|
||||
(fd, cData@(ContactLinkData _ UserContactData {direct, owners, relays})) <- getShortLinkConnReq' nm user l'
|
||||
groupSLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
@@ -4288,23 +4320,29 @@ processChatCommand cxt nm = \case
|
||||
(Nothing, Nothing) -> pure ()
|
||||
_ -> throwChatError CEInvalidConnReq
|
||||
let ov = verifyLinkOwner rootKey owners l' sig_
|
||||
verifiedDomain = case nl of CTName ni -> Just (nameDomain ni); _ -> Nothing
|
||||
plan <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_ ov
|
||||
forM_ verifiedDomain $ \nameDomain ->
|
||||
planDomain = case nl of CTName ni -> Just (nameDomain ni); _ -> Nothing
|
||||
plan0 <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_ ov
|
||||
-- a joined channel is found by link but not by name (its domain is not verified locally,
|
||||
-- e.g. an un-upgraded relay dropped the claim); refresh its profile from the fresh link
|
||||
-- data and mark it verified, so the check below passes and future by-name lookups match
|
||||
plan <- case (planDomain, plan0, groupSLinkData_) of
|
||||
(Just _, CPGroupLink (GLPKnown g u o os), Just sLinkData) ->
|
||||
(\(g', _) -> CPGroupLink (GLPKnown g' u o os)) <$> updateGroupFromLinkData user g sLinkData
|
||||
_ -> pure plan0
|
||||
forM_ planDomain $ \nameDomain ->
|
||||
let domain_ = (\GroupProfile {publicGroup} -> claimDomain <$> (publicGroup >>= publicGroupAccess >>= groupDomainClaim)) =<< case plan of
|
||||
CPGroupLink (GLPOk _ (Just GroupShortLinkData {groupProfile}) _ _) -> Just groupProfile
|
||||
CPGroupLink (GLPOk _ (Just GroupShortLinkData {groupProfile}) _) -> Just groupProfile
|
||||
CPGroupLink (GLPKnown GroupInfo {groupProfile} _ _ _) -> Just groupProfile
|
||||
CPGroupLink (GLPOwnLink GroupInfo {groupProfile}) -> Just groupProfile
|
||||
CPGroupLink (GLPConnectingProhibit (Just GroupInfo {groupProfile})) -> Just groupProfile
|
||||
_ -> (\GroupShortLinkData {groupProfile} -> groupProfile) <$> groupSLinkData_
|
||||
in unless (domain_ == Just nameDomain) $ throwChatError $ CESimplexDomainNotReady nameDomain SDEUnknownDomain
|
||||
pure $ case plan of
|
||||
CPGroupLink glp@(GLPOk {}) -> (con l' cReq, CPGroupLink glp {verifiedDomain})
|
||||
_ -> (con l' cReq, plan)
|
||||
pure (con l' cReq, plan)
|
||||
where
|
||||
unsupportedGroupType = \case
|
||||
Just GroupShortLinkData {groupProfile = GroupProfile {publicGroup = Just PublicGroupProfile {groupType}}} -> groupType /= GTChannel
|
||||
_ -> False
|
||||
knownLinkPlans :: CM (Maybe (ACreatedConnLink, ConnectionPlan))
|
||||
knownLinkPlans = withFastStore $ \db ->
|
||||
liftIO (getGroupInfoViaUserTarget db cxt user nl') >>= \case
|
||||
Just (ccl, g) -> pure $ Just (ACCL SCMContact ccl, CPGroupLink (GLPOwnLink g))
|
||||
@@ -4318,29 +4356,29 @@ processChatCommand cxt nm = \case
|
||||
(g', updated) <- case groupSLinkData_ of
|
||||
Just sLinkData -> updateGroupFromLinkData user g sLinkData
|
||||
_ -> pure (g, False)
|
||||
pure (con l' (linkConnReq fd), CPGroupLink (GLPKnown g' (BoolDef updated) ov (ListDef glOwners)))
|
||||
-- resolve a name to its first contact/channel short link
|
||||
resolveNameLink :: User -> SimplexNameInfo -> CM (ConnShortLink 'CMContact)
|
||||
resolveNameLink user SimplexNameInfo {nameType, nameDomain} = do
|
||||
NameRecord {nrSimplexContact, nrSimplexChannel} <-
|
||||
withAgent $ \a -> resolveSimplexName a nm (aUserId user) nameDomain
|
||||
let (candidates, ctType) = case nameType of
|
||||
NTContact -> (nrSimplexContact, CCTContact)
|
||||
NTPublicGroup -> (nrSimplexChannel, CCTChannel)
|
||||
maybe (throwChatError $ CESimplexDomainNotReady nameDomain SDENoValidLink) pure $ firstNameLink ctType candidates
|
||||
connectWithPlan :: User -> IncognitoEnabled -> ACreatedConnLink -> ConnectionPlan -> CM ChatResponse
|
||||
connectWithPlan user@User {userId} incognito ccLink plan
|
||||
pure (con l' (linkConnReq fd), CPGroupLink (GLPKnown g' updated ov (ListDef glOwners)))
|
||||
-- resolve a name to its first contact/channel short link
|
||||
resolveNameLink :: SimplexNameInfo -> CM (ConnShortLink 'CMContact)
|
||||
resolveNameLink SimplexNameInfo {nameType, nameDomain} = do
|
||||
NameRecord {nrSimplexContact, nrSimplexChannel} <- maybe (withAgent $ \a -> resolveSimplexName a nm (aUserId user) nameDomain) (ExceptT . pure) nameRec
|
||||
let (candidates, ctType') = case nameType of
|
||||
NTContact -> (nrSimplexContact, CCTContact)
|
||||
NTPublicGroup -> (nrSimplexChannel, CCTChannel)
|
||||
maybe (throwChatError $ CESimplexDomainNotReady nameDomain SDENoValidLink) pure $ firstNameLink ctType' candidates
|
||||
connectWithPlan :: User -> IncognitoEnabled -> ACreatedConnLink -> Maybe SimplexNameInfo -> Maybe SimplexNameInfo -> ConnectionPlan -> CM ChatResponse
|
||||
connectWithPlan user@User {userId} incognito ccLink planSimplexName otherSimplexName plan
|
||||
| connectionPlanProceed plan = do
|
||||
case plan of CPError e -> eToView e; _ -> pure ()
|
||||
case plan of
|
||||
CPContactAddress (CAPContactViaAddress Contact {contactId}) ->
|
||||
processChatCommand cxt nm $ APIConnectContactViaAddress userId incognito contactId
|
||||
CPContactAddress (CAPOk (Just sld) _ vName@(Just _)) -> connectContactViaName sld vName
|
||||
CPGroupLink (GLPOk (Just GroupShortLinkInfo {direct = False}) (Just gld) _ vName)
|
||||
CPContactAddress (CAPOk (Just sld) _) | isJust vName -> connectContactViaName sld vName
|
||||
CPGroupLink (GLPOk (Just GroupShortLinkInfo {direct = False}) (Just gld) _)
|
||||
| ACCL SCMContact ccl <- ccLink -> joinChannelViaRelays ccl gld vName
|
||||
_ -> processChatCommand cxt nm $ APIConnect userId incognito $ Just ccLink
|
||||
| otherwise = pure $ CRConnectionPlan user ccLink plan
|
||||
| otherwise = pure $ CRConnectionPlan user ccLink planSimplexName otherSimplexName plan
|
||||
where
|
||||
vName = nameDomain <$> planSimplexName
|
||||
joinChannelViaRelays :: CreatedLinkContact -> GroupShortLinkData -> Maybe SimplexDomain -> CM ChatResponse
|
||||
joinChannelViaRelays ccl gld vName = do
|
||||
GroupInfo {groupId} <- prepareChannelGroup
|
||||
@@ -4395,21 +4433,22 @@ processChatCommand cxt nm = \case
|
||||
contactRequestPlan user (CRContactUri crData) cld ov = do
|
||||
let cReqSchemas = contactCReqSchemas crData
|
||||
cReqHashes = bimap contactCReqHash contactCReqHash cReqSchemas
|
||||
plan p = pure $ CPContactAddress p
|
||||
withFastStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case
|
||||
Just _ -> pure $ CPContactAddress CAPOwnLink
|
||||
Just _ -> plan $ CAPOwnLink
|
||||
Nothing ->
|
||||
withFastStore' (\db -> getContactConnEntityByConnReqHash db cxt user cReqHashes) >>= \case
|
||||
Nothing ->
|
||||
withFastStore' (\db -> getContactWithoutConnViaAddress db cxt user cReqSchemas) >>= \case
|
||||
Just ct | not (contactDeleted ct) -> pure $ CPContactAddress (CAPContactViaAddress ct)
|
||||
_ -> pure $ CPContactAddress (CAPOk cld ov Nothing)
|
||||
Just ct | not (contactDeleted ct) -> plan $ CAPContactViaAddress ct
|
||||
_ -> plan $ CAPOk cld ov
|
||||
Just (RcvDirectMsgConnection Connection {connStatus} Nothing)
|
||||
| connStatus == ConnPrepared -> pure $ CPContactAddress (CAPOk cld ov Nothing)
|
||||
| otherwise -> pure $ CPContactAddress CAPConnectingConfirmReconnect
|
||||
| connStatus == ConnPrepared -> plan $ CAPOk cld ov
|
||||
| otherwise -> plan CAPConnectingConfirmReconnect
|
||||
Just (RcvDirectMsgConnection _ (Just ct))
|
||||
| not (contactReady ct) && contactActive ct -> pure $ CPContactAddress (CAPConnectingProhibit ct)
|
||||
| contactDeleted ct -> pure $ CPContactAddress (CAPOk cld ov Nothing)
|
||||
| otherwise -> pure $ CPContactAddress (CAPKnown ct)
|
||||
| not (contactReady ct) && contactActive ct -> plan $ CAPConnectingProhibit ct
|
||||
| contactDeleted ct -> plan $ CAPOk cld ov
|
||||
| otherwise -> plan $ CAPKnown ct
|
||||
-- TODO [short links] RcvGroupMsgConnection branch is deprecated? (old group link protocol?)
|
||||
Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo Nothing Nothing Nothing
|
||||
Just _ -> throwCmdError "found connection entity is not RcvDirectMsgConnection or RcvGroupMsgConnection"
|
||||
@@ -4417,27 +4456,30 @@ processChatCommand cxt nm = \case
|
||||
groupJoinRequestPlan user (CRContactUri crData) linkInfo gld ov = do
|
||||
let cReqSchemas = contactCReqSchemas crData
|
||||
cReqHashes = bimap contactCReqHash contactCReqHash cReqSchemas
|
||||
plan p = pure $ CPGroupLink p
|
||||
withFastStore' (\db -> getGroupInfoByUserContactLinkConnReq db cxt user cReqSchemas) >>= \case
|
||||
Just g -> pure $ CPGroupLink (GLPOwnLink g)
|
||||
Just g -> plan $ GLPOwnLink g
|
||||
Nothing -> do
|
||||
connEnt_ <- withFastStore' $ \db -> getContactConnEntityByConnReqHash db cxt user cReqHashes
|
||||
gInfo_ <- withFastStore' $ \db -> getGroupInfoByGroupLinkHash db cxt user cReqHashes
|
||||
case (gInfo_, connEnt_) of
|
||||
(Nothing, Nothing) -> pure $ CPGroupLink (GLPOk linkInfo gld ov Nothing)
|
||||
(Nothing, Nothing) -> plan $ GLPOk linkInfo gld ov
|
||||
-- TODO [short links] RcvDirectMsgConnection branches are deprecated? (old group link protocol?)
|
||||
(Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> pure $ CPGroupLink GLPConnectingConfirmReconnect
|
||||
(Nothing, Just (RcvDirectMsgConnection _conn Nothing)) -> plan $ GLPConnectingConfirmReconnect
|
||||
(Nothing, Just (RcvDirectMsgConnection _ (Just ct)))
|
||||
| not (contactReady ct) && contactActive ct -> pure $ CPGroupLink (GLPConnectingProhibit gInfo_)
|
||||
| otherwise -> pure $ CPGroupLink (GLPOk linkInfo gld ov Nothing)
|
||||
| not (contactReady ct) && contactActive ct -> plan $ GLPConnectingProhibit gInfo_
|
||||
| otherwise -> plan $ GLPOk linkInfo gld ov
|
||||
(Nothing, Just _) -> throwCmdError "found connection entity is not RcvDirectMsgConnection"
|
||||
(Just gInfo, _) -> groupPlan gInfo linkInfo gld ov
|
||||
groupPlan :: GroupInfo -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan
|
||||
groupPlan gInfo@GroupInfo {membership} linkInfo gld ov
|
||||
| memberStatus membership == GSMemRejected = pure $ CPGroupLink (GLPKnown gInfo (BoolDef False) ov (ListDef []))
|
||||
| memberStatus membership == GSMemRejected = plan $ GLPKnown gInfo False ov (ListDef [])
|
||||
| not (memberActive membership) && not (memberRemoved membership) =
|
||||
pure $ CPGroupLink (GLPConnectingProhibit $ Just gInfo)
|
||||
| memberActive membership = pure $ CPGroupLink (GLPKnown gInfo (BoolDef False) ov (ListDef []))
|
||||
| otherwise = pure $ CPGroupLink (GLPOk linkInfo gld ov Nothing)
|
||||
plan $ GLPConnectingProhibit $ Just gInfo
|
||||
| memberActive membership = plan $ GLPKnown gInfo False ov (ListDef [])
|
||||
| otherwise = plan $ GLPOk linkInfo gld ov
|
||||
where
|
||||
plan p = pure $ CPGroupLink p
|
||||
contactCReqSchemas :: ConnReqUriData -> (ConnReqContact, ConnReqContact)
|
||||
contactCReqSchemas crData =
|
||||
( CRContactUri crData {crScheme = SSSimplex},
|
||||
@@ -5459,7 +5501,7 @@ chatCommandP =
|
||||
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayNameP <* A.space <* char_ '@' <*> (Just <$> displayNameP) <* A.space <*> quotedMsg <*> msgTextP),
|
||||
"/_contacts " *> (APIListContacts <$> A.decimal),
|
||||
"/contacts" $> ListContacts,
|
||||
"/_connect plan " *> (APIConnectPlan <$> A.decimal <* A.space <*> ((Just <$> strP) <|> A.takeTill (== ' ') $> Nothing) <*> ((" resolve=" *> onOffP) <|> pure False) <*> optional (" sig=" *> jsonP)),
|
||||
"/_connect plan " *> (APIConnectPlan <$> A.decimal <* A.space <*> ((Just <$> strP) <|> A.takeTill (== ' ') $> Nothing) <*> ((" resolve=" *> planResolveModeP) <|> pure PRMUnknown) <*> optional (" sig=" *> jsonP)),
|
||||
"/_prepare contact " *> (APIPrepareContact <$> A.decimal <* A.space <*> connLinkP <*> optional (" domain=" *> strP) <* A.space <*> jsonP),
|
||||
"/_prepare group " *> (APIPrepareGroup <$> A.decimal <* A.space <*> connLinkP' <*> (" direct=" *> onOffP <|> pure True) <*> optional (" domain=" *> strP) <* A.space <*> jsonP),
|
||||
"/_set contact user @" *> (APIChangePreparedContactUser <$> A.decimal <* A.space <*> A.decimal),
|
||||
|
||||
@@ -929,13 +929,15 @@ acceptContactRequestAsync
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileDirect user (fromIncognitoProfile <$> incognitoProfile) (Just ct) True
|
||||
cxt <- chatStoreCxt
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
(cmdId, acId) <- agentAcceptContactAsync user True cReqInvId (XInfo profileToSend) subMode cReqPQSup chatV
|
||||
(cmdId, acId) <- prepareAgentAccept user True cReqInvId cReqPQSup
|
||||
currentTs <- liftIO getCurrentTime
|
||||
withStore $ \db -> do
|
||||
ct' <- 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 cxt user contactId
|
||||
agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend) cReqPQSup chatV subMode
|
||||
pure ct'
|
||||
|
||||
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
|
||||
acceptGroupJoinRequestAsync
|
||||
@@ -983,10 +985,12 @@ acceptGroupJoinRequestAsync
|
||||
}
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
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
|
||||
(cmdId, acId) <- prepareAgentAccept user True cReqInvId PQSupportOff
|
||||
m <- withStore $ \db -> do
|
||||
liftIO $ createJoiningMemberConnection db user uclId (cmdId, acId) chatV cReqChatVRange groupMemberId subMode
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
agentAcceptContactAsync cmdId acId True cReqInvId msg PQSupportOff chatV subMode
|
||||
pure m
|
||||
|
||||
acceptGroupJoinSendRejectAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> GroupRejectionReason -> CM GroupMember
|
||||
acceptGroupJoinSendRejectAsync
|
||||
@@ -1013,10 +1017,12 @@ acceptGroupJoinSendRejectAsync
|
||||
}
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
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
|
||||
(cmdId, acId) <- prepareAgentAccept user False cReqInvId PQSupportOff
|
||||
m <- withStore $ \db -> do
|
||||
liftIO $ createJoiningMemberConnection db user uclId (cmdId, acId) chatV cReqChatVRange groupMemberId subMode
|
||||
getGroupMemberById db cxt user groupMemberId
|
||||
agentAcceptContactAsync cmdId acId False cReqInvId msg PQSupportOff chatV subMode
|
||||
pure m
|
||||
|
||||
acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
|
||||
acceptBusinessJoinRequestAsync
|
||||
@@ -1045,10 +1051,11 @@ acceptBusinessJoinRequestAsync
|
||||
}
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let chatV = vr cxt `peerConnChatVersion` cReqChatVRange
|
||||
connIds <- agentAcceptContactAsync user True cReqInvId msg subMode PQSupportOff chatV
|
||||
(cmdId, acId) <- prepareAgentAccept user True cReqInvId PQSupportOff
|
||||
withStore' $ \db -> do
|
||||
forM_ xContactId $ \xcId -> setBusinessChatAcceptedXContactId db gInfo xcId
|
||||
createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
|
||||
createJoiningMemberConnection db user uclId (cmdId, acId) chatV cReqChatVRange groupMemberId subMode
|
||||
agentAcceptContactAsync cmdId acId True cReqInvId msg PQSupportOff chatV subMode
|
||||
let cd = CDGroupSnd gInfo Nothing
|
||||
-- TODO [short links] move to profileContactRequest?
|
||||
createInternalChatItem user cd (CISndGroupE2EEInfo $ e2eInfoGroup gInfo) Nothing
|
||||
@@ -1071,12 +1078,14 @@ acceptRelayJoinRequestAsync
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
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
|
||||
(cmdId, acId) <- prepareAgentAccept user True cReqInvId PQSupportOff
|
||||
r <- withStore $ \db -> do
|
||||
liftIO $ createJoiningMemberConnection db user uclId (cmdId, acId) chatV cReqChatVRange groupMemberId subMode
|
||||
gInfo' <- liftIO $ updateRelayOwnStatusFromTo db gInfo RSInvited RSAccepted
|
||||
ownerMember' <- getGroupMemberById db cxt user groupMemberId
|
||||
pure (gInfo', ownerMember')
|
||||
agentAcceptContactAsync cmdId acId True cReqInvId msg PQSupportOff chatV subMode
|
||||
pure r
|
||||
|
||||
rejectRelayInvitationAsync
|
||||
:: User
|
||||
@@ -1096,9 +1105,10 @@ rejectRelayInvitationAsync user uclId cxt groupRelayInv invId reqChatVRange init
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
chatVR <- chatVersionRange
|
||||
let chatV = chatVR `peerConnChatVersion` reqChatVRange
|
||||
connIds <- agentAcceptContactAsync user False invId msg subMode PQSupportOff chatV
|
||||
(cmdId, acId) <- prepareAgentAccept user False invId PQSupportOff
|
||||
withStore' $ \db ->
|
||||
createJoiningMemberConnection db user uclId connIds chatV reqChatVRange groupMemberId subMode
|
||||
createJoiningMemberConnection db user uclId (cmdId, acId) chatV reqChatVRange groupMemberId subMode
|
||||
agentAcceptContactAsync cmdId acId False invId msg PQSupportOff chatV subMode
|
||||
|
||||
businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
|
||||
businessGroupProfile Profile {displayName, fullName, shortDescr, image} groupPreferences =
|
||||
@@ -1454,8 +1464,8 @@ updatePublicGroupData user gInfo
|
||||
| otherwise = pure gInfo
|
||||
|
||||
updateGroupFromLinkData :: User -> GroupInfo -> GroupShortLinkData -> CM (GroupInfo, Bool)
|
||||
updateGroupFromLinkData user gInfo@GroupInfo {groupProfile = p, groupSummary = GroupSummary {publicMemberCount = localCount}} GroupShortLinkData {groupProfile, publicGroupData}
|
||||
| profileChanged || countChanged = do
|
||||
updateGroupFromLinkData user gInfo@GroupInfo {groupProfile = p, groupDomainVerified, groupSummary = GroupSummary {publicMemberCount = localCount}} GroupShortLinkData {groupProfile, publicGroupData}
|
||||
| profileChanged || countChanged || verifyChanged = do
|
||||
cxt <- chatStoreCxt
|
||||
withStore $ \db -> do
|
||||
g <- if profileChanged then updateGroupProfile db user gInfo groupProfile else pure gInfo
|
||||
@@ -1463,13 +1473,19 @@ updateGroupFromLinkData user gInfo@GroupInfo {groupProfile = p, groupSummary = G
|
||||
Just PublicGroupData {publicMemberCount} | countChanged ->
|
||||
setPublicMemberCount db cxt user g publicMemberCount
|
||||
_ -> pure g
|
||||
pure (g', profileChanged)
|
||||
-- the group's own link is authoritative for its domain claim, so a claim in the link profile is
|
||||
-- verified; updateGroupProfile above clears verification on a claim change, so set it afterwards
|
||||
g'' <- if verifyChanged then liftIO $ setGroupDomainVerified db user g' True else pure g'
|
||||
pure (g'', profileChanged)
|
||||
| otherwise = pure (gInfo, False)
|
||||
where
|
||||
profileChanged = p /= groupProfile
|
||||
countChanged = case publicGroupData of
|
||||
Just PublicGroupData {publicMemberCount} -> Just publicMemberCount /= localCount
|
||||
_ -> False
|
||||
groupClaim GroupProfile {publicGroup} = claimDomain <$> (publicGroup >>= publicGroupAccess >>= groupDomainClaim)
|
||||
newClaim = groupClaim groupProfile
|
||||
verifyChanged = isJust newClaim && (groupDomainVerified /= Just True || groupClaim p /= newClaim)
|
||||
|
||||
updateContactFromLinkData :: User -> Contact -> Profile -> CM Contact
|
||||
updateContactFromLinkData user ct@Contact {profile = profile@LocalProfile {contactDomain = prevClaim, contactDomainVerified}} linkProfile@Profile {contactDomain = newClaim}
|
||||
@@ -2770,18 +2786,24 @@ msgContentHasLink mc ft_ = case msgContentTag mc of
|
||||
MCLink_ -> True
|
||||
_ -> maybe False hasLinks ft_
|
||||
|
||||
createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId)
|
||||
createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do
|
||||
prepareAgentCreation :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> CM (CommandId, ConnId)
|
||||
prepareAgentCreation user cmdFunction enableNtfs cMode = do
|
||||
cmdId <- withStore' $ \db -> createCommand db user Nothing cmdFunction
|
||||
connId <- withAgent $ \a -> createConnectionAsync a (aUserId user) (aCorrId cmdId) enableNtfs cMode IKPQOff subMode
|
||||
connId <- withAgent $ \a -> prepareConnectionToCreate a (aUserId user) enableNtfs cMode PQSupportOff
|
||||
pure (cmdId, connId)
|
||||
|
||||
joinAgentConnectionAsync :: User -> Maybe Connection -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM (CommandId, ConnId)
|
||||
joinAgentConnectionAsync user conn_ enableNtfs cReqUri cInfo subMode = do
|
||||
prepareAgentJoin :: User -> Maybe Connection -> Bool -> ConnectionRequestUri c -> CM (CommandId, ConnId)
|
||||
prepareAgentJoin user conn_ enableNtfs cReqUri = do
|
||||
cmdId <- withStore' $ \db -> createCommand db user (dbConnId <$> conn_) CFJoinConn
|
||||
connId <- withAgent $ \a -> joinConnectionAsync a (aUserId user) (aCorrId cmdId) (aConnId <$> conn_) enableNtfs cReqUri cInfo PQSupportOff subMode
|
||||
connId <- case conn_ of
|
||||
Just conn -> pure $ aConnId conn
|
||||
Nothing -> withAgent $ \a -> prepareConnectionToJoin a (aUserId user) enableNtfs cReqUri PQSupportOff
|
||||
pure (cmdId, connId)
|
||||
|
||||
joinAgentConnectionAsync :: ConnectionModeI c => CommandId -> Bool -> ConnId -> Bool -> ConnectionRequestUri c -> ConnInfo -> SubscriptionMode -> CM ()
|
||||
joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode =
|
||||
withAgent $ \a -> joinConnectionAsync a (aCorrId cmdId) updateConn connId enableNtfs cReqUri cInfo PQSupportOff subMode
|
||||
|
||||
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> CM ()
|
||||
allowAgentConnectionAsync user conn@Connection {connId, pqSupport, connChatVersion} confId msg = do
|
||||
cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFAllowConn
|
||||
@@ -2789,13 +2811,17 @@ allowAgentConnectionAsync user conn@Connection {connId, pqSupport, connChatVersi
|
||||
withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId dm
|
||||
withStore' $ \db -> updateConnectionStatus db conn ConnAccepted
|
||||
|
||||
agentAcceptContactAsync :: MsgEncodingI e => User -> Bool -> InvitationId -> ChatMsgEvent e -> SubscriptionMode -> PQSupport -> VersionChat -> CM (CommandId, ConnId)
|
||||
agentAcceptContactAsync user enableNtfs invId msg subMode pqSup chatV = do
|
||||
prepareAgentAccept :: User -> Bool -> InvitationId -> PQSupport -> CM (CommandId, ConnId)
|
||||
prepareAgentAccept user enableNtfs invId pqSup = do
|
||||
cmdId <- withStore' $ \db -> createCommand db user Nothing CFAcceptContact
|
||||
dm <- encodeConnInfoPQ pqSup chatV msg
|
||||
connId <- withAgent $ \a -> acceptContactAsync a (aUserId user) (aCorrId cmdId) enableNtfs invId dm pqSup subMode
|
||||
connId <- withAgent $ \a -> prepareConnectionToAccept a (aUserId user) enableNtfs invId pqSup
|
||||
pure (cmdId, connId)
|
||||
|
||||
agentAcceptContactAsync :: MsgEncodingI e => CommandId -> ConnId -> Bool -> InvitationId -> ChatMsgEvent e -> PQSupport -> VersionChat -> SubscriptionMode -> CM ()
|
||||
agentAcceptContactAsync cmdId connId enableNtfs invId msg pqSup chatV subMode = do
|
||||
dm <- encodeConnInfoPQ pqSup chatV msg
|
||||
withAgent $ \a -> acceptContactAsync a (aCorrId cmdId) connId enableNtfs invId dm pqSup subMode
|
||||
|
||||
deleteAgentConnectionAsync :: ConnId -> CM ()
|
||||
deleteAgentConnectionAsync acId = deleteAgentConnectionAsync' acId False
|
||||
{-# INLINE deleteAgentConnectionAsync #-}
|
||||
|
||||
@@ -639,9 +639,10 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
forM_ gli_ $ \GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
|
||||
groupInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
|
||||
groupConnIds@(cmdId, connId) <- prepareAgentCreation user CFCreateConnGrpInv True SCMInvitation
|
||||
gVar <- asks random
|
||||
withStore $ \db -> createNewContactMemberAsync db gVar user groupInfo ct' gLinkMemRole groupConnIds connChatVersion peerChatVRange subMode
|
||||
withAgent $ \a -> createConnectionAsync a (aCorrId cmdId) connId True SCMInvitation CR.IKPQOff subMode
|
||||
-- TODO REMOVE LEGACY ^^^
|
||||
SENT msgId proxy -> do
|
||||
void $ continueSending connEntity conn
|
||||
@@ -1242,7 +1243,8 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo incognitoProfile
|
||||
dm <- encodeXMemberConnInfo gInfo relayMemberId profileToSend
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
void $ joinAgentConnectionAsync user (Just conn) True cReq dm subMode
|
||||
(cmdId, connId') <- prepareAgentJoin user (Just conn) True cReq
|
||||
joinAgentConnectionAsync cmdId True connId' True cReq dm subMode
|
||||
CFGetRelayDataAccept -> do
|
||||
let GroupMember {memberId = MemberId expectedMemberId} = m
|
||||
if linkEntityId == Just expectedMemberId
|
||||
@@ -1639,12 +1641,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
let sig = C.signatureBytes $ C.sign' privKey challenge
|
||||
msg = XGrpRelayTest challenge (Just sig)
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
chatVR <- chatVersionRange
|
||||
let chatV = chatVR `peerConnChatVersion` chatVRange
|
||||
(cmdId, acId) <- agentAcceptContactAsync user True invId msg subMode PQSupportOff chatV
|
||||
let chatV = vr cxt `peerConnChatVersion` chatVRange
|
||||
(cmdId, acId) <- prepareAgentAccept user True invId PQSupportOff
|
||||
withStore $ \db -> do
|
||||
Connection {connId = testCId} <- createRelayTestConnection db cxt user acId ConnAccepted chatV subMode
|
||||
liftIO $ setCommandConnId db user cmdId testCId
|
||||
agentAcceptContactAsync cmdId acId True invId msg PQSupportOff chatV subMode
|
||||
| otherwise = messageError "relay test sent to non-relay link"
|
||||
where
|
||||
User {userChatRelay} = user
|
||||
@@ -2634,12 +2636,13 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
then do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- encodeConnInfo $ XGrpAcpt membershipMemId
|
||||
connIds <- joinAgentConnectionAsync user Nothing True connRequest dm subMode
|
||||
connIds@(cmdId, acId) <- prepareAgentJoin user Nothing True connRequest
|
||||
withStore' $ \db -> do
|
||||
setViaGroupLinkUri db groupId connId
|
||||
createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode
|
||||
updateGroupMemberStatusById db userId hostId GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
joinAgentConnectionAsync cmdId False acId True connRequest dm subMode
|
||||
toView $ CEvtUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
|
||||
else do
|
||||
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
@@ -3200,16 +3203,14 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
Just (ChatVersionRange mcvr)
|
||||
| maxVersion mcvr >= groupDirectInvVersion -> do
|
||||
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
|
||||
groupConnIds@(cmdId, connId) <- prepareAgentCreation user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation
|
||||
let chatV = maybe (minVersion (vr cxt)) (\peerVR -> vr cxt `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
|
||||
void $ withStore $ \db -> do
|
||||
reMember <- createIntroReMember db cxt user gInfo memInfo memRestrictions
|
||||
createIntroReMemberConn db user m reMember chatV memInfo groupConnIds subMode
|
||||
withAgent $ \a -> createConnectionAsync a (aCorrId cmdId) connId (chatHasNtfs chatSettings) SCMInvitation CR.IKPQOff subMode
|
||||
| otherwise -> messageError "x.grp.mem.intro: member chat version range incompatible"
|
||||
_ -> messageError "x.grp.mem.intro can be only sent by host member"
|
||||
where
|
||||
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode
|
||||
|
||||
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM ()
|
||||
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
|
||||
@@ -3252,12 +3253,16 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
|
||||
dm <- encodeConnInfo $ XGrpMemInfo membershipMemId membershipProfile
|
||||
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
|
||||
groupConnIds <- joinAgentConnectionAsync user Nothing (chatHasNtfs chatSettings) groupConnReq dm subMode
|
||||
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user Nothing True dcr dm subMode
|
||||
let enableNtfsGrp = chatHasNtfs chatSettings
|
||||
groupConnIds@(gCmdId, gAcId) <- prepareAgentJoin user Nothing enableNtfsGrp groupConnReq
|
||||
directConnIds <- mapM (prepareAgentJoin user Nothing True) directConnReq
|
||||
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
|
||||
mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
|
||||
chatV = vr cxt `peerConnChatVersion` mcvr
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode
|
||||
joinAgentConnectionAsync gCmdId False gAcId enableNtfsGrp groupConnReq dm subMode
|
||||
forM_ ((,) <$> directConnIds <*> directConnReq) $ \((dCmdId, dAcId), dcr) ->
|
||||
joinAgentConnectionAsync dCmdId False dAcId True dcr dm subMode
|
||||
|
||||
-- rollback defense (channels): apply an owner-signed role/removal only at a version >= the persisted
|
||||
-- roster_version (not the batch-constant gInfo, which a relay can stale by reordering events in one
|
||||
@@ -3777,11 +3782,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
}
|
||||
joinExistingContact subMode mCt@Contact {contactId = mContactId}
|
||||
| autoAcceptMemberContacts user = do
|
||||
(cmdId, acId) <- joinConn subMode
|
||||
(cmdId, acId) <- prepareAgentJoin user Nothing True connReq
|
||||
mCt' <- withStore $ \db -> do
|
||||
updateMemberContactInvited db user mCt groupDirectInv
|
||||
void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode
|
||||
getContact db cxt user mContactId
|
||||
joinMemberContactAsync cmdId acId subMode
|
||||
securityCodeChanged mCt'
|
||||
createItems mCt' m
|
||||
| otherwise = do
|
||||
@@ -3795,13 +3801,14 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
createItems mCt' m
|
||||
createNewContact subMode
|
||||
| autoAcceptMemberContacts user = do
|
||||
(cmdId, acId) <- joinConn subMode
|
||||
(cmdId, acId) <- prepareAgentJoin user Nothing True connReq
|
||||
-- [incognito] reuse membership incognito profile
|
||||
(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 cxt user mContactId
|
||||
pure (mCt, m')
|
||||
joinMemberContactAsync cmdId acId subMode
|
||||
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
|
||||
createItems mCt m'
|
||||
| otherwise = do
|
||||
@@ -3814,12 +3821,12 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart)
|
||||
createInternalChatItem user (CDDirectRcv mCt) (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing
|
||||
createItems mCt m'
|
||||
joinConn subMode = do
|
||||
joinMemberContactAsync cmdId acId subMode = do
|
||||
-- [incognito] send membership incognito profile
|
||||
p <- presentUserBadge user (incognitoMembershipProfile g) $ userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True
|
||||
-- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ)
|
||||
dm <- encodeConnInfo $ XInfo p
|
||||
joinAgentConnectionAsync user Nothing True connReq dm subMode
|
||||
joinAgentConnectionAsync cmdId False acId True connReq dm subMode
|
||||
createItems mCt' m' = do
|
||||
(g', m'', scopeInfo) <- mkGroupChatScope g m'
|
||||
createInternalChatItem user (CDGroupRcv g' scopeInfo m'') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing
|
||||
|
||||
@@ -238,7 +238,7 @@ import Simplex.Chat.Types.MemberRelations (IntroductionDirection (..), MemberRel
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.UITheme
|
||||
import Simplex.Messaging.Agent.Protocol (ConfirmationId, ConnId, CreatedConnLink (..), InvitationId, OwnerAuth (..), SimplexNameInfo (..), UserId)
|
||||
import Simplex.Messaging.Agent.Protocol (ConfirmationId, ConnId, CreatedConnLink (..), InvitationId, OwnerAuth (..), SimplexNameInfo (..), SimplexNameType (..), UserId)
|
||||
import Simplex.Messaging.Agent.Store.AgentStore (firstRow, fromOnlyBI, maybeFirstRow)
|
||||
import qualified Simplex.FileTransfer.Description as FD
|
||||
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
|
||||
@@ -1083,9 +1083,14 @@ getGroupToConnect :: DB.Connection -> StoreCxt -> User -> ContactNameOrLink -> E
|
||||
getGroupToConnect db cxt user@User {userId} = \case
|
||||
CTLink sl -> first (`CCLink` Just sl) <$$> getGroupViaShortLinkToConnect db cxt user sl
|
||||
CTName ni ->
|
||||
liftIO (maybeFirstRow id $ DB.query db byNameQuery (userId, nameDomain ni)) >>= \case
|
||||
Just (gId :: Int64, Just cReq, Just (sLnk :: ShortLinkContact)) -> Just . (CCLink cReq (Just sLnk),) <$> getGroupInfo db cxt user gId
|
||||
_ -> pure Nothing
|
||||
-- @name is a business (presents as a contact); #name is a channel. The same domain can have both,
|
||||
-- so the group type must match the requested name type.
|
||||
let businessCond = case nameType ni of
|
||||
NTContact -> " AND g.business_chat IS NOT NULL"
|
||||
NTPublicGroup -> " AND g.business_chat IS NULL"
|
||||
in liftIO (maybeFirstRow id $ DB.query db (byNameQuery <> businessCond) (userId, nameDomain ni)) >>= \case
|
||||
Just (gId :: Int64, Just cReq, Just (sLnk :: ShortLinkContact)) -> Just . (CCLink cReq (Just sLnk),) <$> getGroupInfo db cxt user gId
|
||||
_ -> pure Nothing
|
||||
where
|
||||
byNameQuery =
|
||||
[sql|
|
||||
|
||||
@@ -60,7 +60,7 @@ import Simplex.Chat.Types.Shared
|
||||
import Simplex.Chat.Types.UITheme
|
||||
import Simplex.FileTransfer.Description (FileDigest)
|
||||
import Simplex.FileTransfer.Types (RcvFileId, SndFileId)
|
||||
import Simplex.Messaging.Agent.Protocol (ACorrId, ACreatedConnLink, AConnectionLink (..), AEventTag (..), AEvtTag (..), ConnId, ConnShortLink (..), ConnectionLink (..), ConnectionMode (..), ConnectionModeI, ConnectionRequestUri, ContactConnType (..), CreatedConnLink (..), InvitationId, SAEntity (..), SConnectionMode (..), SimplexNameInfo, UserId)
|
||||
import Simplex.Messaging.Agent.Protocol (ACorrId, ACreatedConnLink, AConnectionLink (..), AEventTag (..), AEvtTag (..), ConnId, ConnShortLink (..), ConnectionLink (..), ConnectionMode (..), ConnectionModeI, ConnectionRequestUri, ContactConnType (..), CreatedConnLink (..), InvitationId, SAEntity (..), SConnectionMode (..), SimplexDomain, SimplexNameInfo (..), UserId)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), blobFieldDecoder, fromTextField_)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
|
||||
@@ -1789,6 +1789,7 @@ type ConnReqContact = ConnectionRequestUri 'CMContact
|
||||
data ConnectTarget (m :: ConnectionMode) where
|
||||
CTFullContact :: ConnectionRequestUri 'CMContact -> ConnectTarget 'CMContact
|
||||
CTShortContact :: ContactNameOrLink -> ConnectTarget 'CMContact
|
||||
CTDomain :: SimplexDomain -> ConnectTarget 'CMContact
|
||||
CTInv :: ConnectionLink 'CMInvitation -> ConnectTarget 'CMInvitation
|
||||
|
||||
data ContactNameOrLink = CTName SimplexNameInfo | CTLink (ConnShortLink 'CMContact)
|
||||
@@ -1813,10 +1814,12 @@ instance StrEncoding AConnectTarget where
|
||||
CTFullContact cr -> strEncode cr
|
||||
CTShortContact (CTName n) -> strEncode n
|
||||
CTShortContact (CTLink sl) -> strEncode sl
|
||||
CTDomain d -> strEncode d
|
||||
CTInv l -> strEncode l
|
||||
strP =
|
||||
(ACTarget SCMContact . CTShortContact . CTName <$> (lookAhead nameStart *> strP))
|
||||
<|> (aConnectTarget <$> strP)
|
||||
<|> (ACTarget SCMContact . CTDomain <$> strP)
|
||||
where
|
||||
nameStart = "@" <|> "#" <|> "simplex:/name"
|
||||
|
||||
|
||||
@@ -204,7 +204,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
|
||||
CRInvitation u ccLink _ -> ttyUser u $ viewConnReqInvitation ccLink
|
||||
CRConnectionIncognitoUpdated u c customUserProfile -> ttyUser u $ viewConnectionIncognitoUpdated c customUserProfile testView
|
||||
CRConnectionUserChanged u c c' nu -> ttyUser u $ viewConnectionUserChanged u c nu c'
|
||||
CRConnectionPlan u connLink connectionPlan -> ttyUser u $ viewConnectionPlan cfg connLink connectionPlan
|
||||
CRConnectionPlan u connLink _ otherSimplexName connectionPlan -> ttyUser u $ viewConnectionPlan cfg connLink connectionPlan <> otherSimplexNameNote otherSimplexName
|
||||
CRNewPreparedChat u (AChat _ (Chat cInfo _ _)) -> ttyUser u $ case cInfo of
|
||||
DirectChat ct -> [ttyContact' ct <> ": contact is prepared"]
|
||||
GroupChat g _ -> [ttyGroup' g <> ": group is prepared"]
|
||||
@@ -2144,6 +2144,12 @@ viewGroupUserChanged
|
||||
where
|
||||
userChangedStr = "group " <> ttyGroup' g <> " changed from user " <> plain un <> " to user " <> plain un'
|
||||
|
||||
otherSimplexNameNote :: Maybe SimplexNameInfo -> [StyledString]
|
||||
otherSimplexNameNote = \case
|
||||
Just ni@(SimplexNameInfo NTPublicGroup _) -> [plain $ "You can also join channel " <> shortNameInfoStr ni]
|
||||
Just ni@(SimplexNameInfo NTContact _) -> [plain $ "You can also connect to " <> shortNameInfoStr ni <> " in direct chat"]
|
||||
Nothing -> []
|
||||
|
||||
viewConnectionPlan :: ChatConfig -> ACreatedConnLink -> ConnectionPlan -> [StyledString]
|
||||
viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
|
||||
CPInvitationLink ilp -> case ilp of
|
||||
@@ -2165,7 +2171,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
|
||||
| business -> ("business address: " <>)
|
||||
_ -> ("invitation link: " <>)
|
||||
CPContactAddress cap -> case cap of
|
||||
CAPOk contactSLinkData ov _ -> [addrOrBiz contactSLinkData "ok to connect"] <> viewSigVerification ov <> [viewJSON contactSLinkData | testView]
|
||||
CAPOk contactSLinkData ov -> [addrOrBiz contactSLinkData "ok to connect"] <> viewSigVerification ov <> [viewJSON contactSLinkData | testView]
|
||||
CAPOwnLink -> [ctAddr "own address"]
|
||||
CAPConnectingConfirmReconnect -> [ctAddr "connecting, allowed to reconnect"]
|
||||
CAPConnectingProhibit ct -> [ctAddr ("connecting to contact " <> ttyContact' ct)]
|
||||
@@ -2183,7 +2189,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
|
||||
| business -> ("business address: " <>)
|
||||
_ -> ("contact address: " <>)
|
||||
CPGroupLink glp -> case glp of
|
||||
GLPOk groupSLinkInfo_ groupSLinkData ov _ ->
|
||||
GLPOk groupSLinkInfo_ groupSLinkData ov ->
|
||||
let direct = maybe True (\(GroupShortLinkInfo {direct = d}) -> d) groupSLinkInfo_
|
||||
in [grpLink $ if direct then "ok to connect directly" else "ok to connect via relays"]
|
||||
<> viewSigVerification ov
|
||||
@@ -2687,6 +2693,7 @@ viewChatError isCmd logLevel testView = \case
|
||||
SDENoValidLink -> "has no valid connection link"
|
||||
SDEUnknownDomain -> "is not included in the connection link's profile"
|
||||
in [plain $ "SimpleX name " <> strEncode domain <> " " <> reason]
|
||||
CENotResolvedLocally -> ["no matching chat found, name resolution is disabled"]
|
||||
CEUnsupportedConnReq -> [ "", "Connection link is not supported by the your app version, please ugrade it.", plain updateStr]
|
||||
CEInvalidChatMessage Connection {connId} msgMeta_ msg e ->
|
||||
[ plain $
|
||||
|
||||
Reference in New Issue
Block a user