mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-06-04 10:21:50 +00:00
Merge branch 'master' into f/channel-comments
This commit is contained in:
spaced4ndy
@@ -73,6 +73,7 @@ import Simplex.Messaging.Agent (AgentClient, DatabaseDiff, SubscriptionsInfo)
|
||||
import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg, Worker)
|
||||
import Simplex.Messaging.Agent.Lock
|
||||
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..))
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction, withTransactionPriority)
|
||||
import Simplex.Messaging.Agent.Store.Shared (MigrationConfirmation, UpMigration)
|
||||
@@ -158,6 +159,10 @@ data ChatConfig = ChatConfig
|
||||
deliveryWorkerDelay :: Int64, -- microseconds
|
||||
deliveryBucketSize :: Int,
|
||||
channelSubscriberRole :: GroupMemberRole, -- TODO [relays] starting role should be communicated in protocol from owner to relays
|
||||
relayChecksInterval :: NominalDiffTime,
|
||||
relayInactiveTTL :: NominalDiffTime,
|
||||
relayRequestRetryInterval :: RetryInterval,
|
||||
relayRequestExpiry :: (Int, NominalDiffTime),
|
||||
highlyAvailable :: Bool,
|
||||
deviceNameForRemote :: Text,
|
||||
remoteCompression :: Bool,
|
||||
@@ -343,6 +348,7 @@ data ChatCommand
|
||||
| APIGetReactionMembers {userId :: UserId, groupId :: GroupId, chatItemId :: ChatItemId, reaction :: MsgReaction}
|
||||
| APIPlanForwardChatItems {fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId}
|
||||
| APIForwardChatItems {toChatRef :: ChatRef, sendAsGroup :: ShowGroupAsSender, fromChatRef :: ChatRef, chatItemIds :: NonEmpty ChatItemId, ttl :: Maybe Int}
|
||||
| APIShareChatMsgContent {shareChatRef :: ChatRef, toSendRef :: SendRef}
|
||||
| APIUserRead UserId
|
||||
| UserRead
|
||||
| APIChatRead {chatRef :: ChatRef}
|
||||
@@ -471,13 +477,13 @@ data ChatCommand
|
||||
| AddContact IncognitoEnabled
|
||||
| APISetConnectionIncognito Int64 IncognitoEnabled
|
||||
| APIChangeConnectionUser Int64 UserId -- new user id to switch connection to
|
||||
| APIConnectPlan {userId :: UserId, connectionLink :: Maybe AConnectionLink} -- Maybe is used to report link parsing failure as special error
|
||||
| APIConnectPlan {userId :: UserId, connectionLink :: Maybe AConnectionLink, resolveKnown :: Bool, linkOwnerSig :: Maybe LinkOwnerSig} -- Maybe AConnectionLink is used to report link parsing failure as special error
|
||||
| APIPrepareContact UserId ACreatedConnLink ContactShortLinkData
|
||||
| APIPrepareGroup UserId CreatedLinkContact DirectLink GroupShortLinkData
|
||||
| APIChangePreparedContactUser ContactId UserId
|
||||
| APIChangePreparedGroupUser GroupId UserId
|
||||
| APIConnectPreparedContact {contactId :: ContactId, incognito :: IncognitoEnabled, msgContent_ :: Maybe MsgContent}
|
||||
| APIConnectPreparedGroup GroupId IncognitoEnabled (Maybe MsgContent)
|
||||
| APIConnectPreparedGroup {groupId :: GroupId, incognito :: IncognitoEnabled, ownerContact :: Maybe GroupOwnerContact, msgContent_ :: Maybe MsgContent}
|
||||
| APIConnect {userId :: UserId, incognito :: IncognitoEnabled, preparedLink_ :: Maybe ACreatedConnLink} -- Maybe is used to report link parsing failure as special error
|
||||
| Connect {incognito :: IncognitoEnabled, connLink_ :: Maybe AConnectionLink}
|
||||
| APIConnectContactViaAddress UserId IncognitoEnabled ContactId
|
||||
@@ -502,6 +508,7 @@ data ChatCommand
|
||||
| ForwardMessage {toChatName :: ChatName, fromContactName :: ContactName, forwardedMsg :: Text}
|
||||
| ForwardGroupMessage {toChatName :: ChatName, fromGroupName :: GroupName, fromMemberName_ :: Maybe ContactName, forwardedMsg :: Text}
|
||||
| ForwardLocalMessage {toChatName :: ChatName, forwardedMsg :: Text}
|
||||
| SharePublicGroup {shareGroupName :: GroupName, toChatName :: ChatName}
|
||||
| SendMessage SendName Text
|
||||
| SendMemberContactMessage GroupName ContactName Text
|
||||
| AcceptMemberContact ContactName
|
||||
@@ -518,6 +525,7 @@ data ChatCommand
|
||||
-- TODO [relays] starting role should be communicated in protocol from owner to relays (see channelSubscriberRole config)
|
||||
| APINewPublicGroup {userId :: UserId, incognito :: IncognitoEnabled, relayIds :: NonEmpty Int64, groupProfile :: GroupProfile}
|
||||
| APIGetGroupRelays {groupId :: GroupId}
|
||||
| APIAddGroupRelays {groupId :: GroupId, relayIds :: NonEmpty Int64}
|
||||
| NewPublicGroup IncognitoEnabled (NonEmpty Int64) GroupProfile
|
||||
| AddMember GroupName ContactName GroupMemberRole
|
||||
| JoinGroup {groupName :: GroupName, enableNtfs :: MsgFilter}
|
||||
@@ -651,6 +659,12 @@ data RelayConnectionResult = RelayConnectionResult
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data AddRelayResult = AddRelayResult
|
||||
{ relay :: UserChatRelay,
|
||||
relayError :: Maybe ChatError
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data RelayTestStep
|
||||
= RTSGetLink
|
||||
| RTSDecodeLink
|
||||
@@ -721,7 +735,10 @@ data ChatResponse
|
||||
| CRWelcome {user :: User}
|
||||
| CRGroupCreated {user :: User, groupInfo :: GroupInfo}
|
||||
| CRPublicGroupCreated {user :: User, groupInfo :: GroupInfo, groupLink :: GroupLink, groupRelays :: [GroupRelay]}
|
||||
| CRPublicGroupCreationFailed {user :: User, addRelayResults :: [AddRelayResult]}
|
||||
| CRGroupRelays {user :: User, groupInfo :: GroupInfo, groupRelays :: [GroupRelay]}
|
||||
| CRGroupRelaysAdded {user :: User, groupInfo :: GroupInfo, groupLink :: GroupLink, groupRelays :: [GroupRelay]}
|
||||
| CRGroupRelaysAddFailed {user :: User, addRelayResults :: [AddRelayResult]}
|
||||
| CRGroupMembers {user :: User, group :: Group}
|
||||
| CRMemberSupportChats {user :: User, groupInfo :: GroupInfo, members :: [GroupMember]}
|
||||
-- | CRGroupConversationsArchived {user :: User, groupInfo :: GroupInfo, archivedGroupConversations :: [GroupConversation]}
|
||||
@@ -762,6 +779,7 @@ data ChatResponse
|
||||
| CRLeftMemberUser {user :: User, groupInfo :: GroupInfo}
|
||||
| CRGroupDeletedUser {user :: User, groupInfo :: GroupInfo, msgSigned :: Bool}
|
||||
| CRForwardPlan {user :: User, itemsCount :: Int, chatItemIds :: [ChatItemId], forwardConfirmation :: Maybe ForwardConfirmation}
|
||||
| CRChatMsgContent {user :: User, msgContent :: MsgContent}
|
||||
| CRRcvFileAccepted {user :: User, chatItem :: AChatItem}
|
||||
-- TODO add chatItem :: AChatItem
|
||||
| CRRcvFileAcceptedSndCancelled {user :: User, rcvFileTransfer :: RcvFileTransfer}
|
||||
@@ -982,7 +1000,7 @@ data ChatPagination
|
||||
deriving (Show)
|
||||
|
||||
data PaginationByTime
|
||||
= PTLast Int
|
||||
= PTLast {count :: Int}
|
||||
| PTAfter UTCTime Int
|
||||
| PTBefore UTCTime Int
|
||||
deriving (Show)
|
||||
@@ -1009,14 +1027,14 @@ data ConnectionPlan
|
||||
deriving (Show)
|
||||
|
||||
data InvitationLinkPlan
|
||||
= ILPOk {contactSLinkData_ :: Maybe ContactShortLinkData}
|
||||
= ILPOk {contactSLinkData_ :: Maybe ContactShortLinkData, ownerVerification :: Maybe OwnerVerification}
|
||||
| ILPOwnLink
|
||||
| ILPConnecting {contact_ :: Maybe Contact}
|
||||
| ILPKnown {contact :: Contact}
|
||||
deriving (Show)
|
||||
|
||||
data ContactAddressPlan
|
||||
= CAPOk {contactSLinkData_ :: Maybe ContactShortLinkData}
|
||||
= CAPOk {contactSLinkData_ :: Maybe ContactShortLinkData, ownerVerification :: Maybe OwnerVerification}
|
||||
| CAPOwnLink
|
||||
| CAPConnectingConfirmReconnect
|
||||
| CAPConnectingProhibit {contact :: Contact}
|
||||
@@ -1025,11 +1043,29 @@ data ContactAddressPlan
|
||||
deriving (Show)
|
||||
|
||||
data GroupLinkPlan
|
||||
= GLPOk {groupSLinkInfo_ :: Maybe GroupShortLinkInfo, groupSLinkData_ :: Maybe GroupShortLinkData}
|
||||
= GLPOk {groupSLinkInfo_ :: Maybe GroupShortLinkInfo, groupSLinkData_ :: Maybe GroupShortLinkData, ownerVerification :: Maybe OwnerVerification}
|
||||
| GLPOwnLink {groupInfo :: GroupInfo}
|
||||
| GLPConnectingConfirmReconnect
|
||||
| GLPConnectingProhibit {groupInfo_ :: Maybe GroupInfo}
|
||||
| GLPKnown {groupInfo :: GroupInfo}
|
||||
| GLPKnown {groupInfo :: GroupInfo, groupUpdated :: BoolDef, ownerVerification :: Maybe OwnerVerification, linkOwners :: ListDef GroupLinkOwner}
|
||||
| GLPNoRelays {groupSLinkData_ :: Maybe GroupShortLinkData}
|
||||
deriving (Show)
|
||||
|
||||
data GroupLinkOwner = GroupLinkOwner
|
||||
{ memberId :: MemberId,
|
||||
memberKey :: C.PublicKeyEd25519
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data OwnerVerification
|
||||
= OVVerified
|
||||
| OVFailed {reason :: Text}
|
||||
deriving (Show)
|
||||
|
||||
data GroupOwnerContact = GroupOwnerContact
|
||||
{ contactId :: ContactId,
|
||||
memberId :: MemberId
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type DirectLink = Bool
|
||||
@@ -1044,11 +1080,11 @@ data GroupShortLinkInfo = GroupShortLinkInfo
|
||||
connectionPlanProceed :: ConnectionPlan -> Bool
|
||||
connectionPlanProceed = \case
|
||||
CPInvitationLink ilp -> case ilp of
|
||||
ILPOk _ -> True
|
||||
ILPOk {} -> True
|
||||
ILPOwnLink -> True
|
||||
_ -> False
|
||||
CPContactAddress cap -> case cap of
|
||||
CAPOk _ -> True
|
||||
CAPOk {} -> True
|
||||
CAPOwnLink -> True
|
||||
CAPConnectingConfirmReconnect -> True
|
||||
CAPContactViaAddress _ -> True
|
||||
@@ -1057,6 +1093,7 @@ connectionPlanProceed = \case
|
||||
GLPOk {} -> True
|
||||
GLPOwnLink _ -> True
|
||||
GLPConnectingConfirmReconnect -> True
|
||||
GLPNoRelays _ -> False
|
||||
_ -> False
|
||||
CPError _ -> True
|
||||
|
||||
@@ -1633,12 +1670,16 @@ $(JQ.deriveJSON (enumJSON $ dropPrefix "HS") ''HelpSection)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CLQ") ''ChatListQuery)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "OV") ''OwnerVerification)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "ILP") ''InvitationLinkPlan)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CAP") ''ContactAddressPlan)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''GroupShortLinkInfo)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''GroupLinkOwner)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GLP") ''GroupLinkPlan)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "FC") ''ForwardConfirmation)
|
||||
@@ -1703,6 +1744,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "TE") ''TerminalEvent)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''RelayConnectionResult)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''AddRelayResult)
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "RTS") ''RelayTestStep)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''RelayTestFailure)
|
||||
|
||||
@@ -37,6 +37,7 @@ import Data.Constraint (Dict (..))
|
||||
import Data.Either (fromRight, partitionEithers, rights)
|
||||
import Data.Foldable (foldr')
|
||||
import Data.Functor (($>))
|
||||
import Data.Functor.Identity (Identity (..), runIdentity)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (dropWhileEnd, find, foldl', isSuffixOf, partition, sortOn, zipWith4)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
@@ -56,9 +57,11 @@ import qualified Data.UUID.V4 as V4
|
||||
import Simplex.Chat.Library.Subscriber
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Delivery (DeliveryJobScope (..), DeliveryJobSpec (..), DeliveryWorkerScope (..))
|
||||
import Simplex.Chat.Files
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.Batch (encodeBatchElement)
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Messages.CIContent.Events
|
||||
import Simplex.Chat.Operators
|
||||
@@ -101,6 +104,7 @@ import qualified Simplex.Messaging.Crypto.ShortLink as SL
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern IKPQOff, pattern IKPQOn, pattern PQEncOff, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (base64P)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth (..), AProtocolType (..), MsgFlags (..), NtfServer, ProtoServerWithAuth (..), ProtocolServer, ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, userProtocol)
|
||||
@@ -621,7 +625,10 @@ processChatCommand vr nm = \case
|
||||
mapM_ assertNoMentions cms
|
||||
withContactLock "sendMessage" chatId $
|
||||
sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
|
||||
SRGroup chatId gsScope asGroup ->
|
||||
SRGroup chatId gsScope asGroup -> do
|
||||
case gsScope of
|
||||
Just (GCSMemberSupport _) -> when asGroup $ throwCmdError "cannot send as group in support scope"
|
||||
Nothing -> pure ()
|
||||
withGroupLock "sendMessage" chatId $ do
|
||||
(gInfo, cmrs) <- withFastStore $ \db -> do
|
||||
g <- getGroupInfo db vr user chatId
|
||||
@@ -723,7 +730,7 @@ processChatCommand vr nm = \case
|
||||
gInfo@GroupInfo {groupId, membership} <- withFastStore $ \db -> getGroupInfo db vr user chatId
|
||||
when (isNothing scope) $ assertUserGroupRole gInfo GRAuthor
|
||||
let (_, ft_) = msgContentTexts mc
|
||||
if prohibitedSimplexLinks gInfo membership ft_
|
||||
if prohibitedSimplexLinks gInfo membership mc ft_
|
||||
then throwCmdError ("feature not allowed " <> T.unpack (groupFeatureNameText GFSimplexLinks))
|
||||
else do
|
||||
-- TODO [knocking] check chat item scope?
|
||||
@@ -1032,7 +1039,13 @@ processChatCommand vr nm = \case
|
||||
CTContactConnection -> throwCmdError "not supported"
|
||||
where
|
||||
prepareMsgReq :: CChatItem c -> CM (Maybe (MsgContent, Maybe CryptoFile))
|
||||
prepareMsgReq (CChatItem _ ci) = forwardMsgContent ci $>>= forwardContent ci
|
||||
prepareMsgReq (CChatItem md ci) = forwardMsgContent ci $>>= forwardContent ci . dropOwnerSig
|
||||
where
|
||||
dropOwnerSig = \case
|
||||
mc@MCChat {text, chatLink}
|
||||
| SMDSnd <- md, fromChat == toChat -> mc
|
||||
| otherwise -> MCChat {text, chatLink, ownerSig = Nothing}
|
||||
mc -> mc
|
||||
forwardCIFF :: ChatItem c d -> Maybe CIForwardedFrom -> Maybe CIForwardedFrom
|
||||
forwardCIFF ChatItem {meta = CIMeta {itemForwarded}} ciff = case itemForwarded of
|
||||
Nothing -> ciff
|
||||
@@ -1100,6 +1113,41 @@ processChatCommand vr nm = \case
|
||||
let formattedDate = formatTime defaultTimeLocale "%Y%m%d_%H%M%S" currentDate
|
||||
let ext = takeExtension fileName
|
||||
pure $ prefix <> formattedDate <> ext
|
||||
APIShareChatMsgContent (ChatRef CTGroup groupId _) toSendRef -> withUser $ \user -> do
|
||||
GroupInfo {groupProfile = gp@GroupProfile {publicGroup}, membership = GroupMember {memberId, memberRole}, groupKeys} <-
|
||||
withFastStore $ \db -> getGroupInfo db vr user groupId
|
||||
case publicGroup of
|
||||
Nothing -> throwCmdError "not a public group"
|
||||
Just PublicGroupProfile {groupLink} -> do
|
||||
let signingKeys = case (memberRole, groupKeys) of
|
||||
(GROwner, Just gk@GroupKeys {groupRootKey = GRKPrivate _}) -> Just gk
|
||||
_ -> Nothing
|
||||
ownerSig <-
|
||||
pure signingKeys $>>= \GroupKeys {memberPrivKey} ->
|
||||
mkLinkOwnerSig memberPrivKey groupLink memberId <$$> shareChatBinding user toSendRef
|
||||
let text = safeDecodeUtf8 $ strEncode groupLink
|
||||
pure $ CRChatMsgContent user MCChat {text, chatLink = MCLGroup groupLink gp, ownerSig}
|
||||
where
|
||||
mkLinkOwnerSig :: ConnectionModeI m => C.PrivateKeyEd25519 -> ConnShortLink m -> MemberId -> (ChatBinding, ByteString) -> LinkOwnerSig
|
||||
mkLinkOwnerSig privKey connLink MemberId {unMemberId} (cbTag, bindingData) =
|
||||
let ownerId = Just $ B64UrlByteString unMemberId
|
||||
cb = encodeChatBinding cbTag bindingData
|
||||
ownerSig = C.sign' privKey $ cb <> smpEncode connLink
|
||||
in LinkOwnerSig {ownerId, chatBinding = B64UrlByteString cb, ownerSig}
|
||||
shareChatBinding :: User -> SendRef -> CM (Maybe (ChatBinding, ByteString))
|
||||
shareChatBinding u = \case
|
||||
SRDirect contactId -> do
|
||||
ct <- withFastStore $ \db -> getContact db vr u contactId
|
||||
forM (contactConn ct) $ \conn ->
|
||||
(CBDirect,) <$> withAgent (`getConnectionRatchetAdHash` aConnId conn)
|
||||
SRGroup toGroupId _ asGroup -> do
|
||||
GroupInfo {groupProfile = GroupProfile {publicGroup}, membership = m} <- withFastStore $ \db -> getGroupInfo db vr u toGroupId
|
||||
pure $ mkBinding m <$> publicGroup
|
||||
where
|
||||
mkBinding GroupMember {memberId} PublicGroupProfile {publicGroupId = pgId}
|
||||
| asGroup = (CBChannel, smpEncode pgId)
|
||||
| otherwise = (CBGroup, smpEncode (pgId, memberId))
|
||||
APIShareChatMsgContent _ _ -> throwCmdError "sharing is only supported for public groups"
|
||||
APIUserRead userId -> withUserId userId $ \user -> withFastStore' (`setUserChatsRead` user) >> ok user
|
||||
UserRead -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUserRead userId
|
||||
APIChatRead chatRef@(ChatRef cType chatId scope_) -> withUser $ \_ -> case cType of
|
||||
@@ -1760,15 +1808,17 @@ processChatCommand vr nm = \case
|
||||
APIGroupInfo gId -> withUser $ \user ->
|
||||
CRGroupInfo user <$> withFastStore (\db -> getGroupInfo db vr user gId)
|
||||
APIGetUpdatedGroupLinkData groupId -> withUser $ \user -> do
|
||||
gInfo@GroupInfo {groupProfile = GroupProfile {publicGroup}} <- withFastStore $ \db -> getGroupInfo db vr user groupId
|
||||
case publicGroup of
|
||||
Just PublicGroupProfile {groupLink = sLnk} | useRelays' gInfo -> do
|
||||
(_, cData) <- getShortLinkConnReq nm user sLnk
|
||||
gInfo@GroupInfo {groupProfile = p, groupSummary = GroupSummary {publicMemberCount = localCount}} <- withFastStore $ \db -> getGroupInfo db vr user groupId
|
||||
case p of
|
||||
GroupProfile {publicGroup = Just PublicGroupProfile {groupLink = sLnk}} | useRelays' gInfo -> do
|
||||
(_, cData@(ContactLinkData _ UserContactData {relays = currentRelayLinks})) <- getShortLinkConnReq' nm user sLnk
|
||||
groupSLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
let publicGroupData_ = groupSLinkData_ >>= \GroupShortLinkData {publicGroupData} -> publicGroupData
|
||||
publicMemberCount_ = (\PublicGroupData {publicMemberCount} -> publicMemberCount) <$> publicGroupData_
|
||||
gInfo' <- fromMaybe gInfo
|
||||
<$> forM publicMemberCount_ (\count -> withFastStore $ \db -> setPublicMemberCount db vr user gInfo count)
|
||||
gInfo' <- case groupSLinkData_ of
|
||||
Just sLinkData -> fst <$> updateGroupFromLinkData user gInfo sLinkData
|
||||
_ -> pure gInfo
|
||||
when (memberRole' (membership gInfo) /= GROwner && memberCurrent (membership gInfo)) $
|
||||
withGroupLock "syncSubscriberRelays" groupId $
|
||||
syncSubscriberRelays user gInfo' currentRelayLinks
|
||||
pure $ CRGroupInfo user gInfo'
|
||||
_ -> throwCmdError "group link data not available"
|
||||
APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do
|
||||
@@ -1952,7 +2002,7 @@ processChatCommand vr nm = \case
|
||||
where
|
||||
recreateConn user conn@PendingContactConnection {customUserProfileId, connLinkInv} newUser = do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let short = isJust $ connShortLink =<< connLinkInv
|
||||
let short = isJust $ connShortLink' =<< connLinkInv
|
||||
userLinkData_
|
||||
| short = Just $ UserInvLinkData $ contactShortLinkData (userProfileDirect newUser Nothing Nothing True) Nothing
|
||||
| otherwise = Nothing
|
||||
@@ -1966,9 +2016,9 @@ processChatCommand vr nm = \case
|
||||
createDirectConnection db newUser agConnId ccLink' Nothing ConnNew Nothing subMode initialChatVersion PQSupportOn
|
||||
deleteAgentConnectionAsync (aConnId' conn)
|
||||
pure conn'
|
||||
APIConnectPlan userId (Just cLink) -> withUserId userId $ \user ->
|
||||
uncurry (CRConnectionPlan user) <$> connectPlan user cLink
|
||||
APIConnectPlan _ Nothing -> throwChatError CEInvalidConnReq
|
||||
APIConnectPlan userId (Just cLink) resolveKnown linkOwnerSig_ -> withUserId userId $ \user ->
|
||||
uncurry (CRConnectionPlan user) <$> connectPlan user cLink resolveKnown linkOwnerSig_
|
||||
APIConnectPlan _ Nothing _ _ -> throwChatError CEInvalidConnReq
|
||||
APIPrepareContact userId accLink contactSLinkData -> withUserId userId $ \user -> do
|
||||
let ContactShortLinkData {profile, message, business} = contactSLinkData
|
||||
welcomeSharedMsgId <- forM message $ \_ -> getSharedMsgId
|
||||
@@ -1997,7 +2047,7 @@ processChatCommand vr nm = \case
|
||||
let cd = CDDirectRcv ct
|
||||
createItem sharedMsgId content = createChatItem user cd False content sharedMsgId Nothing
|
||||
cInfo = DirectChat ct
|
||||
void $ createItem Nothing $ CIRcvDirectE2EEInfo $ E2EInfo $ connRequestPQEncryption cReq
|
||||
void $ createItem Nothing $ CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ connRequestPQEncryption cReq
|
||||
void $ createFeatureEnabledItems_ user ct
|
||||
aci <- mapM (createItem welcomeSharedMsgId . CIRcvMsgContent) message
|
||||
let chat = case aci of
|
||||
@@ -2088,12 +2138,12 @@ processChatCommand vr nm = \case
|
||||
toView $ CEvtNewChatItems user [ci]
|
||||
pure $ CRStartedConnectionToContact user ct' customUserProfile
|
||||
CVRConnectedContact ct' -> pure $ CRContactAlreadyExists user ct'
|
||||
APIConnectPreparedGroup groupId incognito msgContent_ -> withUser $ \user -> do
|
||||
APIConnectPreparedGroup {groupId, incognito, ownerContact, msgContent_} -> withUser $ \user -> do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db vr user groupId
|
||||
case gInfo of
|
||||
GroupInfo {preparedGroup = Nothing} -> throwCmdError "group doesn't have link to connect"
|
||||
GroupInfo {useRelays = BoolDef True, preparedGroup = Just PreparedGroup {connLinkToConnect}} -> do
|
||||
sLnk <- case toShortLinkContact connLinkToConnect of
|
||||
sLnk <- case connShortLink' connLinkToConnect of
|
||||
Just sl -> pure sl
|
||||
Nothing -> throwChatError $ CEException "failed to retrieve relays: no short link"
|
||||
(FixedLinkData {linkConnReq = mainCReq@(CRContactUri crData), linkEntityId, rootKey}, cData@(ContactLinkData _ UserContactData {owners, relays})) <- getShortLinkConnReq nm user sLnk
|
||||
@@ -2114,10 +2164,15 @@ processChatCommand vr nm = \case
|
||||
gInfo' <- withFastStore $ \db -> do
|
||||
gInfo' <- updatePreparedRelayedGroup db vr user gInfo mainCReq cReqHash incognitoProfile rootKey memberPrivKey publicMemberCount_
|
||||
-- Pre-emptively create owner members with trusted keys from link data
|
||||
forM_ owners $ \OwnerAuth {ownerId, ownerKey} ->
|
||||
void $ createLinkOwnerMember db vr user gInfo' (MemberId ownerId) ownerKey
|
||||
forM_ owners $ \OwnerAuth {ownerId, ownerKey} -> do
|
||||
let ctId_ = case ownerContact of
|
||||
Just GroupOwnerContact {contactId, memberId}
|
||||
| memberId == MemberId ownerId -> Just contactId
|
||||
_ -> Nothing
|
||||
void $ createLinkOwnerMember db vr user gInfo' ctId_ (MemberId ownerId) ownerKey
|
||||
pure gInfo'
|
||||
rs <- mapConcurrently (connectToRelay gInfo') relays
|
||||
rs <- withGroupLock "connectPreparedGroup" groupId $
|
||||
mapConcurrently (connectToRelay user gInfo') relays
|
||||
let relayFailed = \case (_, _, Left _) -> True; _ -> False
|
||||
(failed, succeeded) = partition relayFailed rs
|
||||
if null succeeded
|
||||
@@ -2144,23 +2199,6 @@ processChatCommand vr nm = \case
|
||||
isTempErr = \case
|
||||
(_, _, Left ChatErrorAgent {agentError = e}) -> temporaryOrHostError e
|
||||
_ -> False
|
||||
connectToRelay gInfo' relayLink = do
|
||||
gVar <- asks random
|
||||
-- Save relayLink to re-use relay member record on retry (check by relayLink)
|
||||
relayMember <- withFastStore $ \db -> getCreateRelayForMember db vr gVar user gInfo' relayLink
|
||||
r <- tryAllErrors $ do
|
||||
(fd@FixedLinkData {rootKey = relayKey, linkEntityId}, cData) <- getShortLinkConnReq nm user relayLink
|
||||
relayLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
case (relayLinkData_, linkEntityId) of
|
||||
(Just RelayShortLinkData {relayProfile = p}, Just entityId) ->
|
||||
withFastStore $ \db -> updateRelayMemberData db user relayMember (MemberId entityId) (MemberKey relayKey) p
|
||||
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
|
||||
let cReq = linkConnReq fd
|
||||
relayLinkToConnect = CCLink cReq (Just relayLink)
|
||||
void $ connectViaContact user (Just $ PCEGroup gInfo' relayMember) incognito relayLinkToConnect Nothing Nothing
|
||||
-- Re-read member to get updated activeConn and updated data (from updateRelayMemberData)
|
||||
relayMember' <- withFastStore $ \db -> getGroupMember db vr user groupId (groupMemberId' relayMember)
|
||||
pure (relayLink, relayMember', r)
|
||||
retryRelayConnectionAsync gInfo' relayLink relayMember@GroupMember {activeConn} = do
|
||||
forM_ activeConn $ \conn -> do
|
||||
deleteAgentConnectionAsync $ aConnId conn
|
||||
@@ -2209,7 +2247,7 @@ processChatCommand vr nm = \case
|
||||
Connect incognito (Just cLink@(ACL m cLink')) -> withUser $ \user -> do
|
||||
-- TODO [relays] member: /c api to support groups with relays
|
||||
-- TODO - possibly by going through APIPrepareGroup -> APIConnectPreparedGroup
|
||||
(ccLink, plan) <- connectPlan user cLink `catchAllErrors` \e -> case cLink' of CLFull cReq -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing)); _ -> throwError e
|
||||
(ccLink, plan) <- connectPlan user cLink False Nothing `catchAllErrors` \e -> case cLink' of CLFull cReq -> pure (ACCL m (CCLink cReq Nothing), CPInvitationLink (ILPOk Nothing Nothing)); _ -> throwError e
|
||||
connectWithPlan user incognito ccLink plan
|
||||
Connect _ Nothing -> throwChatError CEInvalidConnReq
|
||||
APIConnectContactViaAddress userId incognito contactId -> withUserId userId $ \user -> do
|
||||
@@ -2227,7 +2265,7 @@ processChatCommand vr nm = \case
|
||||
toView $ CEvtChatInfoUpdated user (AChatInfo SCTDirect $ DirectChat ct')
|
||||
throwError e
|
||||
ConnectSimplex incognito -> withUser $ \user -> do
|
||||
plan <- contactRequestPlan user adminContactReq Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing))
|
||||
plan <- contactRequestPlan user adminContactReq Nothing Nothing `catchAllErrors` const (pure $ CPContactAddress (CAPOk Nothing Nothing))
|
||||
connectWithPlan user incognito (ACCL SCMContact (CCLink adminContactReq Nothing)) plan
|
||||
DeleteContact cName cdm -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId Nothing) cdm
|
||||
ClearContact cName -> withContactName cName $ \chatId -> APIClearChat $ ChatRef CTDirect chatId Nothing
|
||||
@@ -2249,7 +2287,7 @@ processChatCommand vr nm = \case
|
||||
-- TODO [certs rcv]
|
||||
(connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) Nothing IKPQOn subMode
|
||||
ccLink' <- shortenCreatedLink ccLink
|
||||
let ccLink'' = if isTrue userChatRelay then createdRelayLink ccLink' else ccLink'
|
||||
let ccLink'' = if isTrue userChatRelay then setShortLinkType CCTRelay ccLink' else ccLink'
|
||||
withFastStore $ \db -> createUserContactLink db user connId ccLink'' subMode
|
||||
pure $ CRUserContactLinkCreated user ccLink''
|
||||
CreateMyAddress -> withUser $ \User {userId} ->
|
||||
@@ -2321,6 +2359,19 @@ processChatCommand vr nm = \case
|
||||
toChatRef <- getChatRef user toChatName
|
||||
asGroup <- getSendAsGroup user toChatRef
|
||||
processChatCommand vr nm $ APIForwardChatItems toChatRef asGroup (ChatRef CTLocal folderId Nothing) (forwardedItemId :| []) Nothing
|
||||
SharePublicGroup shareGroupName toChatName -> withUser $ \user -> do
|
||||
groupId <- withFastStore $ \db -> getGroupIdByName db user shareGroupName
|
||||
toChatRef <- getChatRef user toChatName
|
||||
sendRef <- case toChatRef of
|
||||
ChatRef CTDirect ctId _ -> pure $ SRDirect ctId
|
||||
ChatRef CTGroup gId scope_ -> do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId
|
||||
pure $ SRGroup gId scope_ (useRelays' gInfo)
|
||||
_ -> throwCmdError "unsupported share target"
|
||||
processChatCommand vr nm (APIShareChatMsgContent (ChatRef CTGroup groupId Nothing) sendRef) >>= \case
|
||||
CRChatMsgContent _ mc ->
|
||||
processChatCommand vr nm $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
|
||||
r -> pure r
|
||||
SendMessage sendName msg -> withUser $ \user -> do
|
||||
let mc = MCText msg
|
||||
case sendName of
|
||||
@@ -2347,7 +2398,7 @@ processChatCommand vr nm = \case
|
||||
forM scope_ $ \(GSNMemberSupport mName_) ->
|
||||
GCSMemberSupport <$> mapM (getGroupMemberIdByName db user gId) mName_
|
||||
(gInfo, cScope_,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let sendRef = SRGroup (groupId' gInfo) cScope_ (sendAsGroup' gInfo)
|
||||
let sendRef = SRGroup (groupId' gInfo) cScope_ (sendAsGroup' gInfo cScope_)
|
||||
processChatCommand vr nm $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
|
||||
SNLocal -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
@@ -2454,13 +2505,29 @@ processChatCommand vr nm = \case
|
||||
APINewPublicGroup userId incognito relayIds groupProfile -> withUserId userId $ \user -> do
|
||||
(gProfile', memberId, groupKeys, setupLink) <- prepareGroupLink user
|
||||
gInfo <- newGroup user incognito gProfile' True memberId (Just groupKeys) (Just 1)
|
||||
(gLink, groupRelays) <- setupLink gInfo `catchAllErrors` \e -> do
|
||||
(gLink, results) <- setupLink gInfo `catchAllErrors` \e -> do
|
||||
deleteInProgressGroup user gInfo
|
||||
throwError e
|
||||
createNewGroupItems user gInfo
|
||||
pure $ CRPublicGroupCreated user gInfo gLink groupRelays
|
||||
case partitionEithers (map snd results) of
|
||||
([], groupRelays) -> do
|
||||
createNewGroupItems user gInfo
|
||||
pure $ CRPublicGroupCreated user gInfo gLink groupRelays
|
||||
(errors@(e : _), _) -> do
|
||||
deleteInProgressGroup user gInfo
|
||||
-- If all errors are temporary (network, timeout, host), throw to allow retry
|
||||
if all isTempErr errors
|
||||
then throwError e
|
||||
else do
|
||||
let relayResults = map toRelayResult results
|
||||
toRelayResult (r, Left e) = AddRelayResult r (Just e)
|
||||
toRelayResult (r, Right _) = AddRelayResult r Nothing
|
||||
pure $ CRPublicGroupCreationFailed user relayResults
|
||||
where
|
||||
prepareGroupLink :: User -> CM (GroupProfile, MemberId, GroupKeys, GroupInfo -> CM (GroupLink, [GroupRelay]))
|
||||
isTempErr :: ChatError -> Bool
|
||||
isTempErr = \case
|
||||
ChatErrorAgent {agentError = e} -> temporaryOrHostError e
|
||||
_ -> False
|
||||
prepareGroupLink :: User -> CM (GroupProfile, MemberId, GroupKeys, GroupInfo -> CM (GroupLink, [(UserChatRelay, Either ChatError GroupRelay)]))
|
||||
prepareGroupLink user = do
|
||||
gVar <- asks random
|
||||
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
|
||||
@@ -2471,8 +2538,8 @@ processChatCommand vr nm = \case
|
||||
crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
-- prepare link with entityId as linkEntityId (no server request)
|
||||
(ccLink, preparedParams) <- withAgent $ \a -> prepareConnectionLink a (aUserId user) rootKey entityId True (Just crClientData)
|
||||
ccLink' <- createdChannelLink <$> shortenCreatedLink ccLink
|
||||
sLnk <- case toShortLinkContact ccLink' of
|
||||
ccLink' <- setShortLinkType CCTChannel <$> shortenCreatedLink ccLink
|
||||
sLnk <- case connShortLink' ccLink' of
|
||||
Just sl -> pure sl
|
||||
Nothing -> throwChatError $ CEException "failed to create relayed group link: no short link"
|
||||
-- generate owner key, OwnerAuth signed by root key
|
||||
@@ -2498,8 +2565,8 @@ processChatCommand vr nm = \case
|
||||
subRole <- asks $ channelSubscriberRole . config
|
||||
gLink <- withFastStore $ \db -> createGroupLink db gVar user gInfo connId ccLink' groupLinkId subRole subMode
|
||||
relays <- withFastStore $ \db -> mapM (getChatRelayById db user) (L.toList relayIds)
|
||||
groupRelays <- addRelays user gInfo sLnk relays
|
||||
pure (gLink, groupRelays)
|
||||
results <- addRelays user gInfo sLnk relays
|
||||
pure (gLink, results)
|
||||
pure (groupProfile', memberId, groupKeys, setupLink)
|
||||
NewPublicGroup incognito relayIds gProfile -> withUser $ \User {userId} ->
|
||||
processChatCommand vr nm $ APINewPublicGroup userId incognito relayIds gProfile
|
||||
@@ -2509,6 +2576,37 @@ processChatCommand vr nm = \case
|
||||
relays <- liftIO $ getGroupRelays db gInfo
|
||||
pure (gInfo, relays)
|
||||
pure $ CRGroupRelays user gInfo relays
|
||||
APIAddGroupRelays groupId relayIds -> withUser $ \user -> withGroupLock "addGroupRelays" groupId $ do
|
||||
(gInfo, existingRelays) <- withFastStore $ \db -> do
|
||||
gi <- getGroupInfo db vr user groupId
|
||||
rs <- liftIO $ getGroupRelays db gi
|
||||
pure (gi, rs)
|
||||
assertUserGroupRole gInfo GROwner
|
||||
unless (useRelays' gInfo) $ throwCmdError "group does not use relays"
|
||||
let existingRelayIds = map (\GroupRelay {userChatRelay = UserChatRelay {chatRelayId = DBEntityId rId}} -> rId) existingRelays
|
||||
when (any (`elem` existingRelayIds) relayIds) $ throwCmdError "some relays are already in the group"
|
||||
gLink@GroupLink {connLinkContact = ccLink} <- withFastStore $ \db -> getGroupLink db user gInfo
|
||||
sLnk <- case connShortLink' ccLink of
|
||||
Just sl -> pure sl
|
||||
Nothing -> throwChatError $ CEException "group link has no short link"
|
||||
relays <- withFastStore $ \db -> mapM (getChatRelayById db user) (L.toList relayIds)
|
||||
results <- addRelays user gInfo sLnk relays
|
||||
case partitionEithers (map snd results) of
|
||||
([], _) -> do
|
||||
relays' <- withFastStore $ \db -> liftIO $ getGroupRelays db gInfo
|
||||
pure $ CRGroupRelaysAdded user gInfo gLink relays'
|
||||
(errors@(e : _), _) -> do
|
||||
if all isTempErr errors
|
||||
then throwError e
|
||||
else do
|
||||
let toRelayResult (r, Left e') = AddRelayResult r (Just e')
|
||||
toRelayResult (r, Right _) = AddRelayResult r Nothing
|
||||
pure $ CRGroupRelaysAddFailed user (map toRelayResult results)
|
||||
where
|
||||
isTempErr :: ChatError -> Bool
|
||||
isTempErr = \case
|
||||
ChatErrorAgent {agentError = e} -> temporaryOrHostError e
|
||||
_ -> False
|
||||
APIAddMember groupId contactId memRole -> withUser $ \user -> withGroupLock "addMember" groupId $ do
|
||||
-- TODO for large groups: no need to load all members to determine if contact is a member
|
||||
(group, contact) <- withFastStore $ \db -> (,) <$> getGroup db vr user groupId <*> getContact db vr user contactId
|
||||
@@ -2865,18 +2963,35 @@ processChatCommand vr nm = \case
|
||||
filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo
|
||||
withGroupLock "leaveGroup" groupId $ do
|
||||
cancelFilesInProgress user filesInfo
|
||||
(members, recipients) <- getRecipients user gInfo
|
||||
msg <- sendGroupMessage' user gInfo recipients XGrpLeave
|
||||
msg <-
|
||||
if useRelays' gInfo && isRelay membership
|
||||
then leaveChannelRelay gInfo
|
||||
else leaveGroupSendMsg user gInfo
|
||||
(gInfo', scopeInfo) <- mkLocalGroupChatScope gInfo
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo' scopeInfo) msg (CISndGroupEvent SGEUserLeft)
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo' scopeInfo) ci]
|
||||
-- TODO delete direct connections that were unused
|
||||
deleteGroupLinkIfExists user gInfo'
|
||||
-- member records are not deleted to keep history
|
||||
deleteMembersConnections' user members True
|
||||
withFastStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
|
||||
pure $ CRLeftMemberUser user gInfo' {membership = membership {memberStatus = GSMemLeft}}
|
||||
where
|
||||
-- Relay leaving channel: create delivery job for cursor-based sending and async connection cleanup.
|
||||
leaveChannelRelay gInfo = do
|
||||
msg@SndMessage {msgBody, signedMsg_} <-
|
||||
liftEither . runIdentity =<< lift (createSndMessages $ Identity (GroupId groupId, groupMsgSigning gInfo XGrpLeave, XGrpLeave))
|
||||
let body = encodeBatchElement signedMsg_ msgBody
|
||||
withFastStore' $ \db -> do
|
||||
deleteGroupDeliveryTasks db gInfo
|
||||
deleteGroupDeliveryJobs db gInfo
|
||||
createMsgDeliveryJob db gInfo (DJSGroup {jobSpec = DJRelayRemoved}) Nothing body
|
||||
lift . void $ getDeliveryJobWorker True (groupId, DWSGroup)
|
||||
pure msg
|
||||
leaveGroupSendMsg user gInfo = do
|
||||
(members, recipients) <- getRecipients user gInfo
|
||||
msg <- sendGroupMessage' user gInfo recipients XGrpLeave
|
||||
deleteMembersConnections' user members True
|
||||
pure msg
|
||||
getRecipients user gInfo
|
||||
| useRelays' gInfo = do
|
||||
relays <- withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
|
||||
@@ -2952,7 +3067,7 @@ processChatCommand vr nm = \case
|
||||
crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
-- TODO [certs rcv]
|
||||
(connId, (ccLink, _serviceId)) <- withAgent $ \a -> createConnection a nm (aUserId user) True True SCMContact (Just userLinkData) (Just crClientData) IKPQOff subMode
|
||||
ccLink' <- createdGroupLink <$> shortenCreatedLink ccLink
|
||||
ccLink' <- setShortLinkType CCTGroup <$> shortenCreatedLink ccLink
|
||||
gVar <- asks random
|
||||
gLink <- withFastStore $ \db -> createGroupLink db gVar user gInfo connId ccLink' groupLinkId mRole subMode
|
||||
pure $ CRGroupLinkCreated user gInfo gLink
|
||||
@@ -3076,7 +3191,7 @@ processChatCommand vr nm = \case
|
||||
qiId <- getGroupChatItemIdByText db user gId cName quotedMsg
|
||||
(gInfo, qiId,) <$> liftIO (getMessageMentions db user gId msg)
|
||||
let mc = MCText msg
|
||||
processChatCommand vr nm $ APISendMessages (SRGroup (groupId' gInfo) Nothing (sendAsGroup' gInfo)) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
|
||||
processChatCommand vr nm $ APISendMessages (SRGroup (groupId' gInfo) Nothing (sendAsGroup' gInfo Nothing)) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
|
||||
ClearNoteFolder -> withUser $ \user -> do
|
||||
folderId <- withFastStore (`getUserNoteFolderId` user)
|
||||
processChatCommand vr nm $ APIClearChat (ChatRef CTLocal folderId Nothing)
|
||||
@@ -3352,7 +3467,7 @@ processChatCommand vr nm = \case
|
||||
_ -> throwCmdError "not supported"
|
||||
pure $ ChatRef cType chatId Nothing
|
||||
getSendAsGroup :: User -> ChatRef -> CM ShowGroupAsSender
|
||||
getSendAsGroup user' (ChatRef CTGroup chatId _) = sendAsGroup' <$> withFastStore (\db -> getGroupInfo db vr user' chatId)
|
||||
getSendAsGroup user' (ChatRef CTGroup chatId scope) = (`sendAsGroup'` scope) <$> withFastStore (\db -> getGroupInfo db vr user' chatId)
|
||||
getSendAsGroup _ _ = pure False
|
||||
getChatRefAndMentions :: User -> ChatName -> Text -> CM (ChatRef, Map MemberName GroupMemberId)
|
||||
getChatRefAndMentions user cName msg = do
|
||||
@@ -3522,6 +3637,43 @@ processChatCommand vr nm = \case
|
||||
ct' <- withStore $ \db -> getContact db vr user contactId
|
||||
pure $ CRSentInvitationToContact user ct' incognitoProfile
|
||||
_ -> throwCmdError "contact already has connection"
|
||||
connectToRelay :: User -> GroupInfo -> ShortLinkContact -> CM (ShortLinkContact, GroupMember, Either ChatError ())
|
||||
connectToRelay user gInfo relayLink = do
|
||||
gVar <- asks random
|
||||
-- Save relayLink to re-use relay member record on retry (check by relayLink)
|
||||
relayMember <- withFastStore $ \db -> getCreateRelayForMember db vr gVar user gInfo relayLink
|
||||
r <- tryAllErrors $ do
|
||||
(fd@FixedLinkData {rootKey = relayKey, linkEntityId}, cData) <- getShortLinkConnReq nm user relayLink
|
||||
relayLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
case (relayLinkData_, linkEntityId) of
|
||||
(Just RelayShortLinkData {relayProfile = p}, Just entityId) ->
|
||||
withFastStore $ \db -> updateRelayMemberData db user relayMember (MemberId entityId) (MemberKey relayKey) p
|
||||
_ -> throwChatError $ CEException "relay link: no relay link data or entity id"
|
||||
let cReq = linkConnReq fd
|
||||
relayLinkToConnect = CCLink cReq (Just relayLink)
|
||||
void $ connectViaContact user (Just $ PCEGroup gInfo relayMember) (incognitoMembership gInfo) relayLinkToConnect Nothing Nothing
|
||||
relayMember' <- withFastStore $ \db -> getGroupMember db vr user (groupId' gInfo) (groupMemberId' relayMember)
|
||||
pure (relayLink, relayMember', r)
|
||||
syncSubscriberRelays :: User -> GroupInfo -> [ShortLinkContact] -> CM ()
|
||||
syncSubscriberRelays user gInfo currentRelayLinks = void . tryAllErrors $ do
|
||||
localRelayMembers <- withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
|
||||
let activeRelayMembers = filter memberCurrent localRelayMembers
|
||||
memberRelayLink GroupMember {relayLink = rl} = rl
|
||||
localRelayLinks = mapMaybe memberRelayLink activeRelayMembers
|
||||
newRelayLinks = filter (`notElem` localRelayLinks) currentRelayLinks
|
||||
forM_ newRelayLinks $ \rlnk -> void . tryAllErrors $
|
||||
connectToRelayAsync user gInfo rlnk
|
||||
forM_ localRelayMembers $ \m ->
|
||||
case memberRelayLink m of
|
||||
-- Remove relay if its link is no longer in the current link data.
|
||||
-- Inactive relays (e.g. left) are only cleaned up when no active relays remain,
|
||||
-- as that is the only case where the owner's relay removal can't be forwarded.
|
||||
Just rlnk | rlnk `notElem` currentRelayLinks,
|
||||
memberCurrent m || null activeRelayMembers ->
|
||||
void . tryAllErrors $ do
|
||||
deleteMemberConnection m
|
||||
deleteOrUpdateMemberRecord user gInfo m
|
||||
_ -> pure ()
|
||||
prepareContact :: User -> ConnReqContact -> PQSupport -> CM (ConnId, VersionChat)
|
||||
prepareContact user cReq pqSup = do
|
||||
-- 0) toggle disabled - PQSupportOff
|
||||
@@ -3806,7 +3958,7 @@ processChatCommand vr nm = \case
|
||||
createNewGroupItems user gInfo = do
|
||||
let cd = CDGroupSnd gInfo Nothing
|
||||
createInternalChatItem user cd CIChatBanner (Just epochStart)
|
||||
createInternalChatItem user cd (CISndGroupE2EEInfo E2EInfo {pqEnabled = Just PQEncOff}) Nothing
|
||||
createInternalChatItem user cd (CISndGroupE2EEInfo $ e2eInfoGroup gInfo) Nothing
|
||||
createGroupFeatureItems user cd CISndGroupFeature gInfo
|
||||
sendGrpInvitation :: User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> CM ()
|
||||
sendGrpInvitation user ct@Contact {contactId, localDisplayName} gInfo@GroupInfo {groupId, groupProfile, membership, businessChat} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
|
||||
@@ -3829,15 +3981,12 @@ processChatCommand vr nm = \case
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci]
|
||||
forM_ (timed_ >>= timedDeleteAt') $
|
||||
startProximateTimedItemThread user (ChatRef CTDirect contactId Nothing, chatItemId' ci)
|
||||
addRelays :: User -> GroupInfo -> ShortLinkContact -> [UserChatRelay] -> CM [GroupRelay]
|
||||
addRelays :: User -> GroupInfo -> ShortLinkContact -> [UserChatRelay] -> CM [(UserChatRelay, Either ChatError GroupRelay)]
|
||||
addRelays user gInfo@GroupInfo {membership} groupSLink relays =
|
||||
mapConcurrently addRelay relays
|
||||
where
|
||||
addRelay :: UserChatRelay -> CM GroupRelay
|
||||
addRelay relay@UserChatRelay {address} = do
|
||||
-- TODO [relays] owner: track and reuse relay profiles
|
||||
-- TODO - single profile linked to relay configuration record (chat_relays)
|
||||
-- TODO - update when fetching link data from relay address
|
||||
addRelay :: UserChatRelay -> CM (UserChatRelay, Either ChatError GroupRelay)
|
||||
addRelay relay@UserChatRelay {address} = fmap (relay,) . tryAllErrors $ do
|
||||
(FixedLinkData {linkConnReq = cReq}, _cData) <- getShortLinkConnReq nm user address
|
||||
lift (withAgent' $ \a -> connRequestPQSupport a PQSupportOff cReq) >>= \case
|
||||
Nothing -> throwChatError CEInvalidConnReq
|
||||
@@ -3930,28 +4079,29 @@ processChatCommand vr nm = \case
|
||||
pure (gId, chatSettings)
|
||||
_ -> throwCmdError "not supported"
|
||||
processChatCommand vr nm $ APISetChatSettings (ChatRef cType chatId Nothing) $ updateSettings chatSettings
|
||||
connectPlan :: User -> AConnectionLink -> CM (ACreatedConnLink, ConnectionPlan)
|
||||
connectPlan user (ACL SCMInvitation cLink) = case cLink of
|
||||
CLFull cReq -> invitationReqAndPlan cReq Nothing Nothing
|
||||
connectPlan :: User -> AConnectionLink -> Bool -> Maybe LinkOwnerSig -> CM (ACreatedConnLink, ConnectionPlan)
|
||||
connectPlan user (ACL SCMInvitation 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
|
||||
Nothing -> do
|
||||
(FixedLinkData {linkConnReq = cReq}, cData) <- getShortLinkConnReq nm user l'
|
||||
(FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l'
|
||||
contactSLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
invitationReqAndPlan cReq (Just l') contactSLinkData_
|
||||
let ov = verifyLinkOwner rootKey [] l sig_
|
||||
invitationReqAndPlan cReq (Just l') contactSLinkData_ ov
|
||||
where
|
||||
knownLinkPlans l' = withFastStore $ \db -> do
|
||||
let inv cReq = ACCL SCMInvitation $ CCLink cReq (Just l')
|
||||
liftIO (getConnectionEntityViaShortLink db vr user l') >>= \case
|
||||
Just (cReq, ent) -> pure $ Just (inv cReq, invitationEntityPlan Nothing ent)
|
||||
Just (cReq, ent) -> pure $ Just (inv cReq, invitationEntityPlan Nothing Nothing ent)
|
||||
-- deleted contact is returned as known, as invitation link cannot be re-used too connect anyway
|
||||
Nothing -> bimap inv (CPInvitationLink . ILPKnown) <$$> getContactViaShortLinkToConnect db vr user l'
|
||||
invitationReqAndPlan cReq sLnk_ contactSLinkData_ = do
|
||||
plan <- invitationRequestPlan user cReq contactSLinkData_ `catchAllErrors` (pure . CPError)
|
||||
invitationReqAndPlan cReq sLnk_ cld ov = do
|
||||
plan <- invitationRequestPlan user cReq cld ov `catchAllErrors` (pure . CPError)
|
||||
pure (ACCL SCMInvitation (CCLink cReq sLnk_), plan)
|
||||
connectPlan user (ACL SCMContact cLink) = case cLink of
|
||||
connectPlan user (ACL SCMContact cLink) resolveKnown sig_ = case cLink of
|
||||
CLFull cReq -> do
|
||||
plan <- contactOrGroupRequestPlan user cReq `catchAllErrors` (pure . CPError)
|
||||
pure (ACCL SCMContact $ CCLink cReq Nothing, plan)
|
||||
@@ -3961,12 +4111,14 @@ processChatCommand vr nm = \case
|
||||
knownLinkPlans >>= \case
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
(FixedLinkData {linkConnReq = cReq}, cData) <- getShortLinkConnReq nm user l'
|
||||
(FixedLinkData {linkConnReq = cReq, rootKey}, cData) <- getShortLinkConnReq nm user l'
|
||||
withFastStore' (\db -> getContactWithoutConnViaShortAddress db vr user l') >>= \case
|
||||
Just ct' | not (contactDeleted ct') -> pure (con cReq, CPContactAddress (CAPContactViaAddress ct'))
|
||||
_ -> do
|
||||
contactSLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
plan <- contactRequestPlan user cReq contactSLinkData_
|
||||
let ContactLinkData _ UserContactData {owners} = cData
|
||||
ov = verifyLinkOwner rootKey owners l' sig_
|
||||
plan <- contactRequestPlan user cReq contactSLinkData_ ov
|
||||
pure (con cReq, plan)
|
||||
where
|
||||
knownLinkPlans = withFastStore $ \db ->
|
||||
@@ -3982,30 +4134,43 @@ processChatCommand vr nm = \case
|
||||
where
|
||||
l' = serverShortLink l
|
||||
con cReq = ACCL SCMContact $ CCLink cReq (Just l')
|
||||
gPlan (cReq, g) = if memberRemoved (membership g) then Nothing else Just (con cReq, CPGroupLink (GLPKnown g))
|
||||
gPlan (cReq, g) = if memberRemoved (membership g) then Nothing else Just (con cReq, CPGroupLink (GLPKnown g (BoolDef False) Nothing (ListDef [])))
|
||||
groupShortLinkPlan =
|
||||
knownLinkPlans >>= \case
|
||||
Just (_, CPGroupLink (GLPKnown g _ _ _))
|
||||
| resolveKnown -> resolveKnownGroup g
|
||||
Just r -> pure r
|
||||
Nothing -> do
|
||||
(fd, cData@(ContactLinkData _ UserContactData {direct, relays})) <- getShortLinkConnReq nm user l'
|
||||
let FixedLinkData {linkConnReq = cReq, linkEntityId} = fd
|
||||
linkInfo = GroupShortLinkInfo {direct, groupRelays = relays, publicGroupId = B64UrlByteString <$> linkEntityId}
|
||||
(fd, cData@(ContactLinkData _ UserContactData {direct, owners, relays})) <- getShortLinkConnReq' nm user l'
|
||||
groupSLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
-- Cross-validate linkEntityId and publicGroupId from profile:
|
||||
-- for channels both must be present and match, for p2p groups both must be absent
|
||||
let profilePGId = groupSLinkData_ >>= \GroupShortLinkData {groupProfile = GroupProfile {publicGroup}} ->
|
||||
fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId) publicGroup
|
||||
case (B64UrlByteString <$> linkEntityId, profilePGId) of
|
||||
(Just entityId, Just publicGroupId) | entityId == publicGroupId -> pure ()
|
||||
(Nothing, Nothing) -> pure ()
|
||||
_ -> throwChatError CEInvalidConnReq
|
||||
plan <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_
|
||||
pure (con cReq, plan)
|
||||
if not direct && null relays
|
||||
then pure (con (linkConnReq fd), CPGroupLink (GLPNoRelays groupSLinkData_))
|
||||
else do
|
||||
let FixedLinkData {linkConnReq = cReq, linkEntityId, rootKey} = fd
|
||||
linkInfo = GroupShortLinkInfo {direct, groupRelays = relays, publicGroupId = B64UrlByteString <$> linkEntityId}
|
||||
let profilePGId = groupSLinkData_ >>= \GroupShortLinkData {groupProfile = GroupProfile {publicGroup}} ->
|
||||
fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId) publicGroup
|
||||
case (B64UrlByteString <$> linkEntityId, profilePGId) of
|
||||
(Just entityId, Just publicGroupId) | entityId == publicGroupId -> pure ()
|
||||
(Nothing, Nothing) -> pure ()
|
||||
_ -> throwChatError CEInvalidConnReq
|
||||
let ov = verifyLinkOwner rootKey owners l' sig_
|
||||
plan <- groupJoinRequestPlan user cReq (Just linkInfo) groupSLinkData_ ov
|
||||
pure (con cReq, plan)
|
||||
where
|
||||
knownLinkPlans = withFastStore $ \db ->
|
||||
liftIO (getGroupInfoViaUserShortLink db vr user l') >>= \case
|
||||
Just (cReq, g) -> pure $ Just (con cReq, CPGroupLink (GLPOwnLink g))
|
||||
Nothing -> (gPlan =<<) <$> getGroupViaShortLinkToConnect db vr user l'
|
||||
resolveKnownGroup g = do
|
||||
(fd@FixedLinkData {rootKey = rk}, cData@(ContactLinkData _ UserContactData {owners})) <- getShortLinkConnReq' nm user l'
|
||||
groupSLinkData_ <- liftIO $ decodeLinkUserData cData
|
||||
let ov = verifyLinkOwner rk owners l' sig_
|
||||
glOwners = map (\OwnerAuth {ownerId, ownerKey} -> GroupLinkOwner {memberId = MemberId ownerId, memberKey = ownerKey}) owners
|
||||
(g', updated) <- case groupSLinkData_ of
|
||||
Just sLinkData -> updateGroupFromLinkData user g sLinkData
|
||||
_ -> pure (g, False)
|
||||
pure (con (linkConnReq fd), CPGroupLink (GLPKnown g' (BoolDef updated) ov (ListDef glOwners)))
|
||||
connectWithPlan :: User -> IncognitoEnabled -> ACreatedConnLink -> ConnectionPlan -> CM ChatResponse
|
||||
connectWithPlan user@User {userId} incognito ccLink plan
|
||||
| connectionPlanProceed plan = do
|
||||
@@ -4015,9 +4180,9 @@ processChatCommand vr nm = \case
|
||||
processChatCommand vr nm $ APIConnectContactViaAddress userId incognito contactId
|
||||
_ -> processChatCommand vr nm $ APIConnect userId incognito $ Just ccLink
|
||||
| otherwise = pure $ CRConnectionPlan user ccLink plan
|
||||
invitationRequestPlan :: User -> ConnReqInvitation -> Maybe ContactShortLinkData -> CM ConnectionPlan
|
||||
invitationRequestPlan user cReq contactSLinkData_ = do
|
||||
maybe (CPInvitationLink (ILPOk contactSLinkData_)) (invitationEntityPlan contactSLinkData_)
|
||||
invitationRequestPlan :: User -> ConnReqInvitation -> Maybe ContactShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan
|
||||
invitationRequestPlan user cReq cld ov = do
|
||||
maybe (CPInvitationLink (ILPOk cld ov)) (invitationEntityPlan cld ov)
|
||||
<$> withFastStore' (\db -> getConnectionEntityByConnReq db vr user $ invCReqSchemas cReq)
|
||||
where
|
||||
invCReqSchemas :: ConnReqInvitation -> (ConnReqInvitation, ConnReqInvitation)
|
||||
@@ -4025,15 +4190,15 @@ processChatCommand vr nm = \case
|
||||
( CRInvitationUri crData {crScheme = SSSimplex} e2e,
|
||||
CRInvitationUri crData {crScheme = simplexChat} e2e
|
||||
)
|
||||
invitationEntityPlan :: Maybe ContactShortLinkData -> ConnectionEntity -> ConnectionPlan
|
||||
invitationEntityPlan contactSLinkData_ = \case
|
||||
invitationEntityPlan :: Maybe ContactShortLinkData -> Maybe OwnerVerification -> ConnectionEntity -> ConnectionPlan
|
||||
invitationEntityPlan cld ov = \case
|
||||
RcvDirectMsgConnection Connection {connStatus, contactConnInitiated} ct_ -> case ct_ of
|
||||
Just ct
|
||||
| contactActive ct -> CPInvitationLink (ILPKnown ct)
|
||||
| otherwise -> CPInvitationLink (ILPOk contactSLinkData_)
|
||||
| otherwise -> CPInvitationLink (ILPOk cld ov)
|
||||
Nothing
|
||||
| connStatus == ConnNew && contactConnInitiated -> CPInvitationLink ILPOwnLink
|
||||
| connStatus == ConnPrepared -> CPInvitationLink (ILPOk contactSLinkData_)
|
||||
| connStatus == ConnPrepared -> CPInvitationLink (ILPOk cld ov)
|
||||
| otherwise -> CPInvitationLink (ILPConnecting Nothing)
|
||||
_ -> CPError $ ChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
|
||||
contactOrGroupRequestPlan :: User -> ConnReqContact -> CM ConnectionPlan
|
||||
@@ -4041,10 +4206,10 @@ processChatCommand vr nm = \case
|
||||
let ConnReqUriData {crClientData} = crData
|
||||
groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
|
||||
case groupLinkId of
|
||||
Nothing -> contactRequestPlan user cReq Nothing
|
||||
Just _ -> groupJoinRequestPlan user cReq Nothing Nothing
|
||||
contactRequestPlan :: User -> ConnReqContact -> Maybe ContactShortLinkData -> CM ConnectionPlan
|
||||
contactRequestPlan user (CRContactUri crData) contactSLinkData_ = do
|
||||
Nothing -> contactRequestPlan user cReq Nothing Nothing
|
||||
Just _ -> groupJoinRequestPlan user cReq Nothing Nothing Nothing
|
||||
contactRequestPlan :: User -> ConnReqContact -> Maybe ContactShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan
|
||||
contactRequestPlan user (CRContactUri crData) cld ov = do
|
||||
let cReqSchemas = contactCReqSchemas crData
|
||||
cReqHashes = bimap contactCReqHash contactCReqHash cReqSchemas
|
||||
withFastStore' (\db -> getUserContactLinkByConnReq db user cReqSchemas) >>= \case
|
||||
@@ -4054,19 +4219,19 @@ processChatCommand vr nm = \case
|
||||
Nothing ->
|
||||
withFastStore' (\db -> getContactWithoutConnViaAddress db vr user cReqSchemas) >>= \case
|
||||
Just ct | not (contactDeleted ct) -> pure $ CPContactAddress (CAPContactViaAddress ct)
|
||||
_ -> pure $ CPContactAddress (CAPOk contactSLinkData_)
|
||||
_ -> pure $ CPContactAddress (CAPOk cld ov)
|
||||
Just (RcvDirectMsgConnection Connection {connStatus} Nothing)
|
||||
| connStatus == ConnPrepared -> pure $ CPContactAddress (CAPOk contactSLinkData_)
|
||||
| connStatus == ConnPrepared -> pure $ CPContactAddress (CAPOk cld ov)
|
||||
| otherwise -> pure $ CPContactAddress CAPConnectingConfirmReconnect
|
||||
Just (RcvDirectMsgConnection _ (Just ct))
|
||||
| not (contactReady ct) && contactActive ct -> pure $ CPContactAddress (CAPConnectingProhibit ct)
|
||||
| contactDeleted ct -> pure $ CPContactAddress (CAPOk contactSLinkData_)
|
||||
| contactDeleted ct -> pure $ CPContactAddress (CAPOk cld ov)
|
||||
| otherwise -> pure $ CPContactAddress (CAPKnown ct)
|
||||
-- TODO [short links] RcvGroupMsgConnection branch is deprecated? (old group link protocol?)
|
||||
Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo Nothing Nothing
|
||||
Just (RcvGroupMsgConnection _ gInfo _) -> groupPlan gInfo Nothing Nothing Nothing
|
||||
Just _ -> throwCmdError "found connection entity is not RcvDirectMsgConnection or RcvGroupMsgConnection"
|
||||
groupJoinRequestPlan :: User -> ConnReqContact -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> CM ConnectionPlan
|
||||
groupJoinRequestPlan user (CRContactUri crData) groupSLinkInfo_ groupSLinkData_ = do
|
||||
groupJoinRequestPlan :: User -> ConnReqContact -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> Maybe OwnerVerification -> CM ConnectionPlan
|
||||
groupJoinRequestPlan user (CRContactUri crData) linkInfo gld ov = do
|
||||
let cReqSchemas = contactCReqSchemas crData
|
||||
cReqHashes = bimap contactCReqHash contactCReqHash cReqSchemas
|
||||
withFastStore' (\db -> getGroupInfoByUserContactLinkConnReq db vr user cReqSchemas) >>= \case
|
||||
@@ -4075,21 +4240,21 @@ processChatCommand vr nm = \case
|
||||
connEnt_ <- withFastStore' $ \db -> getContactConnEntityByConnReqHash db vr user cReqHashes
|
||||
gInfo_ <- withFastStore' $ \db -> getGroupInfoByGroupLinkHash db vr user cReqHashes
|
||||
case (gInfo_, connEnt_) of
|
||||
(Nothing, Nothing) -> pure $ CPGroupLink (GLPOk groupSLinkInfo_ groupSLinkData_)
|
||||
(Nothing, Nothing) -> pure $ CPGroupLink (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 _ (Just ct)))
|
||||
| not (contactReady ct) && contactActive ct -> pure $ CPGroupLink (GLPConnectingProhibit gInfo_)
|
||||
| otherwise -> pure $ CPGroupLink (GLPOk groupSLinkInfo_ groupSLinkData_)
|
||||
| otherwise -> pure $ CPGroupLink (GLPOk linkInfo gld ov)
|
||||
(Nothing, Just _) -> throwCmdError "found connection entity is not RcvDirectMsgConnection"
|
||||
(Just gInfo, _) -> groupPlan gInfo groupSLinkInfo_ groupSLinkData_
|
||||
groupPlan :: GroupInfo -> Maybe GroupShortLinkInfo -> Maybe GroupShortLinkData -> CM ConnectionPlan
|
||||
groupPlan gInfo@GroupInfo {membership} groupSLinkInfo_ groupSLinkData_
|
||||
| memberStatus membership == GSMemRejected = pure $ CPGroupLink (GLPKnown gInfo)
|
||||
(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 []))
|
||||
| not (memberActive membership) && not (memberRemoved membership) =
|
||||
pure $ CPGroupLink (GLPConnectingProhibit $ Just gInfo)
|
||||
| memberActive membership = pure $ CPGroupLink (GLPKnown gInfo)
|
||||
| otherwise = pure $ CPGroupLink (GLPOk groupSLinkInfo_ groupSLinkData_)
|
||||
| memberActive membership = pure $ CPGroupLink (GLPKnown gInfo (BoolDef False) ov (ListDef []))
|
||||
| otherwise = pure $ CPGroupLink (GLPOk linkInfo gld ov)
|
||||
contactCReqSchemas :: ConnReqUriData -> (ConnReqContact, ConnReqContact)
|
||||
contactCReqSchemas crData =
|
||||
( CRContactUri crData {crScheme = SSSimplex},
|
||||
@@ -4101,6 +4266,16 @@ processChatCommand vr nm = \case
|
||||
serverShortLink = \case
|
||||
CSLInvitation _ srv lnkId linkKey -> CSLInvitation SLSServer srv lnkId linkKey
|
||||
CSLContact _ ct srv linkKey -> CSLContact SLSServer ct srv linkKey
|
||||
verifyLinkOwner :: ConnectionModeI m => C.PublicKeyEd25519 -> [OwnerAuth] -> ConnShortLink m -> Maybe LinkOwnerSig -> Maybe OwnerVerification
|
||||
verifyLinkOwner rootKey owners connLink =
|
||||
fmap $ \LinkOwnerSig {ownerId, chatBinding = B64UrlByteString bindingBytes, ownerSig} ->
|
||||
let signedData = bindingBytes <> smpEncode connLink
|
||||
findOwner (B64UrlByteString oId) = find (\OwnerAuth {ownerId = oId'} -> oId' == oId) owners
|
||||
in case maybe (Just rootKey) (fmap ownerKey . findOwner) ownerId of
|
||||
Nothing -> OVFailed "unknown owner"
|
||||
Just key
|
||||
| C.verify' key ownerSig signedData -> OVVerified
|
||||
| otherwise -> OVFailed "signature verification failed"
|
||||
contactShortLinkData :: Profile -> Maybe AddressSettings -> UserLinkData
|
||||
contactShortLinkData p settings =
|
||||
let msg = autoReply =<< settings
|
||||
@@ -4112,7 +4287,7 @@ processChatCommand vr nm = \case
|
||||
encodeShortLinkData $ RelayAddressLinkData {relayProfile = RelayProfile {displayName, fullName, shortDescr, image}}
|
||||
updatePCCShortLinkData :: PendingContactConnection -> Profile -> CM (Maybe ShortLinkInvitation)
|
||||
updatePCCShortLinkData conn@PendingContactConnection {connLinkInv} profile =
|
||||
forM (connShortLink =<< connLinkInv) $ \_ -> do
|
||||
forM (connShortLink' =<< connLinkInv) $ \_ -> do
|
||||
let userData = contactShortLinkData profile Nothing
|
||||
userLinkData = UserInvLinkData userData
|
||||
shortenShortLink' =<< withAgent (\a -> setConnShortLink a nm (aConnId' conn) SCMInvitation userLinkData Nothing)
|
||||
@@ -4176,10 +4351,9 @@ processChatCommand vr nm = \case
|
||||
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect)))
|
||||
prepareMsgs cmsFileInvs timed_ = withFastStore $ \db ->
|
||||
forM cmsFileInvs $ \((ComposedMessage {quotedItemId, msgContent = mc}, itemForwarded, _, _), fInv_) -> do
|
||||
let base = (mcSimple mc) {file = fInv_, ttl = ttl' <$> timed_, live = justTrue live}
|
||||
case (quotedItemId, itemForwarded) of
|
||||
(Nothing, Nothing) -> pure (base, Nothing)
|
||||
(Nothing, Just _) -> pure (base {forward = Just True}, Nothing)
|
||||
(mc', quotedItem_) <- case (quotedItemId, itemForwarded) of
|
||||
(Nothing, Nothing) -> pure (mcSimple mc, Nothing)
|
||||
(Nothing, Just _) -> pure (mcForward mc, Nothing)
|
||||
(Just qiId, Nothing) -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <-
|
||||
getDirectChatItem db user contactId qiId
|
||||
@@ -4187,8 +4361,9 @@ processChatCommand vr nm = \case
|
||||
let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing}
|
||||
qmc = quoteContent mc origQmc file
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just qiId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText}
|
||||
pure (base {quote = Just QuotedMsg {msgRef, content = qmc}}, Just quotedItem)
|
||||
pure (mcQuote QuotedMsg {msgRef, content = qmc} mc, Just quotedItem)
|
||||
(Just _, Just _) -> throwError SEInvalidQuote
|
||||
pure (mc' {file = fInv_, ttl = ttl' <$> timed_, live = justTrue live}, quotedItem_)
|
||||
where
|
||||
quoteData :: ChatItem c d -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTDirect, Bool)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwError SEInvalidQuote
|
||||
@@ -4427,7 +4602,7 @@ processChatCommand vr nm = \case
|
||||
ChatRef CTDirect cId _ -> a $ SRDirect cId
|
||||
ChatRef CTGroup gId scope -> do
|
||||
gInfo <- withFastStore $ \db -> getGroupInfo db vr user gId
|
||||
a $ SRGroup gId scope (sendAsGroup' gInfo)
|
||||
a $ SRGroup gId scope (sendAsGroup' gInfo scope)
|
||||
_ -> throwCmdError "not supported"
|
||||
getSharedMsgId :: CM SharedMsgId
|
||||
getSharedMsgId = do
|
||||
@@ -4661,12 +4836,41 @@ deleteInProgressGroup user gInfo = do
|
||||
withFastStore' $ \db -> deleteGroup db user gInfo
|
||||
|
||||
runRelayGroupLinkChecks :: User -> CM ()
|
||||
runRelayGroupLinkChecks _user = do
|
||||
-- TODO [relays] relay: periodically check presence of relay link in group links of served groups
|
||||
-- TODO - retrieve group link data
|
||||
-- TODO - if relay link is present, update relay status to RSActive
|
||||
-- TODO - if relay link is absent and status was RSActive -> update to new "Removed" status?
|
||||
pure ()
|
||||
runRelayGroupLinkChecks user = do
|
||||
interval <- asks (relayChecksInterval . config)
|
||||
liftIO $ threadDelay' $ diffToMicroseconds interval
|
||||
forever $ do
|
||||
flip catchAllErrors eToView $ do
|
||||
lift waitChatStartedAndActivated
|
||||
checkRelayServedGroups
|
||||
checkRelayInactiveGroups
|
||||
liftIO $ threadDelay' $ diffToMicroseconds interval
|
||||
where
|
||||
checkRelayServedGroups = do
|
||||
vr <- chatVersionRange
|
||||
relayGroups <- withStore' $ \db -> getRelayServedGroups db vr user
|
||||
forM_ relayGroups $ \gInfo@GroupInfo {groupProfile = gp} -> flip catchAllErrors eToView $ do
|
||||
case publicGroup gp of
|
||||
Just PublicGroupProfile {groupLink = sLnk} -> do
|
||||
(_, ContactLinkData _ UserContactData {relays = relayLinks}) <-
|
||||
getShortLinkConnReq' NRMBackground user sLnk
|
||||
gLink_ <- withStore' $ \db -> runExceptT $ getGroupLink db user gInfo
|
||||
case gLink_ of
|
||||
Right GroupLink {connLinkContact = CCLink _ (Just ourLink)} ->
|
||||
if ourLink `elem` relayLinks
|
||||
then do
|
||||
-- TODO [relays] emit event to UI when relay own status promoted to RSActive
|
||||
-- CEvtGroupRelayUpdated requires GroupRelay (owner-side), not available on relay side
|
||||
void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSAccepted RSActive
|
||||
else void $ withStore' $ \db -> updateRelayOwnStatusFromTo db gInfo RSActive RSInactive
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
checkRelayInactiveGroups = do
|
||||
vr <- chatVersionRange
|
||||
ttl <- asks (relayInactiveTTL . config)
|
||||
inactiveGroups <- withStore' $ \db -> getRelayInactiveGroups db vr user ttl
|
||||
forM_ inactiveGroups $ \gInfo -> flip catchAllErrors eToView $
|
||||
deleteGroupConnections user gInfo False
|
||||
|
||||
expireChatItems :: User -> Int64 -> Bool -> CM ()
|
||||
expireChatItems user@User {userId} globalTTL sync = do
|
||||
@@ -4830,6 +5034,7 @@ chatCommandP =
|
||||
"/_reaction members " *> (APIGetReactionMembers <$> A.decimal <* " #" <*> A.decimal <* A.space <*> A.decimal <* A.space <*> (knownReaction <$?> jsonP)),
|
||||
"/_forward plan " *> (APIPlanForwardChatItems <$> chatRefP <*> _strP),
|
||||
"/_forward " *> (APIForwardChatItems <$> chatRefP <*> (" as_group=" *> onOffP <|> pure False) <* A.space <*> chatRefP <*> _strP <*> sendMessageTTLP),
|
||||
"/_share chat content " *> (APIShareChatMsgContent <$> chatRefP <* A.space <*> sendRefP),
|
||||
"/_read user " *> (APIUserRead <$> A.decimal),
|
||||
"/read user" $> UserRead,
|
||||
"/_read chat " *> (APIChatRead <$> chatRefP),
|
||||
@@ -4958,9 +5163,10 @@ chatCommandP =
|
||||
("/help" <|> "/h") $> ChatHelp HSMain,
|
||||
("/group" <|> "/g") *> (NewGroup <$> incognitoP <* A.space <* char_ '#' <*> groupProfile),
|
||||
"/_group " *> (APINewGroup <$> A.decimal <*> incognitoOnOffP <* A.space <*> jsonP),
|
||||
("/public group" <|> "/pg") *> (NewPublicGroup <$> incognitoP <* " relays=" <*> strP <* A.space <* char_ '#' <*> groupProfile),
|
||||
("/public group" <|> "/pg") *> (NewPublicGroup <$> incognitoP <* " relays=" <*> strP <* A.space <* char_ '#' <*> channelProfile),
|
||||
"/_public group " *> (APINewPublicGroup <$> A.decimal <*> incognitoOnOffP <*> _strP <* A.space <*> jsonP),
|
||||
"/_get relays #" *> (APIGetGroupRelays <$> A.decimal),
|
||||
"/_add relays #" *> (APIAddGroupRelays <$> A.decimal <*> _strP),
|
||||
("/add " <|> "/a ") *> char_ '#' *> (AddMember <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <*> (memberRole <|> pure GRMember)),
|
||||
("/join " <|> "/j ") *> char_ '#' *> (JoinGroup <$> displayNameP <*> (" mute" $> MFNone <|> pure MFAll)),
|
||||
"/accept member " *> char_ '#' *> (AcceptMember <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <*> (memberRole <|> pure GRMember)),
|
||||
@@ -5001,13 +5207,13 @@ 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)),
|
||||
"/_connect plan " *> (APIConnectPlan <$> A.decimal <* A.space <*> ((Just <$> strP) <|> A.takeTill (== ' ') $> Nothing) <*> ((" resolve=" *> onOffP) <|> pure False) <*> optional (" sig=" *> jsonP)),
|
||||
"/_prepare contact " *> (APIPrepareContact <$> A.decimal <* A.space <*> connLinkP <* A.space <*> jsonP),
|
||||
"/_prepare group " *> (APIPrepareGroup <$> A.decimal <* A.space <*> connLinkP' <*> (" direct=" *> onOffP <|> pure True) <* A.space <*> jsonP),
|
||||
"/_set contact user @" *> (APIChangePreparedContactUser <$> A.decimal <* A.space <*> A.decimal),
|
||||
"/_set group user #" *> (APIChangePreparedGroupUser <$> A.decimal <* A.space <*> A.decimal),
|
||||
"/_connect contact @" *> (APIConnectPreparedContact <$> A.decimal <*> incognitoOnOffP <*> optional (A.space *> msgContentP)),
|
||||
"/_connect group #" *> (APIConnectPreparedGroup <$> A.decimal <*> incognitoOnOffP <*> optional (A.space *> msgContentP)),
|
||||
"/_connect group #" *> (APIConnectPreparedGroup <$> A.decimal <*> incognitoOnOffP <*> optional (A.space *> ownerContactP) <*> optional (A.space *> msgContentP)),
|
||||
"/_connect " *> (APIAddContact <$> A.decimal <*> incognitoOnOffP),
|
||||
"/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> connLinkP_),
|
||||
"/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP),
|
||||
@@ -5018,6 +5224,7 @@ chatCommandP =
|
||||
ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayNameP <* A.space <* A.char '@' <*> (Just <$> displayNameP) <* A.space <*> msgTextP,
|
||||
ForwardGroupMessage <$> chatNameP <* " <- #" <*> displayNameP <*> pure Nothing <* A.space <*> msgTextP,
|
||||
ForwardLocalMessage <$> chatNameP <* " <- * " <*> msgTextP,
|
||||
"/share chat #" *> (SharePublicGroup <$> displayNameP <* A.space <*> chatNameP),
|
||||
SendMessage <$> sendNameP <* A.space <*> msgTextP,
|
||||
"@#" *> (SendMemberContactMessage <$> displayNameP <* A.space <* char_ '@' <*> displayNameP <* A.space <*> msgTextP),
|
||||
"/accept_member_contact @" *> (AcceptMemberContact <$> displayNameP),
|
||||
@@ -5087,6 +5294,7 @@ chatCommandP =
|
||||
"/set disappear @" *> (SetContactTimedMessages <$> displayNameP <*> optional (A.space *> timedMessagesEnabledP)),
|
||||
"/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
|
||||
"/set reports #" *> (SetGroupFeature (AGFNR SGFReports) <$> displayNameP <*> _strP),
|
||||
"/set support #" *> (SetGroupFeature (AGFNR SGFSupport) <$> displayNameP <*> (A.space *> strP)),
|
||||
"/set links #" *> (SetGroupFeatureRole (AGFR SGFSimplexLinks) <$> displayNameP <*> _strP <*> optional memberRole),
|
||||
"/set admission review #" *> (SetGroupMemberAdmissionReview <$> displayNameP <*> (A.space *> memberCriteriaP)),
|
||||
("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito,
|
||||
@@ -5136,6 +5344,7 @@ chatCommandP =
|
||||
((Just <$> connLinkP) <|> A.takeTill (== ' ') $> Nothing)
|
||||
incognitoP = (A.space *> ("incognito" <|> "i")) $> True <|> pure False
|
||||
incognitoOnOffP = (A.space *> "incognito=" *> onOffP) <|> pure False
|
||||
ownerContactP = "contact=" *> (GroupOwnerContact <$> A.decimal <* " owner=" <*> strP)
|
||||
imagePrefix = (<>) <$> "data:" <*> ("image/png;base64," <|> "image/jpg;base64,")
|
||||
imageP = safeDecodeUtf8 <$> ((<>) <$> imagePrefix <*> (B64.encode <$> base64P))
|
||||
chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> A.char '*' $> CTLocal <|> A.char ':' $> CTContactConnection
|
||||
@@ -5223,6 +5432,10 @@ chatCommandP =
|
||||
history = Just HistoryGroupPreference {enable = FEOn}
|
||||
}
|
||||
pure GroupProfile {displayName = gName, fullName = "", shortDescr, description = Nothing, image = Nothing, publicGroup = Nothing, groupPreferences, memberAdmission = Nothing}
|
||||
channelProfile = do
|
||||
p@GroupProfile {groupPreferences = prefs_} <- groupProfile
|
||||
let prefs = (fromMaybe emptyGroupPrefs prefs_) {support = Just SupportGroupPreference {enable = FEOff}} :: GroupPreferences
|
||||
pure p {groupPreferences = Just prefs}
|
||||
memberCriteriaP = ("all" $> Just MCAll) <|> ("off" $> Nothing)
|
||||
shortDescrP = do
|
||||
descr <- A.takeWhile1 isSpace *> (T.dropWhileEnd isSpace <$> textP) <|> pure ""
|
||||
|
||||
@@ -203,10 +203,9 @@ toggleNtf m ntfOn =
|
||||
|
||||
prepareGroupMsg :: DB.Connection -> User -> GroupInfo -> Maybe MsgScope -> Maybe MsgRef -> ShowGroupAsSender -> MsgContent -> Map MemberName MsgMention -> Maybe ChatItemId -> Maybe CIForwardedFrom -> Maybe FileInvitation -> Maybe CITimed -> Bool -> ExceptT StoreError IO (ChatMsgEvent 'Json, Maybe (CIQuote 'CTGroup))
|
||||
prepareGroupMsg db user g@GroupInfo {membership} msgScope parentRef_ showGroupAsSender mc mentions quotedItemId_ itemForwarded fInv_ timed_ live = do
|
||||
let base = (mcSimple mc) {mentions, file = fInv_, ttl = ttl' <$> timed_, live = justTrue live, scope = msgScope, asGroup = justTrue showGroupAsSender, parent = parentRef_}
|
||||
case (quotedItemId_, itemForwarded) of
|
||||
(Nothing, Nothing) -> pure (XMsgNew base, Nothing)
|
||||
(Nothing, Just _) -> pure (XMsgNew base {forward = Just True}, Nothing)
|
||||
(mc', quotedItem_) <- case (quotedItemId_, itemForwarded) of
|
||||
(Nothing, Nothing) -> pure (mcSimple mc, Nothing)
|
||||
(Nothing, Just _) -> pure (mcForward mc, Nothing)
|
||||
(Just quotedItemId, Nothing) -> do
|
||||
CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, mentions = quoteMentions, file} <-
|
||||
getGroupCIWithReactions db user g quotedItemId
|
||||
@@ -215,9 +214,10 @@ prepareGroupMsg db user g@GroupInfo {membership} msgScope parentRef_ showGroupAs
|
||||
qmc = quoteContent mc origQmc file
|
||||
(qmc', ft', _) = updatedMentionNames qmc formattedText quoteMentions
|
||||
quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc', formattedText = ft'}
|
||||
mc' = base {quote = Just QuotedMsg {msgRef, content = qmc'}}
|
||||
pure (XMsgNew mc', Just quotedItem)
|
||||
pure (mcQuote QuotedMsg {msgRef, content = qmc'} mc, Just quotedItem)
|
||||
(Just _, Just _) -> throwError SEInvalidQuote
|
||||
let mc'' = mc' {mentions = MsgMentions mentions, file = fInv_, ttl = ttl' <$> timed_, live = justTrue live, scope = msgScope, asGroup = justTrue showGroupAsSender, parent = parentRef_}
|
||||
pure (XMsgNew mc'', quotedItem_)
|
||||
where
|
||||
quoteData :: ChatItem c d -> GroupMember -> ExceptT StoreError IO (MsgContent, CIQDirection 'CTGroup, Bool, Maybe GroupMember)
|
||||
quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwError SEInvalidQuote
|
||||
@@ -338,10 +338,11 @@ quoteContent mc qmc ciFile_
|
||||
|
||||
prohibitedGroupContent :: GroupInfo -> GroupMember -> Maybe GroupChatScopeInfo -> Maybe ChannelMsgInfo -> MsgContent -> Maybe MarkdownList -> Maybe f -> Bool -> Maybe GroupFeature
|
||||
prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole = userRole}} m scopeInfo channelMsgInfo mc ft file_ sent
|
||||
| not supportAllowed = Just GFSupport
|
||||
| isVoice mc && not (groupFeatureMemberAllowed SGFVoice m gInfo) && not hostApprovalVoice = Just GFVoice
|
||||
| isNothing scopeInfo && not (isVoice mc) && isJust file_ && not (groupFeatureMemberAllowed SGFFiles m gInfo) = Just GFFiles
|
||||
| isNothing scopeInfo && isReport mc && (badReportUser || not (groupFeatureAllowed SGFReports gInfo)) = Just GFReports
|
||||
| isNothing scopeInfo && prohibitedSimplexLinks gInfo m ft = Just GFSimplexLinks
|
||||
| isNothing scopeInfo && prohibitedSimplexLinks gInfo m mc ft = Just GFSimplexLinks
|
||||
| otherwise = case channelMsgInfo of
|
||||
Just ChannelMsgInfo {channelMsgItem = CChatItem _ ChatItem {meta = CIMeta {itemDeleted, commentsDisabled}}}
|
||||
| not (useRelays' gInfo) -> Just GFComments
|
||||
@@ -351,6 +352,10 @@ prohibitedGroupContent gInfo@GroupInfo {membership = mem@GroupMember {memberRole
|
||||
| otherwise -> Nothing
|
||||
Nothing -> Nothing
|
||||
where
|
||||
supportAllowed = case scopeInfo of
|
||||
Just (GCSIMemberSupport scopeMem_) ->
|
||||
groupFeatureAllowed SGFSupport gInfo || isJust (supportChat $ fromMaybe mem scopeMem_)
|
||||
Nothing -> True
|
||||
hostApprovalVoice
|
||||
| sent = userRole >= GRAdmin && sendApprovalPhase
|
||||
| otherwise = memberCategory m == GCHostMember && hostApprovalPhase
|
||||
@@ -378,10 +383,14 @@ commentsClosed
|
||||
Nothing -> False
|
||||
commentsClosed _ Nothing _ = False
|
||||
|
||||
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> Maybe MarkdownList -> Bool
|
||||
prohibitedSimplexLinks gInfo m ft =
|
||||
prohibitedSimplexLinks :: GroupInfo -> GroupMember -> MsgContent -> Maybe MarkdownList -> Bool
|
||||
prohibitedSimplexLinks gInfo m mc ft =
|
||||
not (groupFeatureMemberAllowed SGFSimplexLinks m gInfo)
|
||||
&& maybe False (any ftIsSimplexLink) ft
|
||||
&& (isChatLink mc || maybe False (any ftIsSimplexLink) ft)
|
||||
where
|
||||
isChatLink = \case
|
||||
MCChat {} -> True
|
||||
_ -> False
|
||||
|
||||
ftIsSimplexLink :: FormattedText -> Bool
|
||||
ftIsSimplexLink FormattedText {format} = maybe False isSimplexLink format
|
||||
@@ -1045,7 +1054,7 @@ acceptBusinessJoinRequestAsync
|
||||
createJoiningMemberConnection db user uclId connIds chatV cReqChatVRange groupMemberId subMode
|
||||
let cd = CDGroupSnd gInfo Nothing
|
||||
-- TODO [short links] move to profileContactRequest?
|
||||
createInternalChatItem user cd (CISndGroupE2EEInfo E2EInfo {pqEnabled = Just PQEncOff}) Nothing
|
||||
createInternalChatItem user cd (CISndGroupE2EEInfo $ e2eInfoGroup gInfo) Nothing
|
||||
createGroupFeatureItems user cd CISndGroupFeature gInfo
|
||||
-- TODO [short links] get updated business chat group and member? (currently not used)
|
||||
pure (gInfo, clientMember)
|
||||
@@ -1320,8 +1329,8 @@ setGroupLinkData nm user gInfo gLink = do
|
||||
(conn, groupRelays) <- withFastStore $ \db ->
|
||||
(,) <$> getGroupLinkConnection db vr user gInfo <*> liftIO (getConnectedGroupRelays db gInfo)
|
||||
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
|
||||
tagShortLink = if useRelays' gInfo then toShortChannelLink else toShortGroupLink
|
||||
sLnk <- shortenShortLink' . tagShortLink =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData))
|
||||
linkType = if useRelays' gInfo then CCTChannel else CCTGroup
|
||||
sLnk <- shortenShortLink' . setShortLinkType_ linkType =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData))
|
||||
withFastStore' $ \db -> setGroupLinkShortLink db gLink sLnk
|
||||
|
||||
setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
|
||||
@@ -1332,6 +1341,18 @@ setGroupLinkDataAsync user gInfo gLink = do
|
||||
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
|
||||
gVar <- asks random
|
||||
relayMember@GroupMember {activeConn} <- withFastStore $ \db -> getCreateRelayForMember db vr gVar user gInfo relayLink
|
||||
case activeConn of
|
||||
Just _ -> pure ()
|
||||
Nothing -> do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
newConnIds <- getAgentConnShortLinkAsync user CFGetRelayDataJoin Nothing relayLink
|
||||
withFastStore' $ \db -> createRelayMemberConnectionAsync db user gInfo relayMember relayLink newConnIds subMode
|
||||
|
||||
updatePublicGroupData :: User -> GroupInfo -> CM GroupInfo
|
||||
updatePublicGroupData user gInfo
|
||||
| useRelays' gInfo && memberRole' (membership gInfo) == GROwner = do
|
||||
@@ -1344,29 +1365,58 @@ updatePublicGroupData user gInfo
|
||||
pure 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
|
||||
vr <- chatVersionRange
|
||||
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
|
||||
_ -> pure g
|
||||
pure (g', profileChanged)
|
||||
| otherwise = pure (gInfo, False)
|
||||
where
|
||||
profileChanged = p /= groupProfile
|
||||
countChanged = case publicGroupData of
|
||||
Just PublicGroupData {publicMemberCount} -> Just publicMemberCount /= localCount
|
||||
_ -> False
|
||||
|
||||
-- TODO [relays] owner: set owners on updating link data (multi-owner)
|
||||
groupLinkData :: GroupInfo -> GroupLink -> [GroupRelay] -> (UserConnLinkData 'CMContact, CRClientData)
|
||||
groupLinkData gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {publicMemberCount}} GroupLink {groupLinkId} groupRelays =
|
||||
groupLinkData gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {publicMemberCount}, membership = GroupMember {memberId}, groupKeys} GroupLink {groupLinkId} groupRelays =
|
||||
let direct = not $ useRelays' gInfo
|
||||
relays = mapMaybe (\GroupRelay {relayLink} -> relayLink) groupRelays
|
||||
publicGroupData_ = PublicGroupData <$> publicMemberCount
|
||||
userData = encodeShortLinkData $ GroupShortLinkData {groupProfile, publicGroupData = publicGroupData_}
|
||||
userLinkData = UserContactLinkData UserContactData {direct, owners = [], relays, userData}
|
||||
owners = case groupKeys of
|
||||
Just GroupKeys {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey} ->
|
||||
let ownerId = unMemberId memberId
|
||||
ownerKey = C.publicKey memberPrivKey
|
||||
authOwnerSig = C.sign' rootPrivKey (ownerId <> C.encodePubKey ownerKey)
|
||||
in [OwnerAuth {ownerId, ownerKey, authOwnerSig}]
|
||||
_ -> []
|
||||
userLinkData = UserContactLinkData UserContactData {direct, owners, relays, userData}
|
||||
crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
in (userLinkData, crClientData)
|
||||
|
||||
restoreShortLink' :: ConnShortLink m -> CM (ConnShortLink m)
|
||||
restoreShortLink' l = (`restoreShortLink` l) <$> asks (shortLinkPresetServers . config)
|
||||
|
||||
getShortLinkConnReq :: NetworkRequestMode -> User -> ConnShortLink m -> CM (FixedLinkData m, ConnLinkData m)
|
||||
getShortLinkConnReq nm user@User {userChatRelay} l = do
|
||||
getShortLinkConnReq' :: NetworkRequestMode -> User -> ConnShortLink m -> CM (FixedLinkData m, ConnLinkData m)
|
||||
getShortLinkConnReq' nm user l = do
|
||||
l' <- restoreShortLink' l
|
||||
(fd, cData) <- withAgent $ \a -> getConnShortLink a nm (aUserId user) l'
|
||||
withAgent $ \a -> getConnShortLink a nm (aUserId user) l'
|
||||
|
||||
getShortLinkConnReq :: NetworkRequestMode -> User -> ConnShortLink m -> CM (FixedLinkData m, ConnLinkData m)
|
||||
getShortLinkConnReq nm user l = do
|
||||
(fd, cData) <- getShortLinkConnReq' nm user l
|
||||
case cData of
|
||||
ContactLinkData _ UserContactData {direct, relays}
|
||||
| not supported -> throwChatError CEUnsupportedConnReq
|
||||
where
|
||||
supported = direct || not (null relays) || isTrue userChatRelay
|
||||
supported = direct || not (null relays)
|
||||
_ -> pure ()
|
||||
pure (fd, cData)
|
||||
|
||||
@@ -1400,27 +1450,6 @@ shortenShortLink' l = (`shortenShortLink` l) <$> asks (shortLinkPresetServers .
|
||||
shortenCreatedLink :: CreatedConnLink m -> CM (CreatedConnLink m)
|
||||
shortenCreatedLink (CCLink cReq sLnk) = CCLink cReq <$> mapM shortenShortLink' sLnk
|
||||
|
||||
createdGroupLink :: CreatedLinkContact -> CreatedLinkContact
|
||||
createdGroupLink (CCLink cReq shortLink) = CCLink cReq (toShortGroupLink <$> shortLink)
|
||||
|
||||
toShortGroupLink :: ShortLinkContact -> ShortLinkContact
|
||||
toShortGroupLink (CSLContact sch _ srv k) = CSLContact sch CCTGroup srv k
|
||||
|
||||
createdChannelLink :: CreatedLinkContact -> CreatedLinkContact
|
||||
createdChannelLink (CCLink cReq shortLink) = CCLink cReq (toShortChannelLink <$> shortLink)
|
||||
|
||||
toShortChannelLink :: ShortLinkContact -> ShortLinkContact
|
||||
toShortChannelLink (CSLContact sch _ srv k) = CSLContact sch CCTChannel srv k
|
||||
|
||||
createdRelayLink :: CreatedLinkContact -> CreatedLinkContact
|
||||
createdRelayLink (CCLink cReq shortLink) = CCLink cReq (toShortRelayLink <$> shortLink)
|
||||
|
||||
toShortRelayLink :: ShortLinkContact -> ShortLinkContact
|
||||
toShortRelayLink (CSLContact sch _ srv k) = CSLContact sch CCTRelay srv k
|
||||
|
||||
toShortLinkContact :: CreatedLinkContact -> Maybe ShortLinkContact
|
||||
toShortLinkContact (CCLink _cReq sLink) = sLink
|
||||
|
||||
deleteGroupLink' :: User -> GroupInfo -> CM ()
|
||||
deleteGroupLink' user gInfo = do
|
||||
vr <- chatVersionRange
|
||||
@@ -1493,7 +1522,7 @@ createContactPQSndItem :: User -> Contact -> Connection -> PQEncryption -> CM (C
|
||||
createContactPQSndItem user ct conn@Connection {pqSndEnabled} pqSndEnabled' =
|
||||
flip catchAllErrors (const $ pure (ct, conn)) $ case (pqSndEnabled, pqSndEnabled') of
|
||||
(Just b, b') | b' /= b -> createPQItem $ CISndConnEvent (SCEPqEnabled pqSndEnabled')
|
||||
(Nothing, PQEncOn) -> createPQItem $ CISndDirectE2EEInfo (E2EInfo $ Just pqSndEnabled')
|
||||
(Nothing, PQEncOn) -> createPQItem $ CISndDirectE2EEInfo (e2eInfoEncrypted $ Just pqSndEnabled')
|
||||
_ -> pure (ct, conn)
|
||||
where
|
||||
createPQItem ciContent = do
|
||||
@@ -1508,7 +1537,7 @@ updateContactPQRcv :: User -> Contact -> Connection -> PQEncryption -> CM (Conta
|
||||
updateContactPQRcv user ct conn@Connection {connId, pqRcvEnabled} pqRcvEnabled' =
|
||||
flip catchAllErrors (const $ pure (ct, conn)) $ case (pqRcvEnabled, pqRcvEnabled') of
|
||||
(Just b, b') | b' /= b -> updatePQ $ CIRcvConnEvent (RCEPqEnabled pqRcvEnabled')
|
||||
(Nothing, PQEncOn) -> updatePQ $ CIRcvDirectE2EEInfo (E2EInfo $ Just pqRcvEnabled')
|
||||
(Nothing, PQEncOn) -> updatePQ $ CIRcvDirectE2EEInfo (e2eInfoEncrypted $ Just pqRcvEnabled')
|
||||
_ -> pure (ct, conn)
|
||||
where
|
||||
updatePQ ciContent = do
|
||||
@@ -1811,9 +1840,12 @@ deleteOrUpdateMemberRecord user gInfo m =
|
||||
deleteOrUpdateMemberRecordIO :: DB.Connection -> User -> GroupInfo -> GroupMember -> IO GroupInfo
|
||||
deleteOrUpdateMemberRecordIO db user@User {userId} gInfo m = do
|
||||
(gInfo', m') <- deleteSupportChatIfExists db user gInfo m
|
||||
checkGroupMemberHasItems db user m' >>= \case
|
||||
Just _ -> updateGroupMemberStatus db userId m' GSMemRemoved
|
||||
Nothing -> deleteGroupMember db user m'
|
||||
if isRelay m'
|
||||
then deleteGroupMember db user m'
|
||||
else
|
||||
checkGroupMemberHasItems db user m' >>= \case
|
||||
Just _ -> updateGroupMemberStatus db userId m' GSMemRemoved
|
||||
Nothing -> deleteGroupMember db user m'
|
||||
pure gInfo'
|
||||
|
||||
updateMemberRecordDeleted :: User -> GroupInfo -> GroupMember -> GroupMemberStatus -> CM GroupInfo
|
||||
@@ -1821,8 +1853,15 @@ updateMemberRecordDeleted user@User {userId} gInfo m newStatus =
|
||||
withStore' $ \db -> do
|
||||
(gInfo', m') <- deleteSupportChatIfExists db user gInfo m
|
||||
updateGroupMemberStatus db userId m' newStatus
|
||||
deactivateRelay_ db m
|
||||
pure gInfo'
|
||||
|
||||
deactivateRelay_ :: DB.Connection -> GroupMember -> IO ()
|
||||
deactivateRelay_ db m =
|
||||
when (isRelay m) $ do
|
||||
relay_ <- runExceptT $ getGroupRelayByGMId db (groupMemberId' m)
|
||||
forM_ relay_ $ \relay -> void $ updateRelayStatus db relay RSInactive
|
||||
|
||||
deleteSupportChatIfExists :: DB.Connection -> User -> GroupInfo -> GroupMember -> IO (GroupInfo, GroupMember)
|
||||
deleteSupportChatIfExists db user gInfo m = do
|
||||
gInfo' <-
|
||||
|
||||
@@ -37,7 +37,7 @@ import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1)
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as V4
|
||||
import Data.Word (Word32)
|
||||
@@ -77,7 +77,7 @@ import Simplex.Messaging.Agent.Client (getAgentWorker, temporaryOrHostError, wai
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Worker (..))
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
|
||||
import Simplex.Messaging.Agent.RetryInterval (withRetryInterval)
|
||||
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Client (NetworkRequestMode (..), ProxyClientError (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
@@ -94,8 +94,9 @@ import Simplex.Messaging.Transport (TransportError (..))
|
||||
import Simplex.Messaging.Util
|
||||
import Simplex.Messaging.Version
|
||||
import qualified System.FilePath as FP
|
||||
import System.Mem.Weak (Weak)
|
||||
import Text.Read (readMaybe)
|
||||
import UnliftIO.Concurrent (forkIO)
|
||||
import UnliftIO.Concurrent (ThreadId, forkIO, mkWeakThreadId)
|
||||
import UnliftIO.Directory
|
||||
import UnliftIO.STM
|
||||
|
||||
@@ -493,7 +494,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
Left e -> do
|
||||
atomically $ modifyTVar' tags ("error" :)
|
||||
logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e
|
||||
eToView (ChatError . CEException $ "error parsing chat message: " <> e)
|
||||
createInternalChatItem user (CDDirectRcv ct') (CIRcvMsgError $ RMEParseError $ T.pack e) Nothing
|
||||
`catchAllErrors` \_ -> pure ()
|
||||
withRcpt <- checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent
|
||||
pure (withRcpt, False)
|
||||
where
|
||||
@@ -589,7 +591,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- [incognito] print incognito profile used for this contact
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
toView $ CEvtContactConnected user ct' (fmap fromLocalProfile incognitoProfile)
|
||||
let createE2EItem = createInternalChatItem user (CDDirectRcv ct') (CIRcvDirectE2EEInfo $ E2EInfo $ Just pqEnc) Nothing
|
||||
let createE2EItem = createInternalChatItem user (CDDirectRcv ct') (CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ Just pqEnc) Nothing
|
||||
-- TODO [short links] get contact request by contactRequestId, check encryption (UserContactRequest.pqSupport)?
|
||||
when (directOrUsed ct') $ case (preparedContact ct', contactRequestId' ct') of
|
||||
(Nothing, Nothing) -> do
|
||||
@@ -687,6 +689,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- error cannot be AUTH error here
|
||||
updateDirectItemsStatusMsgs ct conn (L.toList msgIds) (CISSndError $ agentSndError err)
|
||||
eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity)
|
||||
ERR (AGENT (A_DUPLICATE (Just DroppedMsg {brokerTs, attempts}))) ->
|
||||
createInternalChatItem user (CDDirectRcv ct) (CIRcvMsgError $ RMEDropped attempts) (Just brokerTs)
|
||||
ERR err -> do
|
||||
eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity)
|
||||
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
||||
@@ -839,7 +843,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
firstConnectedHost
|
||||
( do
|
||||
let cd = CDGroupRcv gInfo'' scopeInfo m''
|
||||
createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = Just PQEncOff}) Nothing
|
||||
createInternalChatItem user cd (CIRcvGroupE2EEInfo $ e2eInfoGroup gInfo'') Nothing
|
||||
let prepared = preparedGroup gInfo''
|
||||
unless (isJust prepared) $ createGroupFeatureItems user cd CIRcvGroupFeature gInfo''
|
||||
memberConnectedChatItem gInfo'' scopeInfo m''
|
||||
@@ -927,7 +931,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
newDeliveryTasks <- reverse <$> foldM (processAChatMsg gInfo' scopeInfo m' tags eInfo) [] aChatMsgs
|
||||
shouldDelConns <-
|
||||
if isUserGrpFwdRelay gInfo' && not (blockedByAdmin m)
|
||||
then createDeliveryTasks gInfo' m' newDeliveryTasks
|
||||
then
|
||||
let tasks
|
||||
| relayOwnStatus gInfo' == Just RSInactive = filter relayRemovedNewTask newDeliveryTasks
|
||||
| otherwise = newDeliveryTasks
|
||||
in createDeliveryTasks gInfo' m' tasks
|
||||
else pure False
|
||||
withRcpt <- checkSendRcpt $ rights aChatMsgs
|
||||
pure (withRcpt, shouldDelConns)
|
||||
@@ -962,7 +970,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
Left e -> do
|
||||
atomically $ modifyTVar' tags ("error" :)
|
||||
logInfo $ "group msg=error " <> eInfo <> " " <> tshow e
|
||||
eToView (ChatError . CEException $ "error parsing chat message: " <> e)
|
||||
if isRelay membership
|
||||
then
|
||||
eToView (ChatError . CEException $ "error parsing chat message: " <> e)
|
||||
else
|
||||
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo m') (CIRcvMsgError $ RMEParseError $ T.pack e) Nothing
|
||||
`catchAllErrors` \_ -> pure ()
|
||||
pure newDeliveryTasks
|
||||
processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> VerifiedMsg e -> CM (Maybe NewMessageDeliveryTask)
|
||||
processEvent gInfo' m' verifiedMsg = do
|
||||
@@ -1000,6 +1013,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
XInfo p -> fmap ctx <$> xInfoMember gInfo' m'' p msg brokerTs
|
||||
XGrpLinkMem p -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p
|
||||
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs
|
||||
XGrpRelayNew rl -> fmap ctx <$> xGrpRelayNew gInfo' m'' rl
|
||||
XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs
|
||||
XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_
|
||||
XGrpMemInv memId introInv -> Nothing <$ xGrpMemInv gInfo' m'' memId introInv
|
||||
@@ -1035,6 +1049,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
where
|
||||
aChatMsgHasReceipt (APMsg _ (ParsedMsg _ _ ChatMessage {chatMsgEvent})) =
|
||||
hasDeliveryReceipt (toCMEventTag chatMsgEvent)
|
||||
relayRemovedNewTask :: NewMessageDeliveryTask -> Bool
|
||||
relayRemovedNewTask NewMessageDeliveryTask {taskContext = DeliveryTaskContext {jobScope}} = isRelayRemoved jobScope
|
||||
createDeliveryTasks :: GroupInfo -> GroupMember -> [NewMessageDeliveryTask] -> CM ShouldDeleteGroupConns
|
||||
createDeliveryTasks gInfo'@GroupInfo {groupId = gId} m' newDeliveryTasks = do
|
||||
let relayRemovedTask_ = find (\NewMessageDeliveryTask {taskContext = DeliveryTaskContext {jobScope}} -> isRelayRemoved jobScope) newDeliveryTasks
|
||||
@@ -1183,6 +1199,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
withStore' $ \db -> forM_ msgIds $ \msgId ->
|
||||
updateGroupItemsErrorStatus db msgId (groupMemberId' m) newStatus `catchAll_` pure ()
|
||||
eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity)
|
||||
ERR err@(AGENT (A_DUPLICATE (Just DroppedMsg {brokerTs, attempts})))
|
||||
| isRelay membership ->
|
||||
eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity)
|
||||
| otherwise -> do
|
||||
(gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m
|
||||
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo m') (CIRcvMsgError $ RMEDropped attempts) (Just brokerTs)
|
||||
ERR err -> do
|
||||
eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity)
|
||||
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
||||
@@ -1287,25 +1309,48 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
CFSetShortLink ->
|
||||
case (ucGroupId_, auData) of
|
||||
(Just groupId, UserContactLinkData UserContactData {relays = relayLinks}) -> do
|
||||
(gInfo, gLink, relays, relaysChanged) <- withStore $ \db -> do
|
||||
(gInfo, gLink, relays, relaysChanged, newlyActiveLinks) <- withStore $ \db -> do
|
||||
gInfo <- getGroupInfo db vr user groupId
|
||||
gLink <- getGroupLink db user gInfo
|
||||
relays <- liftIO $ getGroupRelays db gInfo
|
||||
(relays', changed) <- liftIO $ foldrM (updateRelay db) ([], False) relays
|
||||
(relays', changed, newlyActive) <- liftIO $ foldrM (updateRelay db) ([], False, []) relays
|
||||
liftIO $ setGroupInProgressDone db gInfo
|
||||
pure (gInfo, gLink, relays', changed)
|
||||
pure (gInfo, gLink, relays', changed, newlyActive)
|
||||
toView $ CEvtGroupLinkDataUpdated user gInfo gLink relays relaysChanged
|
||||
let GroupSummary {publicMemberCount} = groupSummary gInfo
|
||||
-- Owner is counted in publicMemberCount; > 1 means at least one subscriber.
|
||||
-- TODO [relays] multi-owner: with N owners, threshold should be > N (or use a
|
||||
-- dedicated subscriber count).
|
||||
when (fromMaybe 0 publicMemberCount > 1) $
|
||||
forM_ (L.nonEmpty newlyActiveLinks) $ \newlyActive -> do
|
||||
allRelayMembers <- withFastStore' $ \db -> getGroupRelayMembers db vr user gInfo
|
||||
let recipients =
|
||||
filter
|
||||
(\GroupMember {memberStatus, relayLink} ->
|
||||
memberStatus == GSMemConnected && relayLink `notElem` map Just newlyActiveLinks)
|
||||
allRelayMembers
|
||||
events = XGrpRelayNew <$> newlyActive
|
||||
unless (null recipients) $
|
||||
void $ sendGroupMessages user gInfo Nothing False recipients events
|
||||
where
|
||||
-- TODO [relays] owner: on relay deletion (link absent from relayLinks)
|
||||
-- TODO move status RSActive to new "Removed" status / remove relay record
|
||||
updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool) -> IO ([GroupRelay], Bool)
|
||||
updateRelay db relay@GroupRelay {relayLink, relayStatus} (acc, changed) =
|
||||
updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool, [ShortLinkContact]) -> IO ([GroupRelay], Bool, [ShortLinkContact])
|
||||
updateRelay db relay@GroupRelay {relayLink, relayStatus} (acc, changed, newlyActive) =
|
||||
case relayLink of
|
||||
Just rLink
|
||||
| rLink `elem` relayLinks && relayStatus == RSAccepted -> do
|
||||
relay' <- updateRelayStatus db relay RSActive
|
||||
pure (relay' : acc, True)
|
||||
_ -> pure (relay : acc, changed)
|
||||
pure (relay' : acc, True, rLink : newlyActive)
|
||||
| rLink `elem` relayLinks -> pure (relay : acc, changed, newlyActive)
|
||||
| relayStatus == RSActive -> do
|
||||
-- Relay link absent from link data — deactivate.
|
||||
-- RSAccepted relays are not deactivated: their own link data update
|
||||
-- may not have been processed yet (race with concurrent relay connections).
|
||||
-- TODO [relays] multi-owner: Another owner removing a relay updates link data on
|
||||
-- TODO the SMP server, but this owner won't receive a LINK callback for it
|
||||
-- TODO (LINK only fires in response to own setConnShortLink calls).
|
||||
relay' <- updateRelayStatus db relay RSInactive
|
||||
pure (relay' : acc, True, newlyActive)
|
||||
_ -> pure (relay : acc, changed, newlyActive)
|
||||
_ -> throwChatError $ CECommandError "LINK event expected for a group link only"
|
||||
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
|
||||
MERR _ err -> do
|
||||
@@ -1347,7 +1392,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
upsertDirectRequestItem cd (requestMsg_, prevSharedMsgId_)
|
||||
Nothing -> do
|
||||
void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart)
|
||||
let e2eContent = CIRcvDirectE2EEInfo $ E2EInfo $ Just $ CR.pqSupportToEnc $ reqPQSup
|
||||
let e2eContent = CIRcvDirectE2EEInfo $ e2eInfoEncrypted $ Just $ CR.pqSupportToEnc $ reqPQSup
|
||||
void $ createChatItem user cd False e2eContent Nothing Nothing
|
||||
void $ createFeatureEnabledItems_ user ct
|
||||
forM_ (autoReply addressSettings) $ \mc -> forM_ welcomeSharedMsgId $ \sharedMsgId ->
|
||||
@@ -1483,7 +1528,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
toViewTE $ TERejectingGroupJoinRequestMember user gInfo mem rjctReason
|
||||
xGrpRelayInv :: InvitationId -> VersionRangeChat -> GroupRelayInvitation -> CM ()
|
||||
xGrpRelayInv invId chatVRange groupRelayInv = do
|
||||
(_gInfo, _ownerMember) <- withStore $ \db -> createRelayRequestGroup db vr user groupRelayInv invId chatVRange
|
||||
initialDelay <- asks $ initialInterval . relayRequestRetryInterval . config
|
||||
(_gInfo, _ownerMember) <- withStore $ \db -> createRelayRequestGroup db vr user groupRelayInv invId chatVRange initialDelay
|
||||
lift $ void $ getRelayRequestWorker True
|
||||
xGrpRelayTest :: InvitationId -> VersionRangeChat -> ByteString -> CM ()
|
||||
xGrpRelayTest invId chatVRange challenge = do
|
||||
@@ -1517,12 +1563,18 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
muteEventInChannel :: GroupInfo -> GroupMember -> Bool
|
||||
muteEventInChannel gInfo@GroupInfo {membership} m =
|
||||
useRelays' gInfo && memberRole' membership < GRModerator && not (isRelay membership) && memberRole' m < GRModerator
|
||||
useRelays' gInfo
|
||||
&& not (isRelay membership) -- relay users see all events
|
||||
&& not (isRelay m) -- relay events (e.g. leave) are visible to all
|
||||
&& memberRole' membership < GRModerator
|
||||
&& memberRole' m < GRModerator
|
||||
|
||||
memberCanSend :: Maybe GroupMember -> Maybe MsgScope -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext)
|
||||
memberCanSend Nothing _ a = a -- channel message - was previously checked and allowed by relay
|
||||
memberCanSend (Just m@GroupMember {memberRole}) msgScope a = case msgScope of
|
||||
Just MSMember {} -> a
|
||||
Just (MSMember mId)
|
||||
| sameMemberId mId m || memberRole >= GRModerator -> a
|
||||
| otherwise -> messageError "member is not allowed to send to this support chat" $> Nothing
|
||||
Nothing
|
||||
| memberRole >= GRAuthor || memberPending m -> a
|
||||
| otherwise -> messageError "member is not allowed to send messages" $> Nothing
|
||||
@@ -1717,7 +1769,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
|
||||
newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
let MsgContainer {content, file = fInv_, ttl = itemTTL, live = live_} = mc
|
||||
let MsgContainer {content = c, file = fInv_, ttl = itemTTL, live = live_} = mc
|
||||
content <- case c of
|
||||
MCChat {text, chatLink, ownerSig = Just LinkOwnerSig {chatBinding = B64UrlByteString binding}} -> do
|
||||
keepSig <- case contactConn ct of
|
||||
Nothing -> pure False
|
||||
Just conn -> do
|
||||
adHash <- withAgent (`getConnectionRatchetAdHash` aConnId conn)
|
||||
pure $ encodeChatBinding CBDirect adHash == binding
|
||||
pure $ if keepSig then c else MCChat {text, chatLink, ownerSig = Nothing}
|
||||
_ -> pure c
|
||||
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
|
||||
-- case content of
|
||||
-- MCText "hello 111" ->
|
||||
@@ -1814,13 +1875,19 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- This patches initial sharedMsgId into chat item when locally deleted chat item
|
||||
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
|
||||
-- Chat item and update message which created it will have different sharedMsgId in this case...
|
||||
let timed_ = rcvContactCITimed ct ttl
|
||||
ts = ciContentTexts content
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing Nothing timed_ live M.empty
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateDirectChatItem' db user contactId ci content True live Nothing Nothing
|
||||
toView $ CEvtChatItemUpdated user (AChatItem SCTDirect SMDRcv cInfo ci')
|
||||
if isVoice mc && not (featureAllowed SCFVoice forContact ct)
|
||||
then do
|
||||
let ciContent = ciContentNoParse $ CIRcvChatFeatureRejected CFVoice
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs ciContent Nothing Nothing Nothing False M.empty
|
||||
toView $ CEvtChatItemUpdated user (AChatItem SCTDirect SMDRcv cInfo ci)
|
||||
else do
|
||||
let timed_ = rcvContactCITimed ct ttl
|
||||
ts = ciContentTexts content
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing Nothing timed_ live M.empty
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateDirectChatItem' db user contactId ci content True live Nothing Nothing
|
||||
toView $ CEvtChatItemUpdated user (AChatItem SCTDirect SMDRcv cInfo ci')
|
||||
where
|
||||
brokerTs = metaBrokerTs msgMeta
|
||||
content = CIRcvMsgContent mc
|
||||
@@ -1976,7 +2043,16 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo Nothing (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
|
||||
timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL
|
||||
live' = fromMaybe False live_
|
||||
MsgContainer {content, mentions, file = fInv_, ttl = itemTTL, live = live_, scope = msgScope_, asGroup = asGroup_, parent = parent_} = mc
|
||||
MsgContainer {content = c, mentions = MsgMentions mentions, file = fInv_, ttl = itemTTL, live = live_, scope = msgScope_, asGroup = asGroup_, parent = parent_} = mc
|
||||
content = case c of
|
||||
MCChat {text, chatLink, ownerSig = Just LinkOwnerSig {chatBinding = B64UrlByteString binding}} -> case publicGroup of
|
||||
Just pgp | maybe False (binding ==) (expectedBinding pgp) -> c
|
||||
_ -> MCChat {text, chatLink, ownerSig = Nothing}
|
||||
_ -> c
|
||||
expectedBinding PublicGroupProfile {publicGroupId}
|
||||
| sentAsGroup = Just $ encodeChatBinding CBChannel (smpEncode publicGroupId)
|
||||
| otherwise = (\GroupMember {memberId} -> encodeChatBinding CBGroup (smpEncode (publicGroupId, memberId))) <$> m_
|
||||
GroupInfo {groupProfile = GroupProfile {publicGroup}} = gInfo
|
||||
sentAsGroup = asGroup_ == Just True
|
||||
ts@(_, ft_) = msgContentTexts content
|
||||
-- Resolve the parent post (if any) referenced by this message's container.
|
||||
@@ -2029,7 +2105,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let fileMember_ = if sentAsGroup then Nothing else m'
|
||||
in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_
|
||||
newChatItem gInfo' m' scopeInfo channelMsgInfo'_ ciContent ciFile_ timed live = do
|
||||
let mentions' = if maybe False memberBlocked m' then [] else mentions
|
||||
let mentions' = if maybe False memberBlocked m' then M.empty else mentions
|
||||
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo channelMsgInfo'_ ciContent ciFile_ timed live mentions'
|
||||
ci' <- maybe (pure ci) (\m -> blockedMemberCI gInfo' m ci) m'
|
||||
let memberId_ = memberId' <$> m'
|
||||
@@ -2038,7 +2114,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
|
||||
groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> Maybe Bool -> Maybe MsgPrefs -> CM (Maybe DeliveryTaskContext)
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ asGroup_ prefs_
|
||||
| Just m <- m_, prohibitedSimplexLinks gInfo m ft_ =
|
||||
| Just m <- m_, prohibitedSimplexLinks gInfo m mc ft_ =
|
||||
messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing
|
||||
| otherwise = do
|
||||
updateRcvChatItem `catchCINotFound` \_ -> do
|
||||
@@ -2059,15 +2135,22 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
(gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_
|
||||
pure (gInfo', CDGroupRcv gInfo' scopeInfo m', mentions', scopeInfo)
|
||||
Nothing -> pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing)
|
||||
(ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs (content, ts) Nothing Nothing timed_ live mentions'
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateGroupChatItem db user groupId ci content True live Nothing
|
||||
ci'' <- case chatDir of
|
||||
CDGroupRcv gi' _ m' -> blockedMemberCI gi' m' ci'
|
||||
CDChannelRcv {} -> pure ci'
|
||||
toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv cInfo ci'')
|
||||
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo showGroupAsSender
|
||||
case m_ >>= \m -> prohibitedGroupContent gInfo' m scopeInfo Nothing mc ft_ (Nothing :: Maybe String) False of
|
||||
Just f -> do
|
||||
let ciContent = ciContentNoParse $ CIRcvGroupFeatureRejected f
|
||||
(ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs ciContent Nothing Nothing Nothing False M.empty
|
||||
groupMsgToView cInfo ci
|
||||
pure Nothing
|
||||
Nothing -> do
|
||||
(ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs (content, ts) Nothing Nothing timed_ live mentions'
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateGroupChatItem db user groupId ci content True live Nothing
|
||||
ci'' <- case chatDir of
|
||||
CDGroupRcv gi' _ m' -> blockedMemberCI gi' m' ci'
|
||||
CDChannelRcv {} -> pure ci'
|
||||
toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv cInfo ci'')
|
||||
pure $ Just $ infoToDeliveryContext gInfo' scopeInfo showGroupAsSender
|
||||
where
|
||||
content = CIRcvMsgContent mc
|
||||
ts@(_, ft_) = msgContentTexts mc
|
||||
@@ -2134,7 +2217,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
in case sndMemberId_ of
|
||||
-- regular deletion
|
||||
Nothing
|
||||
| sameMemberId memberId mem && rcvItemDeletable ci brokerTs ->
|
||||
| sameMemberId memberId mem && (publicGroupItemDeletable mem || rcvItemDeletable ci brokerTs) ->
|
||||
delete cci False Nothing
|
||||
| otherwise ->
|
||||
messageError "x.msg.del: member attempted invalid message delete" $> Nothing
|
||||
@@ -2170,6 +2253,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
messageError ("x.msg.del: channel message not found, " <> tshow e) $> Nothing
|
||||
where
|
||||
isOwner = maybe True (\m -> memberRole' m == GROwner) m_
|
||||
publicGroupItemDeletable mem = useRelays' gInfo && memberRole' mem >= GRModerator
|
||||
RcvMessage {msgId} = rcvMsg
|
||||
findItem = do
|
||||
let tryMemberLookup mId =
|
||||
@@ -2546,7 +2630,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
-- create item in both scopes
|
||||
let gInfo' = gInfo {membership = membership'}
|
||||
cd = CDGroupRcv gInfo' Nothing m
|
||||
createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = Just PQEncOff}) Nothing
|
||||
createInternalChatItem user cd (CIRcvGroupE2EEInfo $ e2eInfoGroup gInfo') Nothing
|
||||
let prepared = preparedGroup gInfo'
|
||||
unless (isJust prepared) $ createGroupFeatureItems user cd CIRcvGroupFeature gInfo'
|
||||
let welcomeMsgId_ = (\PreparedGroup {welcomeSharedMsgId = mId} -> mId) <$> preparedGroup gInfo'
|
||||
@@ -2616,10 +2700,18 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
BCCustomer -> customerId == memberId
|
||||
createProfileUpdatedItem m' (msg, brokerTs) = do
|
||||
(gInfo', m'', scopeInfo) <- mkGroupChatScope gInfo m'
|
||||
let ciContent = CIRcvGroupEvent $ RGEMemberProfileUpdated (fromLocalProfile p) p'
|
||||
cd = CDGroupRcv gInfo' scopeInfo m''
|
||||
(ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs ciContent
|
||||
groupMsgToView cInfo ci
|
||||
let createItem scopeInfo_ m_ = do
|
||||
let ciContent = CIRcvGroupEvent $ RGEMemberProfileUpdated (fromLocalProfile p) p'
|
||||
cd = CDGroupRcv gInfo' scopeInfo_ m_
|
||||
(ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs ciContent
|
||||
groupMsgToView cInfo ci
|
||||
case scopeInfo of
|
||||
Just _ -> createItem scopeInfo m''
|
||||
Nothing
|
||||
| useRelays' gInfo' && not (isRelay m'') && memberRole' m'' < GRModerator ->
|
||||
forM_ (supportChat m'') $ \_ ->
|
||||
createItem (Just GCSIMemberSupport {groupMember_ = Just m''}) m''
|
||||
| otherwise -> createItem Nothing m''
|
||||
|
||||
xInfoProbe :: ContactOrMember -> Probe -> CM ()
|
||||
xInfoProbe cgm2 probe = do
|
||||
@@ -2917,13 +3009,19 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
GCHostMember ->
|
||||
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
||||
Right existingMember
|
||||
| useRelays' gInfo ->
|
||||
void $ withStore $ \db -> updatePreparedChannelMember db vr user existingMember memInfo
|
||||
| useRelays' gInfo -> do
|
||||
updatedMember <- withStore $ \db -> updatePreparedChannelMember db vr user existingMember memInfo
|
||||
toView $ CEvtGroupMemberUpdated user gInfo existingMember updatedMember
|
||||
| otherwise ->
|
||||
messageError "x.grp.mem.intro ignored: member already exists"
|
||||
Left _
|
||||
| useRelays' gInfo ->
|
||||
void $ withStore $ \db -> createIntroReMember db user gInfo memInfo memRestrictions
|
||||
| useRelays' gInfo -> do
|
||||
-- owner key must only come from link data, not from relay intro
|
||||
let memInfo' = case memInfo of
|
||||
MemberInfo mId mRole v p _
|
||||
| mRole == GROwner -> MemberInfo mId mRole v p Nothing
|
||||
_ -> memInfo
|
||||
void $ withStore $ \db -> createIntroReMember db user gInfo memInfo' memRestrictions
|
||||
| otherwise -> do
|
||||
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c)
|
||||
case memChatVRange of
|
||||
@@ -3065,10 +3163,12 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
deleteGroupLinkIfExists user gInfo
|
||||
-- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
|
||||
unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False
|
||||
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved
|
||||
withStore' $ \db -> do
|
||||
updateGroupMemberStatus db userId membership GSMemRemoved
|
||||
when (isJust $ relayOwnStatus gInfo) $ updateRelayOwnStatus_ db gInfo RSInactive
|
||||
let membership' = membership {memberStatus = GSMemRemoved}
|
||||
when withMessages $ deleteMessages gInfo membership' SMDSnd
|
||||
deleteMemberItem gInfo RGEUserDeleted
|
||||
deleteMemberItem msg gInfo RGEUserDeleted
|
||||
toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned
|
||||
pure $ Just DJSGroup {jobSpec = DJRelayRemoved}
|
||||
else
|
||||
@@ -3096,7 +3196,11 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let wasDeleted = memberStatus == GSMemRemoved || memberStatus == GSMemLeft
|
||||
deletedMember' = deletedMember {memberStatus = GSMemRemoved}
|
||||
when withMessages $ deleteMessages gInfo'' deletedMember' SMDRcv
|
||||
unless wasDeleted $ deleteMemberItem gInfo'' $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)
|
||||
-- Clear forwardedByMember if it references the deleted member,
|
||||
-- as the member record was already deleted above.
|
||||
let RcvMessage {forwardedByMember = fwdBy} = msg
|
||||
msg' = if fwdBy == Just groupMemberId then (msg :: RcvMessage) {forwardedByMember = Nothing} else msg
|
||||
unless wasDeleted $ deleteMemberItem msg' gInfo'' $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)
|
||||
toView $ CEvtDeletedMember user gInfo'' m deletedMember' withMessages msgSigned
|
||||
pure deliveryScope
|
||||
where
|
||||
@@ -3104,9 +3208,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
| senderRole < GRAdmin || senderRole < memberRole =
|
||||
messageError "x.grp.mem.del with insufficient member permissions" $> Nothing
|
||||
| otherwise = a
|
||||
deleteMemberItem gi gEvent = do
|
||||
deleteMemberItem msg' gi gEvent = do
|
||||
(gi', m', scopeInfo) <- mkGroupChatScope gi m
|
||||
(ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gi' scopeInfo m') msg brokerTs (CIRcvGroupEvent gEvent)
|
||||
(ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gi' scopeInfo m') msg' brokerTs (CIRcvGroupEvent gEvent)
|
||||
groupMsgToView cInfo ci
|
||||
deleteMessages :: MsgDirectionI d => GroupInfo -> GroupMember -> SMsgDirection d -> CM ()
|
||||
deleteMessages gInfo' delMem msgDir
|
||||
@@ -3195,6 +3299,13 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
let cd = CDGroupRcv g'' scopeInfo m'
|
||||
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g''
|
||||
|
||||
xGrpRelayNew :: GroupInfo -> GroupMember -> ShortLinkContact -> CM (Maybe DeliveryJobScope)
|
||||
xGrpRelayNew gInfo GroupMember {memberRole} rl
|
||||
| memberRole < GROwner = messageError "x.grp.relay.new with insufficient member permissions" $> Nothing
|
||||
| otherwise = do
|
||||
unless (isUserGrpFwdRelay gInfo) $ connectToRelayAsync user gInfo rl
|
||||
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}
|
||||
|
||||
xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM ()
|
||||
xGrpDirectInv g@GroupInfo {groupId, groupProfile = gp} m mConn@Connection {connId = mConnId} connReq mContent_ msg brokerTs
|
||||
| not (groupFeatureMemberAllowed SGFDirectMessages m g) = messageError "x.grp.direct.inv: direct messages not allowed"
|
||||
@@ -3316,6 +3427,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
|
||||
XMsgReact sharedMsgId memId scope_ reaction add -> withAuthor XMsgReact_ $ \author -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs
|
||||
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId
|
||||
XInfo p -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p rcvMsg msgTs
|
||||
XGrpRelayNew rl -> withAuthor XGrpRelayNew_ $ \author -> void $ xGrpRelayNew gInfo author rl
|
||||
XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs
|
||||
XGrpMemRole memId memRole -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo author memId memRole rcvMsg msgTs
|
||||
XGrpMemRestrict memId memRestrictions -> withAuthor XGrpMemRestrict_ $ \author -> void $ xGrpMemRestrict gInfo author memId memRestrictions rcvMsg msgTs
|
||||
@@ -3491,19 +3603,24 @@ runDeliveryTaskWorker a deliveryKey Worker {doWork} = do
|
||||
processDeliveryTask :: MessageDeliveryTask -> CM ()
|
||||
processDeliveryTask task@MessageDeliveryTask {jobScope} =
|
||||
case jobScopeImpliedSpec jobScope of
|
||||
DJDeliveryJob _includePending ->
|
||||
withWorkItems a doWork (withStore' $ \db -> getNextDeliveryTasks db gInfo task) $ \nextTasks -> do
|
||||
let (body, taskIds, largeTaskIds) = batchDeliveryTasks1 vr maxEncodedMsgLength nextTasks
|
||||
withStore' $ \db -> do
|
||||
createMsgDeliveryJob db gInfo jobScope (singleSenderGMId_ nextTasks) body
|
||||
forM_ taskIds $ \taskId -> updateDeliveryTaskStatus db taskId DTSProcessed
|
||||
forM_ largeTaskIds $ \taskId -> setDeliveryTaskErrStatus db taskId "large"
|
||||
lift . void $ getDeliveryJobWorker True deliveryKey
|
||||
DJDeliveryJob _includePending
|
||||
| relayOwnStatus gInfo == Just RSInactive -> do
|
||||
logWarn "delivery task worker: relay inactive"
|
||||
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
|
||||
withStore' $ \db -> do
|
||||
createMsgDeliveryJob db gInfo jobScope (singleSenderGMId_ nextTasks) body
|
||||
forM_ taskIds $ \taskId -> updateDeliveryTaskStatus db taskId DTSProcessed
|
||||
forM_ largeTaskIds $ \taskId -> setDeliveryTaskErrStatus db taskId "large"
|
||||
lift . void $ getDeliveryJobWorker True deliveryKey
|
||||
where
|
||||
singleSenderGMId_ :: NonEmpty MessageDeliveryTask -> Maybe GroupMemberId
|
||||
singleSenderGMId_ (MessageDeliveryTask {senderGMId = senderGMId'} :| ts)
|
||||
| all (\MessageDeliveryTask {senderGMId} -> senderGMId == senderGMId') ts = Just senderGMId'
|
||||
| otherwise = Nothing
|
||||
-- DJRelayRemoved is allowed when RSInactive - it forwards XGrpMemDel about relay's own deletion
|
||||
DJRelayRemoved
|
||||
| workerScope /= DWSGroup ->
|
||||
throwChatError $ CEInternalError "delivery task worker: relay removed task in wrong worker scope"
|
||||
@@ -3556,9 +3673,14 @@ runDeliveryJobWorker a deliveryKey Worker {doWork} = do
|
||||
processDeliveryJob :: MessageDeliveryJob -> CM ()
|
||||
processDeliveryJob job =
|
||||
case jobScopeImpliedSpec jobScope of
|
||||
DJDeliveryJob _includePending -> do
|
||||
sendBodyToMembers
|
||||
withStore' $ \db -> updateDeliveryJobStatus db jobId DJSComplete
|
||||
DJDeliveryJob _includePending
|
||||
| relayOwnStatus gInfo == Just RSInactive -> do
|
||||
logWarn "delivery job worker: relay inactive"
|
||||
withStore' $ \db -> setDeliveryJobErrStatus db (deliveryJobId job) "relay inactive"
|
||||
| otherwise -> do
|
||||
sendBodyToMembers
|
||||
withStore' $ \db -> updateDeliveryJobStatus db jobId DJSComplete
|
||||
-- DJRelayRemoved is allowed when RSInactive - it forwards XGrpMemDel about relay's own deletion
|
||||
DJRelayRemoved
|
||||
| workerScope /= DWSGroup ->
|
||||
throwChatError $ CEInternalError "delivery job worker: relay removed job in wrong worker scope"
|
||||
@@ -3677,23 +3799,55 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
user <- getRelayUser db
|
||||
UserContactLink {userContactLinkId} <- getUserAddress db user
|
||||
pure (user, userContactLinkId)
|
||||
delayThreads <- liftIO TM.emptyIO
|
||||
forever $ do
|
||||
lift $ waitForWork doWork
|
||||
runRelayRequestOperation vr user uclId
|
||||
runRelayRequestOperation delayThreads vr user uclId
|
||||
where
|
||||
runRelayRequestOperation :: VersionRangeChat -> User -> Int64 -> CM ()
|
||||
runRelayRequestOperation vr user uclId =
|
||||
withWork_ a doWork (withStore' getNextPendingRelayRequest) $
|
||||
runRelayRequestOperation :: TM.TMap GroupId (TMVar (Weak ThreadId)) -> VersionRangeChat -> User -> Int64 -> CM ()
|
||||
runRelayRequestOperation delayThreads vr user uclId =
|
||||
withWork_ a doWork getReadyRelayRequest $
|
||||
\(groupId, rrd) -> do
|
||||
ri <- asks $ reconnectInterval . agentConfig . config
|
||||
withRetryInterval ri $ \_ loop -> do
|
||||
liftIO $ waitWhileSuspended a
|
||||
liftIO $ waitForUserNetwork a
|
||||
processRelayRequest groupId rrd `catchAllErrors` retryTmpError loop groupId
|
||||
ChatConfig {relayRequestExpiry} <- asks config
|
||||
liftIO $ waitWhileSuspended a
|
||||
liftIO $ waitForUserNetwork a
|
||||
processRelayRequest groupId rrd `catchAllErrors` retryTmpError relayRequestExpiry groupId rrd
|
||||
where
|
||||
retryTmpError :: CM () -> GroupId -> ChatError -> CM ()
|
||||
retryTmpError loop groupId = \case
|
||||
ChatErrorAgent {agentError} | temporaryOrHostError agentError -> loop
|
||||
getReadyRelayRequest :: CM (Either StoreError (Maybe (GroupId, RelayRequestData)))
|
||||
getReadyRelayRequest =
|
||||
withStore' getNextPendingRelayRequest >>= \case
|
||||
Right (Just (groupId, rrd@RelayRequestData {reqExecuteAt})) -> do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let delay = diffUTCTime reqExecuteAt currentTs
|
||||
if delay <= 1
|
||||
then pure $ Right (Just (groupId, rrd))
|
||||
else Right Nothing <$ scheduleRequest groupId delay
|
||||
r -> pure r
|
||||
scheduleRequest :: GroupId -> NominalDiffTime -> CM ()
|
||||
scheduleRequest groupId delay = do
|
||||
v_ <- liftIO $ atomically $
|
||||
ifM
|
||||
(isNothing <$> TM.lookup groupId delayThreads)
|
||||
(newEmptyTMVar >>= \v -> TM.insert groupId v delayThreads $> Just v)
|
||||
(pure Nothing)
|
||||
forM_ v_ $ \v -> do
|
||||
tId <- liftIO $ forkIO $ do
|
||||
threadDelay' $ diffToMicroseconds delay
|
||||
atomically $ TM.delete groupId delayThreads
|
||||
void $ atomically $ tryPutTMVar doWork ()
|
||||
weakTId <- liftIO $ mkWeakThreadId tId
|
||||
liftIO $ atomically $ putTMVar v weakTId
|
||||
retryTmpError :: (Int, NominalDiffTime) -> GroupId -> RelayRequestData -> ChatError -> CM ()
|
||||
retryTmpError (retriesThreshold, ttl) groupId RelayRequestData {reqDelay, reqRetries, reqCreatedAt} = \case
|
||||
ChatErrorAgent {agentError} | temporaryOrHostError agentError -> do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
if reqRetries >= retriesThreshold && diffUTCTime currentTs reqCreatedAt >= ttl
|
||||
then withStore' $ \db -> setRelayRequestErr db groupId "expired"
|
||||
else do
|
||||
ri <- asks $ relayRequestRetryInterval . config
|
||||
let executeAt = addUTCTime (fromIntegral reqDelay / 1000000) currentTs
|
||||
nextDelay = nextRetryDelay 0 reqDelay ri
|
||||
withStore' $ \db -> updateRelayRequestRetries db groupId nextDelay executeAt
|
||||
e -> do
|
||||
withStore' $ \db -> setRelayRequestErr db groupId (tshow e)
|
||||
eToView e
|
||||
@@ -3715,7 +3869,7 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
where
|
||||
getLinkDataCreateRelayLink :: RelayRequestData -> GroupInfo -> CM (GroupInfo, ShortLinkContact)
|
||||
getLinkDataCreateRelayLink RelayRequestData {reqGroupLink} gInfo = do
|
||||
(FixedLinkData {linkEntityId, rootKey}, cData@(ContactLinkData _ UserContactData {owners})) <- getShortLinkConnReq NRMBackground user reqGroupLink
|
||||
(FixedLinkData {linkEntityId, rootKey}, cData@(ContactLinkData _ UserContactData {owners})) <- getShortLinkConnReq' NRMBackground user reqGroupLink
|
||||
liftIO (decodeLinkUserData cData) >>= \case
|
||||
Nothing -> throwChatError $ CEException "getLinkDataCreateRelayLink: no group link data"
|
||||
Just GroupShortLinkData {groupProfile = gp@GroupProfile {publicGroup}} -> do
|
||||
@@ -3746,8 +3900,8 @@ runRelayRequestWorker a Worker {doWork} = do
|
||||
let crClientData = encodeJSON $ CRDataGroup groupLinkId
|
||||
-- prepare link with relayMemId as linkEntityId (no server request)
|
||||
(ccLink, preparedParams) <- withAgent $ \a' -> prepareConnectionLink a' (aUserId user) sigKeys relayMemId True (Just crClientData)
|
||||
ccLink' <- createdGroupLink <$> shortenCreatedLink ccLink
|
||||
sLnk <- case toShortLinkContact ccLink' of
|
||||
ccLink' <- setShortLinkType CCTGroup <$> shortenCreatedLink ccLink
|
||||
sLnk <- case connShortLink' ccLink' of
|
||||
Just sl -> pure sl
|
||||
Nothing -> throwChatError $ CEException "failed to create relay link: no short link"
|
||||
let userData = encodeShortLinkData $ RelayShortLinkData {relayProfile = fromLocalProfile p}
|
||||
|
||||
@@ -360,7 +360,7 @@ parseUri s = case U.parseURI U.laxURIParserOptions s of
|
||||
sanitizeUri :: Bool -> U.URI -> Maybe U.URI
|
||||
sanitizeUri safe uri@U.URI {uriAuthority, uriPath, uriQuery = U.Query originalQS} =
|
||||
let sanitizedQS
|
||||
| safe = filter (not . isSafeBlacklisted . fst) originalQS
|
||||
| safe = filter (\(n, _) -> isWhitelisted n || not (isSafeBlacklisted n)) originalQS
|
||||
| isNamePath = case originalQS of
|
||||
p@(n, _) : ps -> (if isWhitelisted n || not (isBlacklisted n) then (p :) else id) $ filter (isWhitelisted . fst) ps
|
||||
[] -> []
|
||||
|
||||
@@ -119,6 +119,11 @@ checkChatType x = case testEquality (chatTypeI @c) (chatTypeI @c') of
|
||||
data GroupChatScope = GCSMemberSupport {groupMemberId_ :: Maybe GroupMemberId} -- Nothing means own conversation with support
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
sendAsGroup' :: GroupInfo -> Maybe GroupChatScope -> Bool
|
||||
sendAsGroup' gInfo@GroupInfo {membership} scope = case scope of
|
||||
Nothing -> useRelays' gInfo && memberRole' membership == GROwner
|
||||
Just (GCSMemberSupport _) -> False
|
||||
|
||||
data GroupChatScopeTag
|
||||
= GCSTMemberSupport_
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -145,6 +145,7 @@ data CIContent (d :: MsgDirection) where
|
||||
CIRcvCall :: CICallStatus -> Int -> CIContent 'MDRcv
|
||||
CIRcvIntegrityError :: MsgErrorType -> CIContent 'MDRcv
|
||||
CIRcvDecryptionError :: MsgDecryptError -> Word32 -> CIContent 'MDRcv
|
||||
CIRcvMsgError :: RcvMsgError -> CIContent 'MDRcv
|
||||
CIRcvGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDRcv
|
||||
CISndGroupInvitation :: CIGroupInvitation -> GroupMemberRole -> CIContent 'MDSnd
|
||||
CIRcvDirectEvent :: RcvDirectEvent -> CIContent 'MDRcv
|
||||
@@ -176,9 +177,16 @@ data CIContent (d :: MsgDirection) where
|
||||
|
||||
deriving instance Show (CIContent d)
|
||||
|
||||
data E2EInfo = E2EInfo {pqEnabled :: Maybe PQEncryption}
|
||||
-- stored in database, all changed must be backward compatible
|
||||
data E2EInfo = E2EInfo {public :: Maybe Bool, pqEnabled :: Maybe PQEncryption}
|
||||
deriving (Eq, Show)
|
||||
|
||||
e2eInfoEncrypted :: Maybe PQEncryption -> E2EInfo
|
||||
e2eInfoEncrypted pqEnabled = E2EInfo {public = Nothing, pqEnabled}
|
||||
|
||||
e2eInfoGroup :: GroupInfo -> E2EInfo
|
||||
e2eInfoGroup g = E2EInfo {public = if useRelays' g then Just True else Nothing, pqEnabled = Just PQEncOff}
|
||||
|
||||
ciMsgContent :: CIContent d -> Maybe MsgContent
|
||||
ciMsgContent = \case
|
||||
CISndMsgContent mc -> Just mc
|
||||
@@ -196,6 +204,11 @@ data MsgDecryptError
|
||||
| MDERatchetSync
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RcvMsgError
|
||||
= RMEDropped {attempts :: Int}
|
||||
| RMEParseError {parseError :: Text}
|
||||
deriving (Eq, Show)
|
||||
|
||||
ciRequiresAttention :: forall d. MsgDirectionI d => CIContent d -> Bool
|
||||
ciRequiresAttention content = case msgDirection @d of
|
||||
SMDSnd -> True
|
||||
@@ -205,6 +218,7 @@ ciRequiresAttention content = case msgDirection @d of
|
||||
CIRcvCall {} -> True
|
||||
CIRcvIntegrityError _ -> True
|
||||
CIRcvDecryptionError {} -> True
|
||||
CIRcvMsgError _ -> False
|
||||
CIRcvGroupInvitation {} -> True
|
||||
CIRcvDirectEvent rde -> case rde of
|
||||
RDEContactDeleted -> False
|
||||
@@ -275,6 +289,7 @@ ciContentToText = \case
|
||||
CIRcvCall status duration -> "incoming call: " <> ciCallInfoText status duration
|
||||
CIRcvIntegrityError err -> msgIntegrityError err
|
||||
CIRcvDecryptionError err n -> msgDecryptErrorText err n
|
||||
CIRcvMsgError err -> rcvMsgErrorText err
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> "received " <> ciGroupInvitationToText groupInvitation memberRole
|
||||
CISndGroupInvitation groupInvitation memberRole -> "sent " <> ciGroupInvitationToText groupInvitation memberRole
|
||||
CIRcvDirectEvent event -> rcvDirectEventToText event
|
||||
@@ -307,9 +322,14 @@ directE2EInfoToText E2EInfo {pqEnabled} = case pqEnabled of
|
||||
Nothing -> simpleE2EText
|
||||
|
||||
groupE2EInfoToText :: E2EInfo -> Text
|
||||
groupE2EInfoToText E2EInfo {pqEnabled} = case pqEnabled of
|
||||
Just _ -> e2eInfoNoPQText
|
||||
Nothing -> simpleE2EText
|
||||
groupE2EInfoToText E2EInfo {pqEnabled, public} = case public of
|
||||
Just True -> publicGroupNoE2EText
|
||||
_ -> case pqEnabled of
|
||||
Just _ -> e2eInfoNoPQText
|
||||
Nothing -> simpleE2EText
|
||||
|
||||
publicGroupNoE2EText :: Text
|
||||
publicGroupNoE2EText = "This channel or group is NOT end-to-end encrypted."
|
||||
|
||||
simpleE2EText :: Text
|
||||
simpleE2EText = "This conversation is protected by end-to-end encryption"
|
||||
@@ -421,6 +441,11 @@ msgIntegrityError = \case
|
||||
MsgBadHash -> "incorrect message hash"
|
||||
MsgDuplicate -> "duplicate message ID"
|
||||
|
||||
rcvMsgErrorText :: RcvMsgError -> Text
|
||||
rcvMsgErrorText = \case
|
||||
RMEDropped {attempts} -> "message removed after " <> tshow attempts <> " attempts"
|
||||
RMEParseError {parseError} -> "message error: " <> parseError
|
||||
|
||||
msgDecryptErrorText :: MsgDecryptError -> Word32 -> Text
|
||||
msgDecryptErrorText err n =
|
||||
"decryption error, possibly due to the device change"
|
||||
@@ -457,6 +482,7 @@ data JSONCIContent
|
||||
| JCIRcvCall {status :: CICallStatus, duration :: Int}
|
||||
| JCIRcvIntegrityError {msgError :: MsgErrorType}
|
||||
| JCIRcvDecryptionError {msgDecryptError :: MsgDecryptError, msgCount :: Word32}
|
||||
| JCIRcvMsgError {rcvMsgError :: RcvMsgError}
|
||||
| JCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| JCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| JCIRcvDirectEvent {rcvDirectEvent :: RcvDirectEvent}
|
||||
@@ -492,6 +518,7 @@ jsonCIContent = \case
|
||||
CIRcvCall status duration -> JCIRcvCall {status, duration}
|
||||
CIRcvIntegrityError err -> JCIRcvIntegrityError err
|
||||
CIRcvDecryptionError err n -> JCIRcvDecryptionError err n
|
||||
CIRcvMsgError err -> JCIRcvMsgError err
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> JCIRcvGroupInvitation {groupInvitation, memberRole}
|
||||
CISndGroupInvitation groupInvitation memberRole -> JCISndGroupInvitation {groupInvitation, memberRole}
|
||||
CIRcvDirectEvent rcvDirectEvent -> JCIRcvDirectEvent {rcvDirectEvent}
|
||||
@@ -527,6 +554,7 @@ aciContentJSON = \case
|
||||
JCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
|
||||
JCIRcvIntegrityError err -> ACIContent SMDRcv $ CIRcvIntegrityError err
|
||||
JCIRcvDecryptionError err n -> ACIContent SMDRcv $ CIRcvDecryptionError err n
|
||||
JCIRcvMsgError err -> ACIContent SMDRcv $ CIRcvMsgError err
|
||||
JCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole
|
||||
JCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
|
||||
JCIRcvDirectEvent {rcvDirectEvent} -> ACIContent SMDRcv $ CIRcvDirectEvent rcvDirectEvent
|
||||
@@ -563,6 +591,7 @@ data DBJSONCIContent
|
||||
| DBJCIRcvCall {status :: CICallStatus, duration :: Int}
|
||||
| DBJCIRcvIntegrityError {msgError :: DBMsgErrorType}
|
||||
| DBJCIRcvDecryptionError {msgDecryptError :: MsgDecryptError, msgCount :: Word32}
|
||||
| DBJCIRcvMsgError {rcvMsgError :: RcvMsgError}
|
||||
| DBJCIRcvGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| DBJCISndGroupInvitation {groupInvitation :: CIGroupInvitation, memberRole :: GroupMemberRole}
|
||||
| DBJCIRcvDirectEvent {rcvDirectEvent :: DBRcvDirectEvent}
|
||||
@@ -598,6 +627,7 @@ dbJsonCIContent = \case
|
||||
CIRcvCall status duration -> DBJCIRcvCall {status, duration}
|
||||
CIRcvIntegrityError err -> DBJCIRcvIntegrityError $ DBME err
|
||||
CIRcvDecryptionError err n -> DBJCIRcvDecryptionError err n
|
||||
CIRcvMsgError err -> DBJCIRcvMsgError err
|
||||
CIRcvGroupInvitation groupInvitation memberRole -> DBJCIRcvGroupInvitation {groupInvitation, memberRole}
|
||||
CISndGroupInvitation groupInvitation memberRole -> DBJCISndGroupInvitation {groupInvitation, memberRole}
|
||||
CIRcvDirectEvent rde -> DBJCIRcvDirectEvent $ RDE rde
|
||||
@@ -633,6 +663,7 @@ aciContentDBJSON = \case
|
||||
DBJCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
|
||||
DBJCIRcvIntegrityError (DBME err) -> ACIContent SMDRcv $ CIRcvIntegrityError err
|
||||
DBJCIRcvDecryptionError err n -> ACIContent SMDRcv $ CIRcvDecryptionError err n
|
||||
DBJCIRcvMsgError err -> ACIContent SMDRcv $ CIRcvMsgError err
|
||||
DBJCIRcvGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDRcv $ CIRcvGroupInvitation groupInvitation memberRole
|
||||
DBJCISndGroupInvitation {groupInvitation, memberRole} -> ACIContent SMDSnd $ CISndGroupInvitation groupInvitation memberRole
|
||||
DBJCIRcvDirectEvent (RDE rde) -> ACIContent SMDRcv $ CIRcvDirectEvent rde
|
||||
@@ -693,6 +724,8 @@ $(JQ.deriveJSON defaultJSON ''E2EInfo)
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "MDE") ''MsgDecryptError)
|
||||
|
||||
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RME") ''RcvMsgError)
|
||||
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "CIGIS") ''CIGroupInvitationStatus)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''CIGroupInvitation)
|
||||
@@ -751,6 +784,7 @@ toCIContentTag ciContent = case ciContent of
|
||||
CIRcvCall {} -> "rcvCall"
|
||||
CIRcvIntegrityError _ -> "rcvIntegrityError"
|
||||
CIRcvDecryptionError {} -> "rcvDecryptionError"
|
||||
CIRcvMsgError _ -> "rcvMsgError"
|
||||
CIRcvGroupInvitation {} -> "rcvGroupInvitation"
|
||||
CISndGroupInvitation {} -> "sndGroupInvitation"
|
||||
CIRcvDirectEvent _ -> "rcvDirectEvent"
|
||||
|
||||
@@ -60,10 +60,10 @@ import Simplex.Messaging.Transport.Client (TransportHost (..))
|
||||
import Simplex.Messaging.Util (atomicModifyIORef'_, safeDecodeUtf8)
|
||||
|
||||
usageConditionsCommit :: Text
|
||||
usageConditionsCommit = "7471fd2af5838dc0467aebc570b5ea75e5df3209"
|
||||
usageConditionsCommit = "05f99634c470f8bddac20046947a0606938b22ad"
|
||||
|
||||
previousConditionsCommit :: Text
|
||||
previousConditionsCommit = "a5061f3147165a05979d6ace33960aced2d6ac03"
|
||||
previousConditionsCommit = "7471fd2af5838dc0467aebc570b5ea75e5df3209"
|
||||
|
||||
usageConditionsText :: Text
|
||||
usageConditionsText =
|
||||
|
||||
@@ -93,7 +93,8 @@ disabledSimplexChatSMPServers =
|
||||
simplexChatRelays :: [NewUserChatRelay]
|
||||
simplexChatRelays =
|
||||
[ presetChatRelay True (mkRelayProfile "SimpleX Chat Relay 1" $ Just simplexChatImage) ["simplex.im"] (either error id $ strDecode "https://smp5.simplex.im/r#Fp5RWXkiRFg-hgcDwC2v-MWnPfvEf42RgCqREntW0mw"),
|
||||
presetChatRelay True (mkRelayProfile "SimpleX Chat Relay 2" $ Just simplexChatImage) ["simplex.im"] (either error id $ strDecode "https://smp6.simplex.im/r#_qlQfogHGDJ8MAF2wKmkglRBM-xHR142gDJstKiGRQQ")
|
||||
presetChatRelay True (mkRelayProfile "SimpleX Chat Relay 2" $ Just simplexChatImage) ["simplex.im"] (either error id $ strDecode "https://smp6.simplex.im/r#_qlQfogHGDJ8MAF2wKmkglRBM-xHR142gDJstKiGRQQ"),
|
||||
presetChatRelay True (mkRelayProfile "SimpleX Chat Relay 3" $ Just simplexChatImage) ["simplex.im"] (either error id $ strDecode "https://smp4.simplex.im/r#yxNOMJcry5jMTRPEBVtGBATYaKeoRIsZRBPIDLx7x6M")
|
||||
]
|
||||
|
||||
fluxSMPServers :: [NewUserServer 'PSMP]
|
||||
|
||||
+119
-74
@@ -56,7 +56,7 @@ import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.Messaging.Agent.Protocol (VersionSMPA, pqdrSMPAgentVersion)
|
||||
import Simplex.Messaging.Agent.Store.DB (blobFieldDecoder, fromTextField_)
|
||||
import Simplex.Messaging.Compression (Compressed, compress1, decompress1)
|
||||
import Simplex.Messaging.Compression (Compressed, compress1, decompress1, decompressedSize)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding
|
||||
import Simplex.Messaging.Encoding.String
|
||||
@@ -332,7 +332,7 @@ data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMess
|
||||
data KeyRef = KRMember
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ChatBinding = CBGroup
|
||||
data ChatBinding = CBGroup | CBDirect | CBChannel
|
||||
deriving (Eq, Show)
|
||||
|
||||
data MsgSignature = MsgSignature KeyRef C.ASignature
|
||||
@@ -395,10 +395,15 @@ instance Encoding KeyRef where
|
||||
c -> fail $ "invalid KeyRef tag: " <> show c
|
||||
|
||||
instance Encoding ChatBinding where
|
||||
smpEncode CBGroup = "G"
|
||||
smpEncode = \case
|
||||
CBGroup -> "G"
|
||||
CBDirect -> "D"
|
||||
CBChannel -> "C"
|
||||
smpP =
|
||||
A.anyChar >>= \case
|
||||
'G' -> pure CBGroup
|
||||
'D' -> pure CBDirect
|
||||
'C' -> pure CBChannel
|
||||
c -> fail $ "invalid ChatBinding: " <> show c
|
||||
|
||||
instance ToField ChatBinding where toField = toField . decodeLatin1 . smpEncode
|
||||
@@ -425,7 +430,8 @@ data MsgSigning = MsgSigning
|
||||
privKey :: C.PrivateKeyEd25519
|
||||
}
|
||||
|
||||
|
||||
encodeChatBinding :: ChatBinding -> ByteString -> ByteString
|
||||
encodeChatBinding cb bindingData = smpEncode cb <> bindingData
|
||||
|
||||
data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
|
||||
@@ -451,6 +457,7 @@ data ChatMsgEvent (e :: MsgEncoding) where
|
||||
XGrpRelayInv :: GroupRelayInvitation -> ChatMsgEvent 'Json
|
||||
XGrpRelayAcpt :: ShortLinkContact -> ChatMsgEvent 'Json
|
||||
XGrpRelayTest :: ByteString -> Maybe ByteString -> ChatMsgEvent 'Json
|
||||
XGrpRelayNew :: ShortLinkContact -> ChatMsgEvent 'Json
|
||||
XGrpMemNew :: MemberInfo -> Maybe MsgScope -> ChatMsgEvent 'Json
|
||||
XGrpMemIntro :: MemberInfo -> Maybe MemberRestrictions -> ChatMsgEvent 'Json
|
||||
XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json
|
||||
@@ -499,6 +506,7 @@ isForwardedGroupMsg ev = case ev of
|
||||
XMsgReact {} -> True
|
||||
XFileCancel _ -> True
|
||||
XInfo _ -> True
|
||||
XGrpRelayNew _ -> True
|
||||
XGrpMemNew {} -> True
|
||||
XGrpMemRole {} -> True
|
||||
XGrpMemRestrict {} -> True
|
||||
@@ -654,7 +662,7 @@ data MsgContainer = MsgContainer
|
||||
-- the key used in mentions is a locally (per message) unique display name of member.
|
||||
-- Suffixes _1, _2 should be appended to make names locally unique.
|
||||
-- It should be done in the UI, as they will be part of the text, and validated in the API.
|
||||
mentions :: Map MemberName MsgMention,
|
||||
mentions :: MsgMentions,
|
||||
file :: Maybe FileInvitation,
|
||||
ttl :: Maybe Int,
|
||||
live :: Maybe Bool,
|
||||
@@ -673,7 +681,7 @@ mcEmpty :: MsgContainer
|
||||
mcEmpty =
|
||||
MsgContainer
|
||||
{ content = MCText "",
|
||||
mentions = M.empty,
|
||||
mentions = MsgMentions M.empty,
|
||||
file = Nothing,
|
||||
ttl = Nothing,
|
||||
live = Nothing,
|
||||
@@ -707,7 +715,7 @@ data MsgContent
|
||||
| MCVoice {text :: Text, duration :: Int}
|
||||
| MCFile {text :: Text}
|
||||
| MCReport {text :: Text, reason :: ReportReason}
|
||||
| MCChat {text :: Text, chatLink :: MsgChatLink}
|
||||
| MCChat {text :: Text, chatLink :: MsgChatLink, ownerSig :: Maybe LinkOwnerSig}
|
||||
| MCUnknown {tag :: Text, text :: Text, json :: J.Object}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@@ -717,6 +725,13 @@ data MsgChatLink
|
||||
| MCLGroup {connLink :: ShortLinkContact, groupProfile :: GroupProfile}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data LinkOwnerSig = LinkOwnerSig
|
||||
{ ownerId :: Maybe B64UrlByteString,
|
||||
chatBinding :: B64UrlByteString,
|
||||
ownerSig :: C.Signature 'C.Ed25519
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
msgContentText :: MsgContent -> Text
|
||||
msgContentText = \case
|
||||
MCText t -> t
|
||||
@@ -774,12 +789,95 @@ msgContentTag = \case
|
||||
data MsgMention = MsgMention {memberId :: MemberId}
|
||||
deriving (Eq, Show)
|
||||
|
||||
newtype MsgMentions = MsgMentions (Map MemberName MsgMention)
|
||||
deriving (Eq, Show)
|
||||
|
||||
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "MCL") ''MsgChatLink)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''LinkOwnerSig)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''MsgMention)
|
||||
|
||||
instance FromJSON MsgMentions where
|
||||
parseJSON v = MsgMentions <$> parseJSON v
|
||||
omittedField = Just $ MsgMentions M.empty
|
||||
|
||||
instance ToJSON MsgMentions where
|
||||
toJSON (MsgMentions m) = toJSON $ toMaybeMap m
|
||||
toEncoding (MsgMentions m) = toEncoding $ toMaybeMap m
|
||||
omitField (MsgMentions m) = M.null m
|
||||
|
||||
toMaybeMap :: Map k v -> Maybe (Map k v)
|
||||
toMaybeMap m = if M.null m then Nothing else Just m
|
||||
{-# INLINE toMaybeMap #-}
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''QuotedMsg)
|
||||
|
||||
instance FromJSON MsgContent where
|
||||
parseJSON (J.Object v) =
|
||||
v .: "type" >>= \case
|
||||
MCText_ -> MCText <$> v .: "text"
|
||||
MCLink_ -> do
|
||||
text <- v .: "text"
|
||||
preview <- v .: "preview"
|
||||
pure MCLink {text, preview}
|
||||
MCImage_ -> do
|
||||
text <- v .: "text"
|
||||
image <- v .: "image"
|
||||
pure MCImage {text, image}
|
||||
MCVideo_ -> do
|
||||
text <- v .: "text"
|
||||
image <- v .: "image"
|
||||
duration <- v .: "duration"
|
||||
pure MCVideo {text, image, duration}
|
||||
MCVoice_ -> do
|
||||
text <- v .: "text"
|
||||
duration <- v .: "duration"
|
||||
pure MCVoice {text, duration}
|
||||
MCFile_ -> MCFile <$> v .: "text"
|
||||
MCReport_ -> do
|
||||
text <- v .: "text"
|
||||
reason <- v .: "reason"
|
||||
pure MCReport {text, reason}
|
||||
MCChat_ -> do
|
||||
text <- v .: "text"
|
||||
chatLink <- v .: "chatLink"
|
||||
ownerSig <- v .:? "ownerSig"
|
||||
pure MCChat {text, chatLink, ownerSig}
|
||||
MCUnknown_ tag -> do
|
||||
text <- fromMaybe unknownMsgType <$> v .:? "text"
|
||||
pure MCUnknown {tag, text, json = v}
|
||||
parseJSON invalid =
|
||||
JT.prependFailure "bad MsgContent, " (JT.typeMismatch "Object" invalid)
|
||||
|
||||
unknownMsgType :: Text
|
||||
unknownMsgType = "unknown message type"
|
||||
|
||||
(.=?) :: ToJSON v => JT.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)]
|
||||
key .=? value = maybe id ((:) . (key .=)) value
|
||||
|
||||
instance ToJSON MsgContent where
|
||||
toJSON = \case
|
||||
MCUnknown {json} -> J.Object json
|
||||
MCText t -> J.object ["type" .= MCText_, "text" .= t]
|
||||
MCLink {text, preview} -> J.object ["type" .= MCLink_, "text" .= text, "preview" .= preview]
|
||||
MCImage {text, image} -> J.object ["type" .= MCImage_, "text" .= text, "image" .= image]
|
||||
MCVideo {text, image, duration} -> J.object ["type" .= MCVideo_, "text" .= text, "image" .= image, "duration" .= duration]
|
||||
MCVoice {text, duration} -> J.object ["type" .= MCVoice_, "text" .= text, "duration" .= duration]
|
||||
MCFile t -> J.object ["type" .= MCFile_, "text" .= t]
|
||||
MCReport {text, reason} -> J.object ["type" .= MCReport_, "text" .= text, "reason" .= reason]
|
||||
MCChat {text, chatLink, ownerSig} -> J.object $ ("ownerSig" .=? ownerSig) ["type" .= MCChat_, "text" .= text, "chatLink" .= chatLink]
|
||||
toEncoding = \case
|
||||
MCUnknown {json} -> JE.value $ J.Object json
|
||||
MCText t -> J.pairs $ "type" .= MCText_ <> "text" .= t
|
||||
MCLink {text, preview} -> J.pairs $ "type" .= MCLink_ <> "text" .= text <> "preview" .= preview
|
||||
MCImage {text, image} -> J.pairs $ "type" .= MCImage_ <> "text" .= text <> "image" .= image
|
||||
MCVideo {text, image, duration} -> J.pairs $ "type" .= MCVideo_ <> "text" .= text <> "image" .= image <> "duration" .= duration
|
||||
MCVoice {text, duration} -> J.pairs $ "type" .= MCVoice_ <> "text" .= text <> "duration" .= duration
|
||||
MCFile t -> J.pairs $ "type" .= MCFile_ <> "text" .= t
|
||||
MCReport {text, reason} -> J.pairs $ "type" .= MCReport_ <> "text" .= text <> "reason" .= reason
|
||||
MCChat {text, chatLink, ownerSig} -> J.pairs $ "type" .= MCChat_ <> "text" .= text <> "chatLink" .= chatLink <> maybe mempty ("ownerSig" .=) ownerSig
|
||||
|
||||
-- this limit reserves space for metadata in forwarded messages
|
||||
-- 15780 (limit used for fileChunkSize) - 161 (x.grp.msg.forward overhead) = 15619, - 16 for block encryption ("rounded" to 15602)
|
||||
maxEncodedMsgLength :: Int
|
||||
@@ -834,7 +932,11 @@ parseChatMessages msg = case B.head msg of
|
||||
decodeCompressed :: ByteString -> [Either String AParsedMsg]
|
||||
decodeCompressed s = case smpDecode s of
|
||||
Left e -> [Left e]
|
||||
Right (compressed :: L.NonEmpty Compressed) -> concatMap (either (\e -> [Left e]) parseUncompressed' . decompress1 maxDecompressedMsgLength) compressed
|
||||
Right (compressed :: L.NonEmpty Compressed) -> case traverse decompressedSize compressed of
|
||||
Nothing -> [Left "compressed size not specified"]
|
||||
Just sizes
|
||||
| sum sizes > maxDecompressedMsgLength -> [Left "decompressed size exceeds limit"]
|
||||
| otherwise -> concatMap (either (\e -> [Left e]) parseUncompressed' . decompress1) compressed
|
||||
parseUncompressed' "" = [Left "empty string"]
|
||||
parseUncompressed' s = parseUncompressed (B.head s) s
|
||||
-- Binary batch format: '=' <count:1> (<len:2> <body>)*
|
||||
@@ -872,7 +974,7 @@ parseMsgContainer v = do
|
||||
file <- v .:? "file"
|
||||
ttl <- v .:? "ttl"
|
||||
live <- v .:? "live"
|
||||
mentions <- fromMaybe M.empty <$> (v .:? "mentions")
|
||||
mentions <- MsgMentions . fromMaybe M.empty <$> (v .:? "mentions")
|
||||
scope <- v .:? "scope"
|
||||
asGroup <- v .:? "asGroup"
|
||||
quote <- v .:? "quote"
|
||||
@@ -892,47 +994,8 @@ justTrue :: Bool -> Maybe Bool
|
||||
justTrue True = Just True
|
||||
justTrue False = Nothing
|
||||
|
||||
instance FromJSON MsgContent where
|
||||
parseJSON (J.Object v) =
|
||||
v .: "type" >>= \case
|
||||
MCText_ -> MCText <$> v .: "text"
|
||||
MCLink_ -> do
|
||||
text <- v .: "text"
|
||||
preview <- v .: "preview"
|
||||
pure MCLink {text, preview}
|
||||
MCImage_ -> do
|
||||
text <- v .: "text"
|
||||
image <- v .: "image"
|
||||
pure MCImage {text, image}
|
||||
MCVideo_ -> do
|
||||
text <- v .: "text"
|
||||
image <- v .: "image"
|
||||
duration <- v .: "duration"
|
||||
pure MCVideo {text, image, duration}
|
||||
MCVoice_ -> do
|
||||
text <- v .: "text"
|
||||
duration <- v .: "duration"
|
||||
pure MCVoice {text, duration}
|
||||
MCFile_ -> MCFile <$> v .: "text"
|
||||
MCReport_ -> do
|
||||
text <- v .: "text"
|
||||
reason <- v .: "reason"
|
||||
pure MCReport {text, reason}
|
||||
MCChat_ -> do
|
||||
text <- v .: "text"
|
||||
chatLink <- v .: "chatLink"
|
||||
pure MCChat {text, chatLink}
|
||||
MCUnknown_ tag -> do
|
||||
text <- fromMaybe unknownMsgType <$> v .:? "text"
|
||||
pure MCUnknown {tag, text, json = v}
|
||||
parseJSON invalid =
|
||||
JT.prependFailure "bad MsgContent, " (JT.typeMismatch "Object" invalid)
|
||||
|
||||
unknownMsgType :: Text
|
||||
unknownMsgType = "unknown message type"
|
||||
|
||||
msgContainerJSON :: MsgContainer -> J.Object
|
||||
msgContainerJSON MsgContainer {content, mentions, file, ttl, live, scope, asGroup, quote, parent, forward} =
|
||||
msgContainerJSON MsgContainer {content, mentions = MsgMentions mentions, file, ttl, live, scope, asGroup, quote, parent, forward} =
|
||||
JM.fromList $
|
||||
discriminators
|
||||
<> ("file" .=? file) (("ttl" .=? ttl) (("live" .=? live) (("mentions" .=? nonEmptyMap mentions) (("scope" .=? scope) (("asGroup" .=? asGroup) ["content" .= content])))))
|
||||
@@ -946,28 +1009,6 @@ nonEmptyMap :: Map k v -> Maybe (Map k v)
|
||||
nonEmptyMap m = if M.null m then Nothing else Just m
|
||||
{-# INLINE nonEmptyMap #-}
|
||||
|
||||
instance ToJSON MsgContent where
|
||||
toJSON = \case
|
||||
MCUnknown {json} -> J.Object json
|
||||
MCText t -> J.object ["type" .= MCText_, "text" .= t]
|
||||
MCLink {text, preview} -> J.object ["type" .= MCLink_, "text" .= text, "preview" .= preview]
|
||||
MCImage {text, image} -> J.object ["type" .= MCImage_, "text" .= text, "image" .= image]
|
||||
MCVideo {text, image, duration} -> J.object ["type" .= MCVideo_, "text" .= text, "image" .= image, "duration" .= duration]
|
||||
MCVoice {text, duration} -> J.object ["type" .= MCVoice_, "text" .= text, "duration" .= duration]
|
||||
MCFile t -> J.object ["type" .= MCFile_, "text" .= t]
|
||||
MCReport {text, reason} -> J.object ["type" .= MCReport_, "text" .= text, "reason" .= reason]
|
||||
MCChat {text, chatLink} -> J.object ["type" .= MCChat_, "text" .= text, "chatLink" .= chatLink]
|
||||
toEncoding = \case
|
||||
MCUnknown {json} -> JE.value $ J.Object json
|
||||
MCText t -> J.pairs $ "type" .= MCText_ <> "text" .= t
|
||||
MCLink {text, preview} -> J.pairs $ "type" .= MCLink_ <> "text" .= text <> "preview" .= preview
|
||||
MCImage {text, image} -> J.pairs $ "type" .= MCImage_ <> "text" .= text <> "image" .= image
|
||||
MCVideo {text, image, duration} -> J.pairs $ "type" .= MCVideo_ <> "text" .= text <> "image" .= image <> "duration" .= duration
|
||||
MCVoice {text, duration} -> J.pairs $ "type" .= MCVoice_ <> "text" .= text <> "duration" .= duration
|
||||
MCFile t -> J.pairs $ "type" .= MCFile_ <> "text" .= t
|
||||
MCReport {text, reason} -> J.pairs $ "type" .= MCReport_ <> "text" .= text <> "reason" .= reason
|
||||
MCChat {text, chatLink} -> J.pairs $ "type" .= MCChat_ <> "text" .= text <> "chatLink" .= chatLink
|
||||
|
||||
instance ToField MsgContent where
|
||||
toField = toField . encodeJSON
|
||||
|
||||
@@ -1000,6 +1041,7 @@ data CMEventTag (e :: MsgEncoding) where
|
||||
XGrpRelayInv_ :: CMEventTag 'Json
|
||||
XGrpRelayAcpt_ :: CMEventTag 'Json
|
||||
XGrpRelayTest_ :: CMEventTag 'Json
|
||||
XGrpRelayNew_ :: CMEventTag 'Json
|
||||
XGrpMemNew_ :: CMEventTag 'Json
|
||||
XGrpMemIntro_ :: CMEventTag 'Json
|
||||
XGrpMemInv_ :: CMEventTag 'Json
|
||||
@@ -1057,6 +1099,7 @@ instance MsgEncodingI e => StrEncoding (CMEventTag e) where
|
||||
XGrpRelayInv_ -> "x.grp.relay.inv"
|
||||
XGrpRelayAcpt_ -> "x.grp.relay.acpt"
|
||||
XGrpRelayTest_ -> "x.grp.relay.test"
|
||||
XGrpRelayNew_ -> "x.grp.relay.new"
|
||||
XGrpMemNew_ -> "x.grp.mem.new"
|
||||
XGrpMemIntro_ -> "x.grp.mem.intro"
|
||||
XGrpMemInv_ -> "x.grp.mem.inv"
|
||||
@@ -1115,6 +1158,7 @@ instance StrEncoding ACMEventTag where
|
||||
"x.grp.relay.inv" -> XGrpRelayInv_
|
||||
"x.grp.relay.acpt" -> XGrpRelayAcpt_
|
||||
"x.grp.relay.test" -> XGrpRelayTest_
|
||||
"x.grp.relay.new" -> XGrpRelayNew_
|
||||
"x.grp.mem.new" -> XGrpMemNew_
|
||||
"x.grp.mem.intro" -> XGrpMemIntro_
|
||||
"x.grp.mem.inv" -> XGrpMemInv_
|
||||
@@ -1169,6 +1213,7 @@ toCMEventTag msg = case msg of
|
||||
XGrpRelayInv _ -> XGrpRelayInv_
|
||||
XGrpRelayAcpt _ -> XGrpRelayAcpt_
|
||||
XGrpRelayTest {} -> XGrpRelayTest_
|
||||
XGrpRelayNew _ -> XGrpRelayNew_
|
||||
XGrpMemNew {} -> XGrpMemNew_
|
||||
XGrpMemIntro _ _ -> XGrpMemIntro_
|
||||
XGrpMemInv _ _ -> XGrpMemInv_
|
||||
@@ -1241,6 +1286,7 @@ requiresSignature = \case
|
||||
XGrpMemRole_ -> True
|
||||
XGrpMemRestrict_ -> True
|
||||
XGrpLeave_ -> True
|
||||
XGrpRelayNew_ -> True
|
||||
XInfo_ -> True
|
||||
_ -> False
|
||||
|
||||
@@ -1326,6 +1372,7 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
B64UrlByteString challenge <- p "challenge"
|
||||
sig_ <- fmap (\(B64UrlByteString s) -> s) <$> opt "signature"
|
||||
pure $ XGrpRelayTest challenge sig_
|
||||
XGrpRelayNew_ -> XGrpRelayNew <$> p "relayLink"
|
||||
XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" <*> opt "scope"
|
||||
XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" <*> opt "memberRestrictions"
|
||||
XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro"
|
||||
@@ -1358,9 +1405,6 @@ appJsonToCM AppMessageJson {v, msgId, event, params} = do
|
||||
XOk_ -> pure XOk
|
||||
XUnknown_ t -> pure $ XUnknown t params
|
||||
|
||||
(.=?) :: ToJSON v => JT.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)]
|
||||
key .=? value = maybe id ((:) . (key .=)) value
|
||||
|
||||
chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e
|
||||
chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case encoding @e of
|
||||
SBinary -> AMBinary AppMessageBinary {msgId = Nothing, tag = B.head $ strEncode tag, body = chatMsgBinaryToBody chatMsg}
|
||||
@@ -1396,6 +1440,7 @@ chatToAppMessage chatMsg@ChatMessage {chatVRange, msgId, chatMsgEvent} = case en
|
||||
XGrpRelayTest challenge sig_ -> o $
|
||||
("signature" .=? (B64UrlByteString <$> sig_))
|
||||
["challenge" .= B64UrlByteString challenge]
|
||||
XGrpRelayNew relayLink -> o ["relayLink" .= relayLink]
|
||||
XGrpMemNew memInfo scope -> o $ ("scope" .=? scope) ["memberInfo" .= memInfo]
|
||||
XGrpMemIntro memInfo memRestrictions -> o $ ("memberRestrictions" .=? memRestrictions) ["memberInfo" .= memInfo]
|
||||
XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro]
|
||||
|
||||
@@ -79,7 +79,7 @@ minRemoteCtrlVersion = AppVersion [6, 5, 0, 12]
|
||||
|
||||
-- when acting as controller
|
||||
minRemoteHostVersion :: AppVersion
|
||||
minRemoteHostVersion = AppVersion [6, 4, 6, 0]
|
||||
minRemoteHostVersion = AppVersion [6, 5, 0, 12]
|
||||
|
||||
currentAppVersion :: AppVersion
|
||||
currentAppVersion = AppVersion SC.version
|
||||
|
||||
@@ -429,6 +429,14 @@ updatePreparedContactUser
|
||||
WHERE contact_profile_id = ?
|
||||
|]
|
||||
(newUserId, currentTs, profileId)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items
|
||||
SET user_id = ?, updated_at = ?
|
||||
WHERE contact_id = ?
|
||||
|]
|
||||
(newUserId, currentTs, contactId)
|
||||
safeDeleteLDN db user oldLDN
|
||||
getContact db vr newUser contactId
|
||||
|
||||
|
||||
@@ -94,6 +94,9 @@ module Simplex.Chat.Store.Groups
|
||||
setGroupInProgressDone,
|
||||
createRelayRequestGroup,
|
||||
updateRelayOwnStatusFromTo,
|
||||
updateRelayOwnStatus_,
|
||||
getRelayServedGroups,
|
||||
getRelayInactiveGroups,
|
||||
createNewContactMemberAsync,
|
||||
createJoiningMember,
|
||||
getMemberJoinRequest,
|
||||
@@ -188,7 +191,7 @@ import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)
|
||||
import Data.Ord (Down (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, getCurrentTime)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Operators
|
||||
@@ -687,6 +690,14 @@ updatePreparedGroupUser db vr user gInfo@GroupInfo {groupId, membership} hostMem
|
||||
WHERE group_profile_id IN (SELECT group_profile_id FROM groups WHERE group_id = ?)
|
||||
|]
|
||||
(newUserId, currentTs, groupId)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE chat_items
|
||||
SET user_id = ?, updated_at = ?
|
||||
WHERE group_id = ?
|
||||
|]
|
||||
(newUserId, currentTs, groupId)
|
||||
safeDeleteLDN db user oldGroupLDN
|
||||
updateMembership GroupMember {groupMemberId = membershipId} currentTs =
|
||||
DB.execute
|
||||
@@ -1370,7 +1381,12 @@ getCreateRelayForMember db vr gVar user@User {userId, userContactId} GroupInfo {
|
||||
maybeFirstRow (toContactMember vr user) $
|
||||
DB.query
|
||||
db
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.relay_link = ?")
|
||||
#if defined(dbPostgres)
|
||||
(groupMemberQuery <> " WHERE m.group_id = ? AND m.relay_link = ? AND is_current_member(m.member_status)")
|
||||
#else
|
||||
-- skips GSMemLeft historical rows so re-add allocates a fresh row instead of resurrecting
|
||||
(groupMemberQuery <> " JOIN group_member_status_predicates sp ON m.member_status = sp.member_status WHERE m.group_id = ? AND m.relay_link = ? AND sp.current_member = 1")
|
||||
#endif
|
||||
(groupId, relayLink)
|
||||
createRelayMember = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
@@ -1507,8 +1523,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 -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMember, fromMemberProfile, relayMemberId, groupLink} invId reqChatVRange = do
|
||||
createRelayRequestGroup :: DB.Connection -> VersionRangeChat -> User -> GroupRelayInvitation -> InvitationId -> VersionRangeChat -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMember, fromMemberProfile, relayMemberId, groupLink} invId reqChatVRange initialDelay = do
|
||||
currentTs <- liftIO getCurrentTime
|
||||
-- Create group with placeholder profile
|
||||
let Profile {displayName = fromMemberLDN} = fromMemberProfile
|
||||
@@ -1524,7 +1540,7 @@ createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMembe
|
||||
}
|
||||
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just RSInvited) Nothing currentTs
|
||||
-- Store relay request data for recovery
|
||||
liftIO $ setRelayRequestData_ groupId
|
||||
liftIO $ setRelayRequestData_ groupId currentTs
|
||||
ownerMemberId <- insertOwner_ currentTs groupId
|
||||
let relayMember = MemberIdRole relayMemberId GRRelay
|
||||
-- TODO [member keys] should relays use member keys?
|
||||
@@ -1533,7 +1549,7 @@ createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMembe
|
||||
g <- getGroupInfo db vr user groupId
|
||||
pure (g, ownerMember)
|
||||
where
|
||||
setRelayRequestData_ groupId =
|
||||
setRelayRequestData_ groupId currentTs =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -1541,12 +1557,15 @@ createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMembe
|
||||
SET relay_request_inv_id = ?,
|
||||
relay_request_group_link = ?,
|
||||
relay_request_peer_chat_min_version = ?,
|
||||
relay_request_peer_chat_max_version = ?
|
||||
relay_request_peer_chat_max_version = ?,
|
||||
relay_request_delay = ?,
|
||||
relay_request_execute_at = ?
|
||||
WHERE group_id = ?
|
||||
|]
|
||||
(Binary invId, groupLink, minVersion reqChatVRange, maxVersion reqChatVRange, groupId)
|
||||
(Binary invId, groupLink, minVersion reqChatVRange, maxVersion reqChatVRange, initialDelay, currentTs, groupId)
|
||||
insertOwner_ currentTs groupId = do
|
||||
let MemberIdRole {memberId, memberRole} = fromMember
|
||||
VersionRange minV maxV = reqChatVRange
|
||||
(localDisplayName, profileId) <- createNewMemberProfile_ db user fromMemberProfile currentTs
|
||||
indexInGroup <- getUpdateNextIndexInGroup_ db groupId
|
||||
liftIO $ do
|
||||
@@ -1555,11 +1574,13 @@ createRelayRequestGroup db vr user@User {userId} GroupRelayInvitation {fromMembe
|
||||
[sql|
|
||||
INSERT INTO group_members
|
||||
( group_id, index_in_group, member_id, member_role, member_category, member_status,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
|
||||
peer_chat_min_version, peer_chat_max_version)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (groupId, indexInGroup, memberId, memberRole, GCHostMember, GSMemAccepted)
|
||||
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, currentTs, currentTs)
|
||||
:. (minV, maxV)
|
||||
)
|
||||
insertedRowId db
|
||||
|
||||
@@ -1572,7 +1593,29 @@ updateRelayOwnStatusFromTo db gInfo@GroupInfo {groupId} fromStatus toStatus = do
|
||||
updateRelayOwnStatus_ :: DB.Connection -> GroupInfo -> RelayStatus -> IO ()
|
||||
updateRelayOwnStatus_ db GroupInfo {groupId} relayStatus = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute db "UPDATE groups SET relay_own_status = ?, updated_at = ? WHERE group_id = ?" (relayStatus, currentTs, groupId)
|
||||
let inactiveAt_ = if relayStatus == RSInactive then Just currentTs else Nothing
|
||||
DB.execute db "UPDATE groups SET relay_own_status = ?, relay_inactive_at = ?, updated_at = ? WHERE group_id = ?" (relayStatus, inactiveAt_, currentTs, groupId)
|
||||
|
||||
getRelayServedGroups :: DB.Connection -> VersionRangeChat -> User -> IO [GroupInfo]
|
||||
getRelayServedGroups db vr User {userId, userContactId} = do
|
||||
map (toGroupInfo vr userContactId [])
|
||||
<$> DB.query
|
||||
db
|
||||
( groupInfoQuery
|
||||
<> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.relay_own_status IN (?, ?)"
|
||||
)
|
||||
(userId, userContactId, RSAccepted, RSActive)
|
||||
|
||||
getRelayInactiveGroups :: DB.Connection -> VersionRangeChat -> User -> NominalDiffTime -> IO [GroupInfo]
|
||||
getRelayInactiveGroups db vr User {userId, userContactId} ttl = do
|
||||
cutoffTs <- addUTCTime (- ttl) <$> getCurrentTime
|
||||
map (toGroupInfo vr userContactId [])
|
||||
<$> DB.query
|
||||
db
|
||||
( groupInfoQuery
|
||||
<> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.relay_own_status = ? AND g.relay_inactive_at IS NOT NULL AND g.relay_inactive_at <= ?"
|
||||
)
|
||||
(userId, userContactId, RSInactive, cutoffTs)
|
||||
|
||||
createNewContactMemberAsync :: DB.Connection -> TVar ChaChaDRG -> User -> GroupInfo -> Contact -> GroupMemberRole -> (CommandId, ConnId) -> VersionChat -> VersionRangeChat -> SubscriptionMode -> ExceptT StoreError IO ()
|
||||
createNewContactMemberAsync db gVar user@User {userId, userContactId} GroupInfo {groupId, membership} Contact {contactId, localDisplayName, profile} memberRole (cmdId, agentConnId) chatV peerChatVRange subMode =
|
||||
@@ -1801,12 +1844,12 @@ updatePublicMemberCount db vr user GroupInfo {groupId} = do
|
||||
relayCount <- fromMaybe 0 <$> maybeFirstRow fromOnly
|
||||
(DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT COUNT(1) FROM group_members
|
||||
WHERE group_id = ? AND member_role = ?
|
||||
AND member_status IN (?,?,?,?,?,?,?)
|
||||
|]
|
||||
(groupId, GRRelay, GSMemIntroduced, GSMemIntroInvited, GSMemAccepted, GSMemAnnounced, GSMemConnected, GSMemComplete, GSMemCreator))
|
||||
#if defined(dbPostgres)
|
||||
"SELECT COUNT(1) FROM group_members WHERE group_id = ? AND member_role = ? AND is_current_member(member_status)"
|
||||
#else
|
||||
"SELECT COUNT(1) FROM group_members m JOIN group_member_status_predicates sp ON m.member_status = sp.member_status WHERE m.group_id = ? AND m.member_role = ? AND sp.current_member = 1"
|
||||
#endif
|
||||
(groupId, GRRelay))
|
||||
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)
|
||||
@@ -2976,8 +3019,8 @@ createNewUnknownGroupMember db vr user@User {userId, userContactId} GroupInfo {g
|
||||
where
|
||||
VersionRange minV maxV = vr
|
||||
|
||||
createLinkOwnerMember :: DB.Connection -> VersionRangeChat -> User -> GroupInfo -> MemberId -> C.PublicKeyEd25519 -> ExceptT StoreError IO GroupMember
|
||||
createLinkOwnerMember db vr user@User {userId, userContactId} GroupInfo {groupId} memberId ownerKey = do
|
||||
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
|
||||
currentTs <- liftIO getCurrentTime
|
||||
let memberProfile = profileFromName $ nameFromMemberId memberId
|
||||
(localDisplayName, profileId) <- createNewMemberProfile_ db user memberProfile currentTs
|
||||
@@ -2993,7 +3036,7 @@ createLinkOwnerMember db vr user@User {userId, userContactId} GroupInfo {groupId
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
( (groupId, indexInGroup, memberId, GROwner, GCPreMember, GSMemUnknown, Binary B.empty, fromInvitedBy userContactId IBUnknown)
|
||||
:. (userId, localDisplayName, Nothing :: (Maybe Int64), profileId, ownerKey, currentTs, currentTs)
|
||||
:. (userId, localDisplayName, contactId_, profileId, ownerKey, currentTs, currentTs)
|
||||
:. (minV, maxV)
|
||||
)
|
||||
groupMemberId <- liftIO $ insertedRowId db
|
||||
|
||||
@@ -234,7 +234,7 @@ createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage
|
||||
ECMEncoded msgBody -> do
|
||||
let signedMsg_ = signBody <$> msgSigning_
|
||||
signBody MsgSigning {bindingTag, bindingData, keyRef, privKey} =
|
||||
let sig = C.ASignature C.SEd25519 $ C.sign' privKey (smpEncode bindingTag <> bindingData <> msgBody)
|
||||
let sig = C.ASignature C.SEd25519 $ C.sign' privKey (encodeChatBinding bindingTag bindingData <> msgBody)
|
||||
in SignedMsg {chatBinding = bindingTag, signatures = MsgSignature keyRef sig :| [], signedBody = msgBody}
|
||||
createdAt <- getCurrentTime
|
||||
DB.execute
|
||||
@@ -245,7 +245,7 @@ createNewSndMessage db gVar connOrGroupId chatMsgEvent msgSigning_ encodeMessage
|
||||
shared_msg_id, shared_msg_id_user, created_at, updated_at
|
||||
) VALUES (?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, chatBinding <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, connId_, groupId_)
|
||||
((MDSnd, toCMEventTag chatMsgEvent, DB.Binary msgBody, (\SignedMsg {chatBinding} -> chatBinding) <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, connId_, groupId_)
|
||||
:. (DB.Binary sharedMsgId, Just (BI True), createdAt, createdAt))
|
||||
msgId <- insertedRowId db
|
||||
pure $ Right SndMessage {msgId, sharedMsgId = SharedMsgId sharedMsgId, msgBody, signedMsg_}
|
||||
@@ -332,7 +332,7 @@ createNewRcvMessage db connOrGroupId NewRcvMessage {chatMsgEvent, verifiedMsg, b
|
||||
shared_msg_id, author_group_member_id, forwarded_by_group_member_id)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, chatBinding <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, brokerTs, currentTs, currentTs, connId_, groupId_)
|
||||
((MDRcv, toCMEventTag chatMsgEvent, DB.Binary msgBody, (\SignedMsg {chatBinding} -> chatBinding) <$> signedMsg_, DB.Binary . smpEncode . signatures <$> signedMsg_, brokerTs, currentTs, currentTs, connId_, groupId_)
|
||||
:. (sharedMsgId_, authorMember, forwardedByMember))
|
||||
msgId <- insertedRowId db
|
||||
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgSigned, forwardedByMember}
|
||||
@@ -563,7 +563,9 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent, msgS
|
||||
quotedItem <- mapM (getChatItemQuote_ db user chatDirection) quotedMsg
|
||||
pure (ciId, quotedItem, itemForwarded)
|
||||
where
|
||||
itemForwarded = cmForwardedFrom chatMsgEvent
|
||||
itemForwarded = case chatMsgEvent of
|
||||
ACME _ (XMsgNew MsgContainer {forward}) | forward == Just True -> Just CIFFUnknown
|
||||
_ -> Nothing
|
||||
quotedMsg = cmToQuotedMsg chatMsgEvent
|
||||
quoteRow :: NewQuoteRow
|
||||
quoteRow = case quotedMsg of
|
||||
|
||||
@@ -29,6 +29,8 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260122_has_link
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260222_chat_relays
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260403_item_viewed
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260407_channel_comments
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260429_relay_request_retries
|
||||
import Simplex.Chat.Store.Postgres.Migrations.M20260507_relay_inactive_at
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Text, Maybe Text)]
|
||||
@@ -57,7 +59,9 @@ schemaMigrations =
|
||||
("20260122_has_link", m20260122_has_link, Just down_m20260122_has_link),
|
||||
("20260222_chat_relays", m20260222_chat_relays, Just down_m20260222_chat_relays),
|
||||
("20260403_item_viewed", m20260403_item_viewed, Just down_m20260403_item_viewed),
|
||||
("20260407_channel_comments", m20260407_channel_comments, Just down_m20260407_channel_comments)
|
||||
("20260407_channel_comments", m20260407_channel_comments, Just down_m20260407_channel_comments),
|
||||
("20260429_relay_request_retries", m20260429_relay_request_retries, Just down_m20260429_relay_request_retries),
|
||||
("20260507_relay_inactive_at", m20260507_relay_inactive_at, Just down_m20260507_relay_inactive_at)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,23 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Store.Postgres.Migrations.M20260429_relay_request_retries where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20260429_relay_request_retries :: Text
|
||||
m20260429_relay_request_retries =
|
||||
[r|
|
||||
ALTER TABLE groups ADD COLUMN relay_request_retries BIGINT NOT NULL DEFAULT 0;
|
||||
ALTER TABLE groups ADD COLUMN relay_request_delay BIGINT NOT NULL DEFAULT 0;
|
||||
ALTER TABLE groups ADD COLUMN relay_request_execute_at TIMESTAMPTZ NOT NULL DEFAULT '1970-01-01 00:00:00+00';
|
||||
|]
|
||||
|
||||
down_m20260429_relay_request_retries :: Text
|
||||
down_m20260429_relay_request_retries =
|
||||
[r|
|
||||
ALTER TABLE groups DROP COLUMN relay_request_retries;
|
||||
ALTER TABLE groups DROP COLUMN relay_request_delay;
|
||||
ALTER TABLE groups DROP COLUMN relay_request_execute_at;
|
||||
|]
|
||||
@@ -0,0 +1,19 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Store.Postgres.Migrations.M20260507_relay_inactive_at where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
m20260507_relay_inactive_at :: Text
|
||||
m20260507_relay_inactive_at =
|
||||
[r|
|
||||
ALTER TABLE groups ADD COLUMN relay_inactive_at TIMESTAMPTZ;
|
||||
|]
|
||||
|
||||
down_m20260507_relay_inactive_at :: Text
|
||||
down_m20260507_relay_inactive_at =
|
||||
[r|
|
||||
ALTER TABLE groups DROP COLUMN relay_inactive_at;
|
||||
|]
|
||||
@@ -959,7 +959,11 @@ CREATE TABLE test_chat_schema.groups (
|
||||
root_priv_key bytea,
|
||||
root_pub_key bytea,
|
||||
member_priv_key bytea,
|
||||
public_member_count bigint
|
||||
public_member_count bigint,
|
||||
relay_request_retries bigint DEFAULT 0 NOT NULL,
|
||||
relay_request_delay bigint DEFAULT 0 NOT NULL,
|
||||
relay_request_execute_at timestamp with time zone DEFAULT '1970-01-01 04:00:00+04'::timestamp with time zone NOT NULL,
|
||||
relay_inactive_at timestamp with time zone
|
||||
);
|
||||
|
||||
|
||||
|
||||
@@ -9,13 +9,15 @@
|
||||
module Simplex.Chat.Store.RelayRequests
|
||||
( hasPendingRelayRequests,
|
||||
getNextPendingRelayRequest,
|
||||
updateRelayRequestRetries,
|
||||
setRelayRequestErr,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Shared
|
||||
@@ -64,7 +66,7 @@ getNextPendingRelayRequest db =
|
||||
WHERE relay_own_status = ?
|
||||
AND relay_request_failed = 0
|
||||
AND relay_request_err_reason IS NULL
|
||||
ORDER BY group_id ASC
|
||||
ORDER BY relay_request_execute_at ASC
|
||||
LIMIT 1
|
||||
|]
|
||||
(Only RSInvited)
|
||||
@@ -76,18 +78,27 @@ getNextPendingRelayRequest db =
|
||||
[sql|
|
||||
SELECT
|
||||
relay_request_inv_id, relay_request_group_link,
|
||||
relay_request_peer_chat_min_version, relay_request_peer_chat_max_version
|
||||
relay_request_peer_chat_min_version, relay_request_peer_chat_max_version,
|
||||
relay_request_delay, relay_request_retries, created_at, relay_request_execute_at
|
||||
FROM groups
|
||||
WHERE group_id = ?
|
||||
|]
|
||||
(Only groupId)
|
||||
where
|
||||
toRelayRequestData :: (Maybe InvitationId, Maybe ShortLinkContact, Maybe VersionChat, Maybe VersionChat) -> Either StoreError (GroupId, RelayRequestData)
|
||||
toRelayRequestData :: (Maybe InvitationId, Maybe ShortLinkContact, Maybe VersionChat, Maybe VersionChat, Int64, Int, UTCTime, UTCTime) -> Either StoreError (GroupId, RelayRequestData)
|
||||
toRelayRequestData = \case
|
||||
(Just relayInvId, Just reqGroupLink, Just minV, Just maxV) ->
|
||||
Right (groupId, RelayRequestData {relayInvId, reqGroupLink, reqChatVRange = fromMaybe (versionToRange maxV) $ safeVersionRange minV maxV})
|
||||
(Just relayInvId, Just reqGroupLink, Just minV, Just maxV, reqDelay, reqRetries, reqCreatedAt, reqExecuteAt) ->
|
||||
Right (groupId, RelayRequestData {relayInvId, reqGroupLink, reqChatVRange = fromMaybe (versionToRange maxV) $ safeVersionRange minV maxV, reqDelay, reqRetries, reqCreatedAt, reqExecuteAt})
|
||||
_ -> Left $ SEInternalError "missing relay request data"
|
||||
|
||||
updateRelayRequestRetries :: DB.Connection -> GroupId -> Int64 -> UTCTime -> IO ()
|
||||
updateRelayRequestRetries db groupId delay executeAt = do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE groups SET relay_request_retries = relay_request_retries + 1, relay_request_delay = ?, relay_request_execute_at = ?, updated_at = ? WHERE group_id = ?"
|
||||
(delay, executeAt, currentTs, groupId)
|
||||
|
||||
markRelayRequestFailed :: DB.Connection -> GroupId -> IO ()
|
||||
markRelayRequestFailed db groupId = do
|
||||
currentTs <- getCurrentTime
|
||||
|
||||
@@ -152,6 +152,8 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260122_has_link
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260222_chat_relays
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260403_item_viewed
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260407_channel_comments
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260429_relay_request_retries
|
||||
import Simplex.Chat.Store.SQLite.Migrations.M20260507_relay_inactive_at
|
||||
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@@ -303,7 +305,9 @@ schemaMigrations =
|
||||
("20260122_has_link", m20260122_has_link, Just down_m20260122_has_link),
|
||||
("20260222_chat_relays", m20260222_chat_relays, Just down_m20260222_chat_relays),
|
||||
("20260403_item_viewed", m20260403_item_viewed, Just down_m20260403_item_viewed),
|
||||
("20260407_channel_comments", m20260407_channel_comments, Just down_m20260407_channel_comments)
|
||||
("20260407_channel_comments", m20260407_channel_comments, Just down_m20260407_channel_comments),
|
||||
("20260429_relay_request_retries", m20260429_relay_request_retries, Just down_m20260429_relay_request_retries),
|
||||
("20260507_relay_inactive_at", m20260507_relay_inactive_at, Just down_m20260507_relay_inactive_at)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
||||
@@ -0,0 +1,22 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Store.SQLite.Migrations.M20260429_relay_request_retries where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20260429_relay_request_retries :: Query
|
||||
m20260429_relay_request_retries =
|
||||
[sql|
|
||||
ALTER TABLE groups ADD COLUMN relay_request_retries INTEGER NOT NULL DEFAULT 0;
|
||||
ALTER TABLE groups ADD COLUMN relay_request_delay INTEGER NOT NULL DEFAULT 0;
|
||||
ALTER TABLE groups ADD COLUMN relay_request_execute_at TEXT NOT NULL DEFAULT '1970-01-01 00:00:00';
|
||||
|]
|
||||
|
||||
down_m20260429_relay_request_retries :: Query
|
||||
down_m20260429_relay_request_retries =
|
||||
[sql|
|
||||
ALTER TABLE groups DROP COLUMN relay_request_retries;
|
||||
ALTER TABLE groups DROP COLUMN relay_request_delay;
|
||||
ALTER TABLE groups DROP COLUMN relay_request_execute_at;
|
||||
|]
|
||||
@@ -0,0 +1,18 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Store.SQLite.Migrations.M20260507_relay_inactive_at where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20260507_relay_inactive_at :: Query
|
||||
m20260507_relay_inactive_at =
|
||||
[sql|
|
||||
ALTER TABLE groups ADD COLUMN relay_inactive_at TEXT;
|
||||
|]
|
||||
|
||||
down_m20260507_relay_inactive_at :: Query
|
||||
down_m20260507_relay_inactive_at =
|
||||
[sql|
|
||||
ALTER TABLE groups DROP COLUMN relay_inactive_at;
|
||||
|]
|
||||
@@ -1197,6 +1197,10 @@ Query: UPDATE connections SET smp_agent_version = ? WHERE conn_id = ?
|
||||
Plan:
|
||||
SEARCH connections USING PRIMARY KEY (conn_id=?)
|
||||
|
||||
Query: UPDATE deleted_snd_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE deleted_snd_chunk_replica_id = ?
|
||||
Plan:
|
||||
SEARCH deleted_snd_chunk_replicas USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE messages SET msg_body = x'' WHERE conn_id = ? AND internal_id = ?
|
||||
Plan:
|
||||
SEARCH messages USING PRIMARY KEY (conn_id=? AND internal_id=?)
|
||||
@@ -1205,10 +1209,6 @@ Query: UPDATE ratchets SET ratchet_state = ? WHERE conn_id = ?
|
||||
Plan:
|
||||
SEARCH ratchets USING PRIMARY KEY (conn_id=?)
|
||||
|
||||
Query: UPDATE rcv_file_chunk_replicas SET delay = ?, retries = retries + 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?
|
||||
Plan:
|
||||
SEARCH rcv_file_chunk_replicas USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE rcv_file_chunk_replicas SET received = 1, updated_at = ? WHERE rcv_file_chunk_replica_id = ?
|
||||
Plan:
|
||||
SEARCH rcv_file_chunk_replicas USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
@@ -446,6 +446,14 @@ Query:
|
||||
Plan:
|
||||
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query:
|
||||
UPDATE chat_items
|
||||
SET user_id = ?, updated_at = ?
|
||||
WHERE group_id = ?
|
||||
|
||||
Plan:
|
||||
SEARCH chat_items USING COVERING INDEX idx_chat_items_group_id (group_id=?)
|
||||
|
||||
Query:
|
||||
UPDATE contact_profiles
|
||||
SET display_name = ?,
|
||||
@@ -515,8 +523,9 @@ SEARCH users USING COVERING INDEX sqlite_autoindex_users_1 (contact_id=?)
|
||||
Query:
|
||||
INSERT INTO group_members
|
||||
( group_id, index_in_group, member_id, member_role, member_category, member_status,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
user_id, local_display_name, contact_id, contact_profile_id, created_at, updated_at,
|
||||
peer_chat_min_version, peer_chat_max_version)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|
||||
Plan:
|
||||
SEARCH group_relays USING COVERING INDEX idx_group_relays_group_member_id (group_member_id=?)
|
||||
@@ -686,7 +695,8 @@ SEARCH delivery_jobs USING INTEGER PRIMARY KEY (rowid=?)
|
||||
Query:
|
||||
SELECT
|
||||
relay_request_inv_id, relay_request_group_link,
|
||||
relay_request_peer_chat_min_version, relay_request_peer_chat_max_version
|
||||
relay_request_peer_chat_min_version, relay_request_peer_chat_max_version,
|
||||
relay_request_delay, relay_request_retries, created_at, relay_request_execute_at
|
||||
FROM groups
|
||||
WHERE group_id = ?
|
||||
|
||||
@@ -984,11 +994,12 @@ Query:
|
||||
WHERE relay_own_status = ?
|
||||
AND relay_request_failed = 0
|
||||
AND relay_request_err_reason IS NULL
|
||||
ORDER BY group_id ASC
|
||||
ORDER BY relay_request_execute_at ASC
|
||||
LIMIT 1
|
||||
|
||||
Plan:
|
||||
SCAN groups
|
||||
USE TEMP B-TREE FOR ORDER BY
|
||||
|
||||
Query:
|
||||
SELECT i.chat_item_id
|
||||
@@ -1063,6 +1074,14 @@ SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
|
||||
SEARCH g USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
|
||||
SEARCH h USING INDEX idx_sent_probe_hashes_sent_probe_id (sent_probe_id=?)
|
||||
|
||||
Query:
|
||||
UPDATE chat_items
|
||||
SET user_id = ?, updated_at = ?
|
||||
WHERE contact_id = ?
|
||||
|
||||
Plan:
|
||||
SEARCH chat_items USING COVERING INDEX idx_chat_items_contact_id (contact_id=?)
|
||||
|
||||
Query:
|
||||
UPDATE chat_items SET item_status = ?, item_viewed = 1, updated_at = ?
|
||||
WHERE user_id = ? AND group_id = ? AND item_status = ? AND chat_item_id = ?
|
||||
@@ -1758,7 +1777,9 @@ Query:
|
||||
SET relay_request_inv_id = ?,
|
||||
relay_request_group_link = ?,
|
||||
relay_request_peer_chat_min_version = ?,
|
||||
relay_request_peer_chat_max_version = ?
|
||||
relay_request_peer_chat_max_version = ?,
|
||||
relay_request_delay = ?,
|
||||
relay_request_execute_at = ?
|
||||
WHERE group_id = ?
|
||||
|
||||
Plan:
|
||||
@@ -1842,6 +1863,41 @@ SEARCH group_members USING COVERING INDEX idx_group_members_invited_by_group_mem
|
||||
SEARCH contacts USING COVERING INDEX idx_contacts_grp_direct_inv_from_group_member_id (grp_direct_inv_from_group_member_id=?)
|
||||
SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (contact_group_member_id=?)
|
||||
|
||||
Query:
|
||||
INSERT INTO group_members
|
||||
( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by,
|
||||
user_id, local_display_name, contact_id, contact_profile_id, member_pub_key, created_at, updated_at,
|
||||
peer_chat_min_version, peer_chat_max_version)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|
||||
Plan:
|
||||
SEARCH group_relays USING COVERING INDEX idx_group_relays_group_member_id (group_member_id=?)
|
||||
SEARCH delivery_jobs USING COVERING INDEX idx_delivery_jobs_single_sender_group_member_id (single_sender_group_member_id=?)
|
||||
SEARCH delivery_jobs USING COVERING INDEX idx_delivery_jobs_job_scope_support_gm_id (job_scope_support_gm_id=?)
|
||||
SEARCH delivery_tasks USING COVERING INDEX idx_delivery_tasks_sender_group_member_id (sender_group_member_id=?)
|
||||
SEARCH delivery_tasks USING COVERING INDEX idx_delivery_tasks_job_scope_support_gm_id (job_scope_support_gm_id=?)
|
||||
SEARCH received_probes USING COVERING INDEX idx_received_probes_group_member_id (group_member_id=?)
|
||||
SEARCH sent_probe_hashes USING COVERING INDEX idx_sent_probe_hashes_group_member_id (group_member_id=?)
|
||||
SEARCH sent_probes USING COVERING INDEX idx_sent_probes_group_member_id (group_member_id=?)
|
||||
SEARCH group_snd_item_statuses USING COVERING INDEX idx_group_snd_item_statuses_group_member_id (group_member_id=?)
|
||||
SEARCH chat_item_moderations USING COVERING INDEX idx_chat_item_moderations_moderator_member_id (moderator_member_id=?)
|
||||
SEARCH chat_item_reactions USING COVERING INDEX idx_chat_item_reactions_group_member_id (group_member_id=?)
|
||||
SEARCH chat_items USING COVERING INDEX idx_chat_items_group_scope_group_member_id (group_scope_group_member_id=?)
|
||||
SEARCH chat_items USING COVERING INDEX idx_chat_items_forwarded_by_group_member_id (forwarded_by_group_member_id=?)
|
||||
SEARCH chat_items USING COVERING INDEX idx_chat_items_item_deleted_by_group_member_id (item_deleted_by_group_member_id=?)
|
||||
SEARCH chat_items USING COVERING INDEX idx_chat_items_group_member_id (group_member_id=?)
|
||||
SEARCH pending_group_messages USING COVERING INDEX idx_pending_group_messages_group_member_id (group_member_id=?)
|
||||
SEARCH messages USING COVERING INDEX idx_messages_forwarded_by_group_member_id (forwarded_by_group_member_id=?)
|
||||
SEARCH messages USING COVERING INDEX idx_messages_author_group_member_id (author_group_member_id=?)
|
||||
SEARCH connections USING COVERING INDEX idx_connections_group_member_id (group_member_id=?)
|
||||
SEARCH rcv_files USING COVERING INDEX idx_rcv_files_group_member_id (group_member_id=?)
|
||||
SEARCH snd_files USING COVERING INDEX idx_snd_files_group_member_id (group_member_id=?)
|
||||
SEARCH group_member_intros USING COVERING INDEX idx_group_member_intros_to_group_member_id (to_group_member_id=?)
|
||||
SEARCH group_member_intros USING COVERING INDEX idx_group_member_intros_re_group_member_id (re_group_member_id=?)
|
||||
SEARCH group_members USING COVERING INDEX idx_group_members_invited_by_group_member_id (invited_by_group_member_id=?)
|
||||
SEARCH contacts USING COVERING INDEX idx_contacts_grp_direct_inv_from_group_member_id (grp_direct_inv_from_group_member_id=?)
|
||||
SEARCH contacts USING COVERING INDEX idx_contacts_contact_group_member_id (contact_group_member_id=?)
|
||||
|
||||
Query:
|
||||
INSERT INTO group_relays
|
||||
(group_id, group_member_id, chat_relay_id, relay_status, created_at, updated_at)
|
||||
@@ -6530,6 +6586,10 @@ Query: SELECT COUNT(1) FROM contacts WHERE user_id = ? AND chat_item_ttl > 0
|
||||
Plan:
|
||||
SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?)
|
||||
|
||||
Query: SELECT COUNT(1) FROM group_members WHERE member_role = 'owner' AND member_pub_key IS NOT NULL
|
||||
Plan:
|
||||
SCAN group_members
|
||||
|
||||
Query: SELECT COUNT(1) FROM groups WHERE user_id = ? AND chat_item_ttl > 0
|
||||
Plan:
|
||||
SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?)
|
||||
@@ -6748,6 +6808,10 @@ Query: SELECT last_insert_rowid()
|
||||
Plan:
|
||||
SCAN CONSTANT ROW
|
||||
|
||||
Query: SELECT local_display_name FROM group_members
|
||||
Plan:
|
||||
SCAN group_members USING COVERING INDEX idx_group_members_user_id_local_display_name
|
||||
|
||||
Query: SELECT max(active_order) FROM users
|
||||
Plan:
|
||||
SEARCH users
|
||||
@@ -7088,7 +7152,11 @@ Query: UPDATE groups SET public_member_count = ?, updated_at = ? WHERE group_id
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE groups SET relay_own_status = ?, updated_at = ? WHERE group_id = ?
|
||||
Query: UPDATE groups SET relay_own_status = ?, relay_inactive_at = ?, updated_at = ? WHERE group_id = ?
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE groups SET relay_request_err_reason = ?, updated_at = ? WHERE group_id = ?
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
|
||||
@@ -173,7 +173,11 @@ CREATE TABLE groups(
|
||||
root_priv_key BLOB,
|
||||
root_pub_key BLOB,
|
||||
member_priv_key BLOB,
|
||||
public_member_count INTEGER, -- received
|
||||
public_member_count INTEGER,
|
||||
relay_request_retries INTEGER NOT NULL DEFAULT 0,
|
||||
relay_request_delay INTEGER NOT NULL DEFAULT 0,
|
||||
relay_request_execute_at TEXT NOT NULL DEFAULT '1970-01-01 00:00:00',
|
||||
relay_inactive_at TEXT, -- received
|
||||
FOREIGN KEY(user_id, local_display_name)
|
||||
REFERENCES display_names(user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
|
||||
@@ -52,7 +52,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, AEventTag (..), AEvtTag (..), ConnId, ConnShortLink, ConnectionLink, ConnectionMode (..), ConnectionRequestUri, CreatedConnLink, InvitationId, SAEntity (..), UserId)
|
||||
import Simplex.Messaging.Agent.Protocol (ACorrId, ACreatedConnLink, AEventTag (..), AEvtTag (..), ConnId, ConnShortLink (..), ConnectionLink, ConnectionMode (..), ConnectionRequestUri, ContactConnType (..), CreatedConnLink (..), InvitationId, SAEntity (..), UserId)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), blobFieldDecoder, fromTextField_)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.File (CryptoFileArgs (..))
|
||||
@@ -494,9 +494,6 @@ data GroupInfo = GroupInfo
|
||||
useRelays' :: GroupInfo -> Bool
|
||||
useRelays' GroupInfo {useRelays} = isTrue useRelays
|
||||
|
||||
sendAsGroup' :: GroupInfo -> Bool
|
||||
sendAsGroup' gInfo@GroupInfo {membership} = useRelays' gInfo && memberRole' membership == GROwner
|
||||
|
||||
groupId' :: GroupInfo -> GroupId
|
||||
groupId' GroupInfo {groupId} = groupId
|
||||
|
||||
@@ -518,6 +515,18 @@ instance FromField BusinessChatType where fromField = fromTextField_ textDecode
|
||||
|
||||
instance ToField BusinessChatType where toField = toField . textEncode
|
||||
|
||||
class HasShortLink l where
|
||||
connShortLink' :: l c -> Maybe (ConnShortLink c)
|
||||
|
||||
instance HasShortLink CreatedConnLink where
|
||||
connShortLink' (CCLink _ sl) = sl
|
||||
|
||||
setShortLinkType :: ContactConnType -> CreatedLinkContact -> CreatedLinkContact
|
||||
setShortLinkType ct (CCLink cReq sl) = CCLink cReq (setShortLinkType_ ct <$> sl)
|
||||
|
||||
setShortLinkType_ :: ContactConnType -> ShortLinkContact -> ShortLinkContact
|
||||
setShortLinkType_ ct (CSLContact sch _ srv k) = CSLContact sch ct srv k
|
||||
|
||||
data PreparedGroup = PreparedGroup
|
||||
{ connLinkToConnect :: CreatedLinkContact,
|
||||
connLinkPreparedConnection :: Bool,
|
||||
@@ -757,15 +766,18 @@ fromLocalProfile LocalProfile {displayName, fullName, shortDescr, image, contact
|
||||
|
||||
data GroupType
|
||||
= GTChannel
|
||||
| GTGroup
|
||||
| GTUnknown Text
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance TextEncoding GroupType where
|
||||
textEncode = \case
|
||||
GTChannel -> "channel"
|
||||
GTGroup -> "group"
|
||||
GTUnknown tag -> tag
|
||||
textDecode s = Just $ case s of
|
||||
"channel" -> GTChannel
|
||||
"group" -> GTGroup
|
||||
tag -> GTUnknown tag
|
||||
|
||||
instance FromField GroupType where fromField = fromTextField_ textDecode
|
||||
@@ -1033,7 +1045,11 @@ data GroupMember = GroupMember
|
||||
data RelayRequestData = RelayRequestData
|
||||
{ relayInvId :: InvitationId,
|
||||
reqGroupLink :: ShortLinkContact,
|
||||
reqChatVRange :: VersionRangeChat
|
||||
reqChatVRange :: VersionRangeChat,
|
||||
reqDelay :: Int64,
|
||||
reqRetries :: Int,
|
||||
reqCreatedAt :: UTCTime,
|
||||
reqExecuteAt :: UTCTime
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
@@ -176,6 +176,7 @@ data GroupFeature
|
||||
| GFSimplexLinks
|
||||
| GFReports
|
||||
| GFHistory
|
||||
| GFSupport
|
||||
| GFSessions
|
||||
| GFComments
|
||||
deriving (Show)
|
||||
@@ -190,6 +191,7 @@ data SGroupFeature (f :: GroupFeature) where
|
||||
SGFSimplexLinks :: SGroupFeature 'GFSimplexLinks
|
||||
SGFReports :: SGroupFeature 'GFReports
|
||||
SGFHistory :: SGroupFeature 'GFHistory
|
||||
SGFSupport :: SGroupFeature 'GFSupport
|
||||
SGFSessions :: SGroupFeature 'GFSessions
|
||||
SGFComments :: SGroupFeature 'GFComments
|
||||
|
||||
@@ -218,6 +220,7 @@ groupFeatureNameText = \case
|
||||
GFSimplexLinks -> "SimpleX links"
|
||||
GFReports -> "Member reports"
|
||||
GFHistory -> "Recent history"
|
||||
GFSupport -> "Chat with admins"
|
||||
GFSessions -> "Chat sessions"
|
||||
GFComments -> "Comments"
|
||||
|
||||
@@ -233,6 +236,11 @@ groupFeatureMemberAllowed' feature role prefs =
|
||||
let pref = getGroupPreference feature prefs
|
||||
in getField @"enable" pref == FEOn && maybe True (role >=) (getField @"role" pref)
|
||||
|
||||
-- TODO: some preferences are channel-only (e.g., comments) and should not generate
|
||||
-- UI items or be configurable in regular groups. Currently they are simply excluded
|
||||
-- from this list. When more channel-only or group-only preferences are added,
|
||||
-- consider adding a scope property to GroupFeatureI (e.g., GFScopeAll | GFScopeChannel | GFScopeGroup)
|
||||
-- and filtering at the call sites in createGroupFeatureItems_ / createGroupFeatureChangedItems.
|
||||
allGroupFeatures :: [AGroupFeature]
|
||||
allGroupFeatures =
|
||||
[ AGF SGFTimedMessages,
|
||||
@@ -244,11 +252,12 @@ allGroupFeatures =
|
||||
AGF SGFSimplexLinks,
|
||||
AGF SGFReports,
|
||||
AGF SGFHistory,
|
||||
AGF SGFSupport,
|
||||
AGF SGFComments
|
||||
]
|
||||
|
||||
groupPrefSel :: SGroupFeature f -> GroupPreferences -> Maybe (GroupFeaturePreference f)
|
||||
groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, sessions, comments} = case f of
|
||||
groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, support, sessions, comments} = case f of
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
@@ -258,6 +267,7 @@ groupPrefSel f GroupPreferences {timedMessages, directMessages, fullDelete, reac
|
||||
SGFSimplexLinks -> simplexLinks
|
||||
SGFReports -> reports
|
||||
SGFHistory -> history
|
||||
SGFSupport -> support
|
||||
SGFSessions -> sessions
|
||||
SGFComments -> comments
|
||||
|
||||
@@ -272,6 +282,7 @@ toGroupFeature = \case
|
||||
SGFSimplexLinks -> GFSimplexLinks
|
||||
SGFReports -> GFReports
|
||||
SGFHistory -> GFHistory
|
||||
SGFSupport -> GFSupport
|
||||
SGFSessions -> GFSessions
|
||||
SGFComments -> GFComments
|
||||
|
||||
@@ -285,7 +296,7 @@ instance GroupPreferenceI (Maybe GroupPreferences) where
|
||||
getGroupPreference pt prefs = fromMaybe (getGroupPreference pt defaultGroupPrefs) (groupPrefSel pt =<< prefs)
|
||||
|
||||
instance GroupPreferenceI FullGroupPreferences where
|
||||
getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, sessions, comments} = case f of
|
||||
getGroupPreference f FullGroupPreferences {timedMessages, directMessages, fullDelete, reactions, voice, files, simplexLinks, reports, history, support, sessions, comments} = case f of
|
||||
SGFTimedMessages -> timedMessages
|
||||
SGFDirectMessages -> directMessages
|
||||
SGFFullDelete -> fullDelete
|
||||
@@ -295,6 +306,7 @@ instance GroupPreferenceI FullGroupPreferences where
|
||||
SGFSimplexLinks -> simplexLinks
|
||||
SGFReports -> reports
|
||||
SGFHistory -> history
|
||||
SGFSupport -> support
|
||||
SGFSessions -> sessions
|
||||
SGFComments -> comments
|
||||
{-# INLINE getGroupPreference #-}
|
||||
@@ -310,6 +322,7 @@ data GroupPreferences = GroupPreferences
|
||||
simplexLinks :: Maybe SimplexLinksGroupPreference,
|
||||
reports :: Maybe ReportsGroupPreference,
|
||||
history :: Maybe HistoryGroupPreference,
|
||||
support :: Maybe SupportGroupPreference,
|
||||
sessions :: Maybe SessionsGroupPreference,
|
||||
comments :: Maybe CommentsGroupPreference,
|
||||
commands :: Maybe [ChatBotCommand]
|
||||
@@ -361,6 +374,7 @@ setGroupPreference_ f pref prefs =
|
||||
SGFSimplexLinks -> prefs {simplexLinks = pref}
|
||||
SGFReports -> prefs {reports = pref}
|
||||
SGFHistory -> prefs {history = pref}
|
||||
SGFSupport -> prefs {support = pref}
|
||||
SGFSessions -> prefs {sessions = pref}
|
||||
SGFComments -> prefs {comments = pref}
|
||||
|
||||
@@ -404,6 +418,7 @@ data FullGroupPreferences = FullGroupPreferences
|
||||
simplexLinks :: SimplexLinksGroupPreference,
|
||||
reports :: ReportsGroupPreference,
|
||||
history :: HistoryGroupPreference,
|
||||
support :: SupportGroupPreference,
|
||||
sessions :: SessionsGroupPreference,
|
||||
comments :: CommentsGroupPreference,
|
||||
commands :: ListDef ChatBotCommand
|
||||
@@ -474,13 +489,14 @@ defaultGroupPrefs =
|
||||
simplexLinks = SimplexLinksGroupPreference {enable = FEOn, role = Nothing},
|
||||
reports = ReportsGroupPreference {enable = FEOn},
|
||||
history = HistoryGroupPreference {enable = FEOff},
|
||||
support = SupportGroupPreference {enable = FEOn},
|
||||
sessions = SessionsGroupPreference {enable = FEOff, role = Nothing},
|
||||
comments = CommentsGroupPreference {enable = FEOff, closeAfter = Nothing},
|
||||
commands = ListDef []
|
||||
}
|
||||
|
||||
emptyGroupPrefs :: GroupPreferences
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
emptyGroupPrefs = GroupPreferences Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
|
||||
|
||||
businessGroupPrefs :: Preferences -> GroupPreferences
|
||||
businessGroupPrefs Preferences {timedMessages, fullDelete, reactions, voice, files, sessions, commands} =
|
||||
@@ -511,6 +527,7 @@ defaultBusinessGroupPrefs =
|
||||
simplexLinks = Just $ SimplexLinksGroupPreference FEOn Nothing,
|
||||
reports = Just $ ReportsGroupPreference FEOff,
|
||||
history = Just $ HistoryGroupPreference FEOn,
|
||||
support = Just $ SupportGroupPreference FEOn,
|
||||
sessions = Just $ SessionsGroupPreference FEOn Nothing,
|
||||
comments = Just $ CommentsGroupPreference FEOff Nothing,
|
||||
commands = Nothing
|
||||
@@ -643,6 +660,10 @@ data HistoryGroupPreference = HistoryGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SupportGroupPreference = SupportGroupPreference
|
||||
{enable :: GroupFeatureEnabled}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data SessionsGroupPreference = SessionsGroupPreference
|
||||
{enable :: GroupFeatureEnabled, role :: Maybe GroupMemberRole}
|
||||
deriving (Eq, Show)
|
||||
@@ -695,6 +716,9 @@ instance HasField "enable" ReportsGroupPreference GroupFeatureEnabled where
|
||||
instance HasField "enable" HistoryGroupPreference GroupFeatureEnabled where
|
||||
hasField p@HistoryGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
instance HasField "enable" SupportGroupPreference GroupFeatureEnabled where
|
||||
hasField p@SupportGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
instance HasField "enable" SessionsGroupPreference GroupFeatureEnabled where
|
||||
hasField p@SessionsGroupPreference {enable} = (\e -> p {enable = e}, enable)
|
||||
|
||||
@@ -755,6 +779,12 @@ instance GroupFeatureI 'GFHistory where
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFSupport where
|
||||
type GroupFeaturePreference 'GFSupport = SupportGroupPreference
|
||||
sGroupFeature = SGFSupport
|
||||
groupPrefParam _ = Nothing
|
||||
groupPrefRole _ = Nothing
|
||||
|
||||
instance GroupFeatureI 'GFSessions where
|
||||
type GroupFeaturePreference 'GFSessions = SessionsGroupPreference
|
||||
sGroupFeature = SGFSessions
|
||||
@@ -777,6 +807,8 @@ instance GroupFeatureNoRoleI 'GFReports
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFHistory
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFSupport
|
||||
|
||||
instance GroupFeatureNoRoleI 'GFComments
|
||||
|
||||
instance HasField "role" DirectMessagesGroupPreference (Maybe GroupMemberRole) where
|
||||
@@ -969,6 +1001,7 @@ mergeGroupPreferences groupPreferences =
|
||||
simplexLinks = pref SGFSimplexLinks,
|
||||
reports = pref SGFReports,
|
||||
history = pref SGFHistory,
|
||||
support = pref SGFSupport,
|
||||
sessions = pref SGFSessions,
|
||||
comments = pref SGFComments,
|
||||
commands = ListDef $ fromMaybe [] $ groupPreferences >>= commands_
|
||||
@@ -989,6 +1022,7 @@ toGroupPreferences groupPreferences@FullGroupPreferences {commands = ListDef cmd
|
||||
simplexLinks = pref SGFSimplexLinks,
|
||||
reports = pref SGFReports,
|
||||
history = pref SGFHistory,
|
||||
support = pref SGFSupport,
|
||||
sessions = pref SGFSessions,
|
||||
comments = pref SGFComments,
|
||||
commands = Just cmds
|
||||
@@ -1119,11 +1153,13 @@ $(J.deriveJSON defaultJSON ''ReportsGroupPreference)
|
||||
|
||||
$(J.deriveJSON defaultJSON ''HistoryGroupPreference)
|
||||
|
||||
$(J.deriveToJSON defaultJSON ''SessionsGroupPreference)
|
||||
$(J.deriveToJSON defaultJSON ''SupportGroupPreference)
|
||||
|
||||
instance FromJSON SessionsGroupPreference where
|
||||
parseJSON v = $(J.mkParseJSON defaultJSON ''SessionsGroupPreference) v
|
||||
omittedField = Just SessionsGroupPreference {enable = FEOff, role = Nothing}
|
||||
instance FromJSON SupportGroupPreference where
|
||||
parseJSON v = $(J.mkParseJSON defaultJSON ''SupportGroupPreference) v
|
||||
omittedField = Just SupportGroupPreference {enable = FEOn}
|
||||
|
||||
$(J.deriveJSON defaultJSON ''SessionsGroupPreference)
|
||||
|
||||
$(J.deriveToJSON defaultJSON ''CommentsGroupPreference)
|
||||
|
||||
|
||||
@@ -86,6 +86,7 @@ data RelayStatus
|
||||
| RSInvited
|
||||
| RSAccepted
|
||||
| RSActive
|
||||
| RSInactive
|
||||
deriving (Eq, Show)
|
||||
|
||||
relayStatusText :: RelayStatus -> Text
|
||||
@@ -94,6 +95,7 @@ relayStatusText = \case
|
||||
RSInvited -> "invited"
|
||||
RSAccepted -> "accepted"
|
||||
RSActive -> "active"
|
||||
RSInactive -> "inactive"
|
||||
|
||||
instance TextEncoding RelayStatus where
|
||||
textEncode = \case
|
||||
@@ -101,11 +103,13 @@ instance TextEncoding RelayStatus where
|
||||
RSInvited -> "invited"
|
||||
RSAccepted -> "accepted"
|
||||
RSActive -> "active"
|
||||
RSInactive -> "inactive"
|
||||
textDecode = \case
|
||||
"new" -> Just RSNew
|
||||
"invited" -> Just RSInvited
|
||||
"accepted" -> Just RSAccepted
|
||||
"active" -> Just RSActive
|
||||
"inactive" -> Just RSInactive
|
||||
_ -> Nothing
|
||||
|
||||
instance FromField RelayStatus where fromField = fromTextField_ textDecode
|
||||
|
||||
+68
-12
@@ -22,7 +22,7 @@ import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Char (isSpace, toUpper)
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intercalate, intersperse, sortOn)
|
||||
import Data.List (groupBy, intercalate, intersperse, nub, sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
@@ -148,8 +148,8 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
|
||||
CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code]
|
||||
CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView
|
||||
CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView
|
||||
CRNewChatItems u chatItems -> viewChatItems ttyUser unmuted u chatItems ts tz
|
||||
CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
|
||||
CRNewChatItems u chatItems -> viewChatItems ttyUser unmuted u chatItems ts tz testView
|
||||
CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item <> viewTestInfo testView item) chatItems
|
||||
CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz
|
||||
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
|
||||
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz
|
||||
@@ -180,7 +180,10 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
|
||||
CRContactRequestRejected u UserContactRequest {localDisplayName = c} _ct_ -> ttyUser u [ttyContact c <> ": contact request rejected"]
|
||||
CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView
|
||||
CRPublicGroupCreated u g _groupLink _relays -> ttyUser u $ viewGroupCreated g testView
|
||||
CRPublicGroupCreationFailed u results -> ttyUser u $ viewPublicGroupCreationFailed results
|
||||
CRGroupRelays u g relays -> ttyUser u $ viewGroupRelays g relays
|
||||
CRGroupRelaysAdded u g _groupLink relays -> ttyUser u $ viewGroupRelays g relays
|
||||
CRGroupRelaysAddFailed u results -> ttyUser u $ viewGroupRelaysAddFailed results
|
||||
CRGroupMembers u g -> ttyUser u $ viewGroupMembers g
|
||||
CRMemberSupportChats u g ms -> ttyUser u $ viewMemberSupportChats g ms
|
||||
-- CRGroupConversationsArchived u _g _conversations -> ttyUser u []
|
||||
@@ -222,6 +225,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, testView} liveIte
|
||||
CRLeftMemberUser u g -> ttyUser u $ [ttyGroup' g <> ": you left the group"] <> groupPreserved g
|
||||
CRGroupDeletedUser u g signed -> ttyUser u [ttyGroup' g <> ": you deleted the group" <> signedStr signed]
|
||||
CRForwardPlan u count itemIds fc -> ttyUser u $ viewForwardPlan count itemIds fc
|
||||
CRChatMsgContent u mc -> ttyUser u $ ttyMsgContent mc <> viewMsgTestInfo testView mc
|
||||
CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
|
||||
CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
|
||||
CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts
|
||||
@@ -407,7 +411,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
|
||||
CEvtContactRatchetSync u ct progress -> ttyUser u $ viewContactRatchetSync ct progress
|
||||
CEvtGroupMemberRatchetSync u g m progress -> ttyUser u $ viewGroupMemberRatchetSync g m progress
|
||||
CEvtChatInfoUpdated _ _ -> []
|
||||
CEvtNewChatItems u chatItems -> viewChatItems ttyUser unmuted u chatItems ts tz
|
||||
CEvtNewChatItems u chatItems -> viewChatItems ttyUser unmuted u chatItems ts tz testView
|
||||
CEvtChatItemsStatusesUpdated u chatItems
|
||||
| length chatItems <= 20 ->
|
||||
concatMap
|
||||
@@ -646,11 +650,12 @@ viewChatItems ::
|
||||
[AChatItem] ->
|
||||
UTCTime ->
|
||||
TimeZone ->
|
||||
Bool ->
|
||||
[StyledString]
|
||||
viewChatItems ttyUser unmuted u chatItems ts tz
|
||||
viewChatItems ttyUser unmuted u chatItems ts tz testView
|
||||
| length chatItems <= 20 =
|
||||
concatMap
|
||||
(\(AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item)
|
||||
(\(AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewChatItem chat item False ts tz <> viewItemReactions item <> viewTestInfo testView item)
|
||||
chatItems
|
||||
| all (\aci -> aChatItemDir aci == MDRcv) chatItems = ttyUser u [sShow (length chatItems) <> " new messages"]
|
||||
| all (\aci -> aChatItemDir aci == MDSnd) chatItems = ttyUser u [sShow (length chatItems) <> " messages sent"]
|
||||
@@ -671,6 +676,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
|
||||
CIDirectRcv -> case content of
|
||||
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvMsgError err -> viewRcvMsgError from err ts tz meta
|
||||
CIRcvGroupEvent {} -> showRcvItemProhibited from
|
||||
_ -> showRcvItem from
|
||||
where
|
||||
@@ -694,6 +700,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
|
||||
rcvGroupItem m_ = case content of
|
||||
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from context mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvMsgError err -> viewRcvMsgError from err ts tz meta
|
||||
CIRcvGroupInvitation {} | isJust m_ -> showRcvItemProhibited from
|
||||
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m_) context meta [plainContent content] False
|
||||
CIRcvBlocked {} -> receivedWithTime_ ts tz (ttyFromGroup g scopeInfo m_) context meta [plainContent content] False
|
||||
@@ -715,6 +722,7 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemForwarded, forwa
|
||||
CILocalRcv -> case content of
|
||||
CIRcvMsgContent mc -> withLocalFile from $ rcvMsg from context mc
|
||||
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
|
||||
CIRcvMsgError err -> viewRcvMsgError from err ts tz meta
|
||||
CIRcvGroupEvent {} -> showRcvItemProhibited from
|
||||
_ -> showRcvItem from
|
||||
where
|
||||
@@ -946,6 +954,14 @@ viewItemReactions ChatItem {reactions} = [" " <> viewReactions reactions |
|
||||
viewReaction CIReactionCount {reaction = MREmoji (MREmojiChar emoji), userReacted, totalReacted} =
|
||||
plain [emoji, ' '] <> (if userReacted then styled Italic else plain) (show totalReacted)
|
||||
|
||||
viewTestInfo :: Bool -> ChatItem c d -> [StyledString]
|
||||
viewTestInfo testView ChatItem {content} = maybe [] (viewMsgTestInfo testView) $ ciMsgContent content
|
||||
|
||||
viewMsgTestInfo :: Bool -> MsgContent -> [StyledString]
|
||||
viewMsgTestInfo testView = \case
|
||||
MCChat {ownerSig = Just sig} | testView -> [viewJSON sig]
|
||||
_ -> []
|
||||
|
||||
viewReactionMembers :: [MemberReaction] -> [StyledString]
|
||||
viewReactionMembers memberReactions = [sShow (length memberReactions) <> " member(s) reacted"]
|
||||
|
||||
@@ -991,6 +1007,9 @@ viewRcvIntegrityError from msgErr ts tz meta = receivedWithTime_ ts tz from [] m
|
||||
viewMsgIntegrityError :: MsgErrorType -> [StyledString]
|
||||
viewMsgIntegrityError err = [ttyError $ msgIntegrityError err]
|
||||
|
||||
viewRcvMsgError :: StyledString -> RcvMsgError -> CurrentTime -> TimeZone -> CIMeta c 'MDRcv -> [StyledString]
|
||||
viewRcvMsgError from rcvErr ts tz meta = receivedWithTime_ ts tz from [] meta [ttyError $ rcvMsgErrorText rcvErr] False
|
||||
|
||||
viewInvalidConnReq :: [StyledString]
|
||||
viewInvalidConnReq =
|
||||
[ "",
|
||||
@@ -1222,6 +1241,18 @@ viewGroupCreated g testView =
|
||||
where
|
||||
relaysInstruction = "wait for selected relay(s) to join, then you can invite members via group link"
|
||||
|
||||
viewRelayResults :: StyledString -> [AddRelayResult] -> [StyledString]
|
||||
viewRelayResults header results = [header] <> map showRelayResult results
|
||||
where
|
||||
showRelayResult (AddRelayResult UserChatRelay {chatRelayId = DBEntityId i} err_) =
|
||||
" relay " <> sShow i <> ": " <> maybe "ok" (plain . tshow) err_
|
||||
|
||||
viewPublicGroupCreationFailed :: [AddRelayResult] -> [StyledString]
|
||||
viewPublicGroupCreationFailed = viewRelayResults "channel not created, results:"
|
||||
|
||||
viewGroupRelaysAddFailed :: [AddRelayResult] -> [StyledString]
|
||||
viewGroupRelaysAddFailed = viewRelayResults "relays not added, results:"
|
||||
|
||||
viewCannotResendInvitation :: GroupInfo -> ContactName -> [StyledString]
|
||||
viewCannotResendInvitation g c =
|
||||
[ ttyContact c <> " is already invited to group " <> ttyGroup' g,
|
||||
@@ -2033,7 +2064,7 @@ viewGroupUserChanged
|
||||
viewConnectionPlan :: ChatConfig -> ACreatedConnLink -> ConnectionPlan -> [StyledString]
|
||||
viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
|
||||
CPInvitationLink ilp -> case ilp of
|
||||
ILPOk contactSLinkData -> [invOrBiz contactSLinkData "ok to connect"] <> [viewJSON contactSLinkData | testView]
|
||||
ILPOk contactSLinkData ov -> [invOrBiz contactSLinkData "ok to connect"] <> viewSigVerification ov <> [viewJSON contactSLinkData | testView]
|
||||
ILPOwnLink -> [invLink "own link"]
|
||||
ILPConnecting Nothing -> [invLink "connecting"]
|
||||
ILPConnecting (Just ct) -> [invLink ("connecting to contact " <> ttyContact' ct)]
|
||||
@@ -2051,7 +2082,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
|
||||
| business -> ("business address: " <>)
|
||||
_ -> ("invitation link: " <>)
|
||||
CPContactAddress cap -> case cap of
|
||||
CAPOk contactSLinkData -> [addrOrBiz contactSLinkData "ok to connect"] <> [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)]
|
||||
@@ -2069,15 +2100,16 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
|
||||
| business -> ("business address: " <>)
|
||||
_ -> ("contact address: " <>)
|
||||
CPGroupLink glp -> case glp of
|
||||
GLPOk groupSLinkInfo_ groupSLinkData ->
|
||||
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
|
||||
<> [viewJSON groupSLinkData | testView]
|
||||
GLPOwnLink g -> [grpLink "own link for group " <> ttyGroup' g]
|
||||
GLPConnectingConfirmReconnect -> [grpLink "connecting, allowed to reconnect"]
|
||||
GLPConnectingProhibit Nothing -> [grpLink "connecting"]
|
||||
GLPConnectingProhibit (Just g) -> connecting g
|
||||
GLPKnown g@GroupInfo {preparedGroup, membership = m} -> case preparedGroup of
|
||||
GLPKnown g@GroupInfo {preparedGroup, membership = m} _ _ _ -> case preparedGroup of
|
||||
Just PreparedGroup {connLinkStartedConnection} -> case memberStatus m of
|
||||
GSMemUnknown
|
||||
| connLinkStartedConnection -> connecting g
|
||||
@@ -2093,6 +2125,7 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
|
||||
"use " <> ttyToGroup g Nothing <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
knownGroup prepared = grpOrBizLink g <> ": known " <> prepared <> grpOrBiz g <> " " <> ttyGroup' g
|
||||
GLPNoRelays _ -> [grpLink "channel has no active relays, please try to join later"]
|
||||
where
|
||||
connecting g = [grpOrBizLink g <> ": connecting to " <> grpOrBiz g <> " " <> ttyGroup' g]
|
||||
grpLink = ("group link: " <>)
|
||||
@@ -2107,6 +2140,10 @@ viewConnectionPlan ChatConfig {logLevel, testView} _connLink = \case
|
||||
nextConnectPrepared Contact {preparedContact, activeConn} = case preparedContact of
|
||||
Just _ -> maybe True (\c -> connStatus c == ConnPrepared) activeConn
|
||||
_ -> False
|
||||
viewSigVerification = \case
|
||||
Just OVVerified -> ["owner signature: verified"]
|
||||
Just (OVFailed r) -> ["owner signature: FAILED (" <> plain r <> ")"]
|
||||
Nothing -> []
|
||||
|
||||
viewContactUpdated :: Contact -> Contact -> [StyledString]
|
||||
viewContactUpdated
|
||||
@@ -2206,7 +2243,26 @@ sentWithTime_ ts tz styledMsg CIMeta {itemTs} =
|
||||
prependFirst (ttyMsgTime ts tz itemTs <> " ") styledMsg
|
||||
|
||||
ttyMsgContent :: MsgContent -> [StyledString]
|
||||
ttyMsgContent = msgPlain . msgContentText
|
||||
ttyMsgContent = \case
|
||||
MCChat {text, chatLink, ownerSig} ->
|
||||
let (linkInfo, name, links) = viewChatLink chatLink
|
||||
signed = if isJust ownerSig then " (signed)" else ""
|
||||
body = if T.null text || text `elem` links then [] else msgPlain text
|
||||
in [plain $ linkInfo <> viewName name <> signed <> ":"] <> map plain links <> body
|
||||
mc -> msgPlain $ msgContentText mc
|
||||
where
|
||||
viewChatLink = \case
|
||||
MCLGroup {connLink, groupProfile = GroupProfile {displayName, publicGroup}} ->
|
||||
let (ref, links) = case publicGroup of
|
||||
Just PublicGroupProfile {groupType, groupLink} -> (textEncode groupType, nub [enc connLink, enc groupLink])
|
||||
Nothing -> ("group", [enc connLink])
|
||||
in ("link to join " <> ref <> " #", displayName, links)
|
||||
MCLContact {connLink, profile = Profile {displayName}} ->
|
||||
("contact address of @", displayName, [enc connLink])
|
||||
MCLInvitation {invLink, profile = Profile {displayName}} ->
|
||||
("one-time link of @", displayName, [enc invLink])
|
||||
enc :: StrEncoding a => a -> Text
|
||||
enc = safeDecodeUtf8 . strEncode
|
||||
|
||||
prependFirst :: StyledString -> [StyledString] -> [StyledString]
|
||||
prependFirst s [] = [s]
|
||||
@@ -2656,7 +2712,7 @@ viewChatError isCmd logLevel testView = \case
|
||||
BRContent -> "content violates conditions of use"
|
||||
BROKER _ (NETWORK _) | not isCmd -> []
|
||||
BROKER _ TIMEOUT | not isCmd -> []
|
||||
AGENT A_DUPLICATE -> [withConnEntity <> "error: AGENT A_DUPLICATE" | logLevel == CLLDebug || isCmd]
|
||||
AGENT A_DUPLICATE {} -> [withConnEntity <> "error: AGENT A_DUPLICATE" | logLevel == CLLDebug || isCmd]
|
||||
AGENT (A_PROHIBITED e) -> [withConnEntity <> "error: AGENT A_PROHIBITED, " <> plain e | logLevel <= CLLWarning || isCmd]
|
||||
CONN NOT_FOUND _ -> [withConnEntity <> "error: CONN NOT_FOUND" | logLevel <= CLLWarning || isCmd]
|
||||
CRITICAL restart e -> [plain $ "critical error: " <> e] <> ["please restart the app" | restart]
|
||||
|
||||
Reference in New Issue
Block a user