dandri/simplex-chat
1
0 Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-10-22 11:22:27 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into ab/names-lookup-api

Browse Source
This commit is contained in:
Alain Brenzikofer committed 2026-09-23 19:39:09 +02:00
2 parents 0dd4cea07c 692b0026e7
commit 75b59f4dec
238 files changed
+6294 -4002
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

src/Simplex/Chat/Badges/Service.hs
-69
View File
@@ -42,7 +42,6 @@ import Simplex.Chat.Badges
import Simplex.Chat.Badges.Types
import Simplex.Chat.PaymentService
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
import Simplex.Messaging.Version.Internal (Version (..))
@@ -205,74 +204,6 @@ data StatementDebitType
| SDUnknown {tag :: Text, json :: J.Object}
deriving (Show)
data BadgeServiceErrorCode
= BSEBadRequest
| BSEUnsupportedVersion
| BSEUnknownPurchaseKey
| BSEUnknownOfferId
| BSEOfferDisabled
| BSEOfferMismatch
| BSEProductUnavailable
| BSEPaymentNotEntitled
| BSEPaymentPending
| BSEProviderUnavailable
| BSERateLimited
| BSECodeInvalid
| BSECodeUsed
| BSECodeExpired
| BSEReceiptInvalid
| BSEReceiptUsed
| BSEInternal
| BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
deriving (Eq, Show)
instance TextEncoding BadgeServiceErrorCode where
textEncode = \case
BSEBadRequest -> "bad_request"
BSEUnsupportedVersion -> "unsupported_version"
BSEUnknownPurchaseKey -> "unknown_purchase_key"
BSEUnknownOfferId -> "unknown_offer_id"
BSEOfferDisabled -> "offer_disabled"
BSEOfferMismatch -> "offer_mismatch"
BSEProductUnavailable -> "product_unavailable"
BSEPaymentNotEntitled -> "payment_not_entitled"
BSEPaymentPending -> "payment_pending"
BSEProviderUnavailable -> "provider_unavailable"
BSERateLimited -> "rate_limited"
BSECodeInvalid -> "code_invalid"
BSECodeUsed -> "code_used"
BSECodeExpired -> "code_expired"
BSEReceiptInvalid -> "receipt_invalid"
BSEReceiptUsed -> "receipt_used"
BSEInternal -> "internal"
BSEUnknown t -> t
textDecode s = Just $ case s of
"bad_request" -> BSEBadRequest
"unsupported_version" -> BSEUnsupportedVersion
"unknown_purchase_key" -> BSEUnknownPurchaseKey
"unknown_offer_id" -> BSEUnknownOfferId
"offer_disabled" -> BSEOfferDisabled
"offer_mismatch" -> BSEOfferMismatch
"product_unavailable" -> BSEProductUnavailable
"payment_not_entitled" -> BSEPaymentNotEntitled
"payment_pending" -> BSEPaymentPending
"provider_unavailable" -> BSEProviderUnavailable
"rate_limited" -> BSERateLimited
"code_invalid" -> BSECodeInvalid
"code_used" -> BSECodeUsed
"code_expired" -> BSECodeExpired
"receipt_invalid" -> BSEReceiptInvalid
"receipt_used" -> BSEReceiptUsed
"internal" -> BSEInternal
t -> BSEUnknown t
instance ToJSON BadgeServiceErrorCode where
toJSON = textToJSON
toEncoding = textToEncoding
instance FromJSON BadgeServiceErrorCode where
parseJSON = textParseJSON "BadgeServiceErrorCode"
$(pure [])
instance FromJSON StatementCreditType where
src/Simplex/Chat/Badges/Types.hs
+143 -6
View File
@@ -3,6 +3,7 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
@@ -18,6 +19,9 @@ module Simplex.Chat.Badges.Types
LedgerCreditType (..),
LedgerDebitType (..),
BadgeAlertKind (..),
BadgeServiceErrorCode (..),
BadgeIssueFailure (..),
BadgeIssueError (..),
BadgeFunding (..),
BadgePurchase (..),
BadgeLedgerEntry (..),
@@ -28,11 +32,14 @@ module Simplex.Chat.Badges.Types
BadgeState (..),
) where
import Data.Aeson (FromJSON, ToJSON)
import Control.Applicative ((<|>))
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.TH as JQ
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Int (Int64)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Word (Word8)
import Simplex.Chat.Badges hiding (BadgePurchase (..))
@@ -42,7 +49,8 @@ import Simplex.Messaging.Agent.Protocol (UserId)
import Simplex.Messaging.Agent.Store.DB (fromTextField_)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, taggedObjectJSON)
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, sumTypeJSON, taggedObjectJSON)
import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
#if defined(dbPostgres)
import Database.PostgreSQL.Simple.FromField (FromField (..))
import Database.PostgreSQL.Simple.ToField (ToField (..))
@@ -108,7 +116,7 @@ data LedgerDebitType
deriving (Eq, Show)
-- unconfirmed draft
data BadgeAlertKind = BARenewalApproaching | BAPaymentIssue | BASubscriptionEnded | BAPrepaidEnding | BASupportEnded
data BadgeAlertKind = BARenewalApproaching | BAPaymentIssue | BASubscriptionEnded | BAPrepaidEnding | BASupportEnded | BAIssueFailed
deriving (Eq, Show)
instance TextEncoding BadgeAlertKind where
@@ -118,12 +126,14 @@ instance TextEncoding BadgeAlertKind where
BASubscriptionEnded -> "subscription_ended"
BAPrepaidEnding -> "prepaid_ending"
BASupportEnded -> "support_ended"
BAIssueFailed -> "issue_failed"
textDecode = \case
"renewal_approaching" -> Just BARenewalApproaching
"payment_issue" -> Just BAPaymentIssue
"subscription_ended" -> Just BASubscriptionEnded
"prepaid_ending" -> Just BAPrepaidEnding
"support_ended" -> Just BASupportEnded
"issue_failed" -> Just BAIssueFailed
_ -> Nothing
instance FromField BadgeAlertKind where fromField = fromTextField_ textDecode
@@ -215,10 +225,49 @@ data BadgeAlertPrice = BadgeAlertPrice
}
deriving (Show)
-- | The user's badge as the badge surfaces render it. The purchase keys are deliberately absent:
-- this travels to the UI and over remote control, and they are secrets that stay in core.
data BadgeServiceErrorCode
= BSEBadRequest
| BSEUnsupportedVersion
| BSEUnknownPurchaseKey
| BSEUnknownOfferId
| BSEOfferDisabled
| BSEOfferMismatch
| BSEProductUnavailable
| BSEPaymentNotEntitled
| BSEPaymentPending
| BSEProviderUnavailable
| BSERateLimited
| BSECodeInvalid
| BSECodeUsed
| BSECodeExpired
| BSEReceiptInvalid
| BSEReceiptUsed
| BSEInternal
| BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
deriving (Eq, Show)
-- | Why a renewal request ended without a credential stored. retryable is the service's own view of
-- transience: it gave retryAfter, which holds for codes this version does not know.
data BadgeIssueFailure
= BIFServiceError {code :: BadgeServiceErrorCode, retryable :: Bool}
| BIFServiceTimeout
| BIFNetwork {agentError :: Text}
| BIFInvalidCredential
| BIFUnexpected {message :: Text}
deriving (Eq, Show)
data BadgeIssueError = BadgeIssueError
{ failedSince :: UTCTime,
lastAttemptAt :: UTCTime,
reason :: BadgeIssueFailure
}
deriving (Eq, Show)
-- | The user's badge as the badge surfaces render it. The private purchase key is deliberately
-- absent: this travels to the UI and over remote control, and it is a secret that stays in core.
data BadgeState = BadgeState
{ badgePurchaseId :: Int64,
purchaseKey :: C.PublicKeyEd25519, -- the purchase's identifier on the service
badgeType :: BadgeType,
shown :: BoolDef,
monthsLeft :: Int,
@@ -226,7 +275,9 @@ data BadgeState = BadgeState
-- payments returns here with the payment types, which this slice neither writes nor encodes
renewsAt :: Maybe UTCTime,
willRenew :: Bool,
alert :: Maybe BadgeAlert
alert :: Maybe BadgeAlert,
issueError :: Maybe BadgeIssueError,
nextWakeAt :: Maybe UTCTime
}
deriving (Show)
@@ -262,6 +313,88 @@ instance FromField BadgeCodePaymentStatus where fromField = fromTextField_ textD
instance ToField BadgeCodePaymentStatus where toField = toField . textEncode
instance TextEncoding BadgeServiceErrorCode where
textEncode = \case
BSEBadRequest -> "bad_request"
BSEUnsupportedVersion -> "unsupported_version"
BSEUnknownPurchaseKey -> "unknown_purchase_key"
BSEUnknownOfferId -> "unknown_offer_id"
BSEOfferDisabled -> "offer_disabled"
BSEOfferMismatch -> "offer_mismatch"
BSEProductUnavailable -> "product_unavailable"
BSEPaymentNotEntitled -> "payment_not_entitled"
BSEPaymentPending -> "payment_pending"
BSEProviderUnavailable -> "provider_unavailable"
BSERateLimited -> "rate_limited"
BSECodeInvalid -> "code_invalid"
BSECodeUsed -> "code_used"
BSECodeExpired -> "code_expired"
BSEReceiptInvalid -> "receipt_invalid"
BSEReceiptUsed -> "receipt_used"
BSEInternal -> "internal"
BSEUnknown t -> t
textDecode s = Just $ case s of
"bad_request" -> BSEBadRequest
"unsupported_version" -> BSEUnsupportedVersion
"unknown_purchase_key" -> BSEUnknownPurchaseKey
"unknown_offer_id" -> BSEUnknownOfferId
"offer_disabled" -> BSEOfferDisabled
"offer_mismatch" -> BSEOfferMismatch
"product_unavailable" -> BSEProductUnavailable
"payment_not_entitled" -> BSEPaymentNotEntitled
"payment_pending" -> BSEPaymentPending
"provider_unavailable" -> BSEProviderUnavailable
"rate_limited" -> BSERateLimited
"code_invalid" -> BSECodeInvalid
"code_used" -> BSECodeUsed
"code_expired" -> BSECodeExpired
"receipt_invalid" -> BSEReceiptInvalid
"receipt_used" -> BSEReceiptUsed
"internal" -> BSEInternal
t -> BSEUnknown t
instance ToJSON BadgeServiceErrorCode where
toJSON = textToJSON
toEncoding = textToEncoding
instance FromJSON BadgeServiceErrorCode where
parseJSON = textParseJSON "BadgeServiceErrorCode"
instance StrEncoding BadgeIssueFailure where
strEncode = \case
BIFServiceError {code, retryable} -> "service_error " <> (if retryable then "retry " else "final ") <> encodeUtf8 (textEncode code)
BIFServiceTimeout -> "service_timeout"
BIFNetwork {agentError} -> "network " <> encodeUtf8 agentError
BIFInvalidCredential -> "invalid_credential"
BIFUnexpected {message} -> "unexpected " <> encodeUtf8 message
-- a row this version cannot read is reported as it stands rather than failing every read of the purchase
strP = (knownP <* A.endOfInput) <|> (BIFUnexpected . safeDecodeUtf8 <$> A.takeByteString)
where
knownP =
A.takeWhile1 (/= ' ') >>= \case
"service_error" -> serviceErrorP
"service_timeout" -> pure BIFServiceTimeout
"network" -> BIFNetwork <$> restP
"invalid_credential" -> pure BIFInvalidCredential
"unexpected" -> BIFUnexpected <$> restP
_ -> fail "bad BadgeIssueFailure"
-- the code is encoded last and read to the end, so a code this version does not know reads back whole
serviceErrorP = do
retryable_ <- A.space *> retryableP
code_ <- A.space *> codeP
pure BIFServiceError {code = code_, retryable = retryable_}
retryableP =
A.takeWhile1 (/= ' ') >>= \case
"retry" -> pure True
"final" -> pure False
_ -> fail "bad BadgeIssueFailure retry flag"
codeP = A.takeByteString >>= maybe (fail "bad BadgeServiceErrorCode") pure . textDecode . safeDecodeUtf8
restP = safeDecodeUtf8 <$> (A.space *> A.takeByteString)
instance ToField BadgeIssueFailure where toField = toField . decodeLatin1 . strEncode
instance FromField BadgeIssueFailure where fromField = fromTextField_ $ eitherToMaybe . strDecode . encodeUtf8
$(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus)
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount)
@@ -272,4 +405,8 @@ $(JQ.deriveJSON defaultJSON ''BadgeAlertPrice)
$(JQ.deriveJSON defaultJSON ''BadgeAlert)
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BIF") ''BadgeIssueFailure)
$(JQ.deriveJSON defaultJSON ''BadgeIssueError)
$(JQ.deriveJSON defaultJSON ''BadgeState)
src/Simplex/Chat/Bot/Store.hs
+1 -6
View File
@@ -4,8 +4,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Simplex.Chat.Bot.Store
( storeCxt,
withDB,
( withDB,
withDB',
)
where
@@ -20,10 +19,6 @@ import Simplex.Messaging.Agent.Store.Common (withTransaction)
import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Util (catchAll)
storeCxt :: ChatController -> StoreCxt
storeCxt ChatController {config} = mkStoreCxt config
{-# INLINE storeCxt #-}
withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Either String a)
withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
src/Simplex/Chat/Controller.hs
+6 -4
View File
@@ -84,7 +84,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyMode (..), SMPWebPortServers (..), SocksMode (..))
import qualified Simplex.Messaging.Crypto as C
import Simplex.Chat.Badges (BadgeCredential, FileSizeLimits, LocalBadge)
import Simplex.Chat.Badges.Service (BadgeServiceErrorCode)
import Simplex.Chat.Badges.Service (BadgeServiceErrorCode, StatementEntry)
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeState (..))
import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
import Simplex.Messaging.Crypto.File (CryptoFile (..))
@@ -228,9 +228,9 @@ newWebPreviewState = do
-- | Builds the read-only context threaded through store functions from chat config.
-- The single construction point, so new store-wide config (e.g. server keys) is added in one place.
mkStoreCxt :: ChatConfig -> StoreCxt
mkStoreCxt ChatConfig {chatVRange, badgePublicKeys} = StoreCxt chatVRange badgePublicKeys
{-# INLINE mkStoreCxt #-}
storeCxt :: ChatController -> StoreCxt
storeCxt ChatController {config = ChatConfig {chatVRange, badgePublicKeys}, random} = StoreCxt chatVRange badgePublicKeys random
{-# INLINE storeCxt #-}
data RandomAgentServers = RandomAgentServers
{ smpServers :: NonEmpty (ServerCfg 'PSMP),
@@ -660,6 +660,7 @@ data ChatCommand
| AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`)
| APIRedeemBadgeCode {userId :: UserId, code :: Text} -- redeem a badge code with the configured badge service
| APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert
| APIGetBadgeLedger {userId :: UserId, badgePurchaseId :: Int64} -- the purchase's ledger, oldest first
-- episode is last because it is free text: it is the value that makes one occurrence of an
-- alert distinct from the next, and the app returns whatever it was given
| APIAckBadgeAlert {userId :: UserId, badgePurchaseId :: Int64, alertKind :: BadgeAlertKind, snooze :: Bool, episode :: Text}
@@ -871,6 +872,7 @@ data ChatResponse
| CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId}
| CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool, badgeState :: Maybe BadgeState}
| CRBadgeState {user :: User, badgeState :: Maybe BadgeState}
| CRBadgeLedger {user :: User, badgeLedger :: [StatementEntry]}
| CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
| CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool}
| CRGroupsList {user :: User, groups :: [GroupInfo]}
src/Simplex/Chat/Library/Commands.hs
+269 -198
View File
File diff suppressed because it is too large. Load diff
src/Simplex/Chat/Library/Internal.hs
+103 -118
View File
@@ -470,9 +470,9 @@ sndBadgeProof_ User {profile = LocalProfile {localBadge}} ph = case localBadge o
_ -> pure Nothing
sndGroupChatBinding :: GroupInfo -> ShowGroupAsSender -> Maybe ByteString
sndGroupChatBinding GroupInfo {groupKeys, membership = GroupMember {memberId}} asGroup
| asGroup = (\PublicGroupKeys {publicGroupId} -> encodeChatBinding CBChannel $ smpEncode publicGroupId) <$> (groupKeys >>= publicGroupKeys)
| otherwise = (\GroupKeys {memberPrivKey} -> encodeChatBinding CBGroup $ groupBindingData groupKeys memberId (C.publicKey memberPrivKey)) <$> groupKeys
sndGroupChatBinding gInfo@GroupInfo {membership = GroupMember {memberId, memberPubKey}} asGroup
| asGroup = (\PublicGroupProfile {publicGroupId} -> encodeChatBinding CBChannel $ smpEncode publicGroupId) <$> publicGroup' gInfo
| otherwise = (\k -> encodeChatBinding CBGroup $ groupBindingData gInfo memberId k) <$> memberPubKey
cryptoFileDigest :: CryptoFile -> CM FD.FileDigest
cryptoFileDigest (CryptoFile filePath cfArgs) = do
@@ -1020,11 +1020,11 @@ acceptContactRequestAsync
agentAcceptContactAsync cmdId acId True cReqInvId (XInfo profileToSend Nothing) cReqPQSup subMode
pure ct'
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfo -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
acceptGroupJoinRequestAsync :: User -> Int64 -> GroupInfoKeys -> InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe MemberId -> Maybe SharedMsgId -> GroupAcceptance -> GroupMemberRole -> Maybe IncognitoProfile -> Maybe MemberKey -> Maybe GroupMember -> CM GroupMember
acceptGroupJoinRequestAsync
user@User {userId}
uclId
gInfo@GroupInfo {groupProfile, membership, businessChat}
(GIK gInfo@GroupInfo {groupProfile, membership, businessChat} gks)
cReqInvId
cReqChatVRange
cReqProfile
@@ -1058,7 +1058,7 @@ acceptGroupJoinRequestAsync
GroupLinkInvitation
{ fromMember = MemberIdRole userMemberId userRole,
fromMemberName = displayName,
fromMemberKey = groupMemberKey gInfo,
fromMemberKey = Just $ groupMemberKey gks,
invitedMember = MemberIdRole memberId gLinkMemRole,
groupProfile,
accepted = Just gAccepted,
@@ -1106,11 +1106,11 @@ acceptGroupJoinSendRejectAsync
agentAcceptContactAsync cmdId acId False cReqInvId msg PQSupportOff subMode
pure m
acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfo -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
acceptBusinessJoinRequestAsync :: User -> Int64 -> GroupInfoKeys -> GroupMember -> UserContactRequest -> CM (GroupInfo, GroupMember)
acceptBusinessJoinRequestAsync
user
uclId
gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}}
(GIK gInfo@GroupInfo {membership = GroupMember {memberRole = userRole, memberId = userMemberId}} gks)
clientMember@GroupMember {groupMemberId, memberId}
UserContactRequest {agentInvitationId = AgentInvId cReqInvId, cReqChatVRange, xContactId} = do
cxt <- chatStoreCxt
@@ -1122,7 +1122,7 @@ acceptBusinessJoinRequestAsync
GroupLinkInvitation
{ fromMember = MemberIdRole userMemberId userRole,
fromMemberName = displayName,
fromMemberKey = groupMemberKey gInfo,
fromMemberKey = Just $ groupMemberKey gks,
invitedMember = MemberIdRole memberId GRMember,
groupProfile = businessGroupProfile userProfile groupPreferences,
accepted = Just GAAccepted,
@@ -1197,15 +1197,15 @@ businessGroupProfile :: Profile -> GroupPreferences -> GroupProfile
businessGroupProfile Profile {displayName, fullName, shortDescr, description, image} groupPreferences =
GroupProfile {displayName, fullName, description, shortDescr, image, publicGroup = Nothing, groupPreferences = Just groupPreferences, memberAdmission = Nothing}
introduceToModerators :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceToModerators cxt user gInfo@GroupInfo {groupId} m@GroupMember {memberRole, memberId} = do
introduceToModerators :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
introduceToModerators cxt user gInfo@(GIK g@GroupInfo {groupId} _) m@GroupMember {memberRole, memberId} = do
forM_ (memberConn m) $ \mConn -> do
let msg =
if maxVersion (memberChatVRange m) >= groupKnockingVersion
then XGrpLinkAcpt GAPendingReview memberRole memberId
else XMsgNew $ mcSimple (MCText pendingReviewMessage)
void $ sendDirectMemberMessage mConn msg groupId
modMs <- withStore' $ \db -> getGroupModerators db cxt user gInfo
modMs <- withStore' $ \db -> getGroupModerators db cxt user g
let rcpModMs = filter shouldIntroduceToMod modMs
introduceMember user gInfo m rcpModMs (Just $ MSMember $ memberId' m)
where
@@ -1215,15 +1215,15 @@ introduceToModerators cxt user gInfo@GroupInfo {groupId} m@GroupMember {memberRo
&& groupMemberId' mem /= groupMemberId' m
&& maxVersion (memberChatVRange mem) >= groupKnockingVersion
introduceToAll :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceToAll cxt user gInfo m = do
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
introduceToAll :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
introduceToAll cxt user gInfo@(GIK g _) m = do
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user g) (getMemberRelationsVector db m)
let recipients = filter (shouldIntroduce m vector) members
introduceMember user gInfo m recipients Nothing
introduceToRemaining :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceToRemaining cxt user gInfo m = do
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user gInfo) (getMemberRelationsVector db m)
introduceToRemaining :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
introduceToRemaining cxt user gInfo@(GIK g _) m = do
(members, vector) <- withStore $ \db -> liftM2 (,) (liftIO $ getGroupMembers db cxt user g) (getMemberRelationsVector db m)
let recipients = filter (shouldIntroduce m vector) members
introduceMember user gInfo m recipients Nothing
@@ -1233,17 +1233,17 @@ shouldIntroduce m vec mem =
&& groupMemberId' mem /= groupMemberId' m
&& getRelation (indexInGroup mem) vec == MRNew
introduceMember :: User -> GroupInfo -> GroupMember -> [GroupMember] -> Maybe MsgScope -> CM ()
introduceMember :: User -> GroupInfoKeys -> GroupMember -> [GroupMember] -> Maybe MsgScope -> CM ()
introduceMember _ _ GroupMember {activeConn = Nothing} _ _ = throwChatError $ CEInternalError "member connection not active"
introduceMember user gInfo toMember@GroupMember {activeConn = Just conn} introduceToMembers msgScope = do
void . sendGroupMessage' user gInfo introduceToMembers $ XGrpMemNew (memberInfo gInfo toMember) msgScope
introduceMember user gInfo@(GIK g _) toMember@GroupMember {activeConn = Just conn} introduceToMembers msgScope = do
void . sendGroupMessage' user gInfo introduceToMembers $ XGrpMemNew (memberInfo g toMember) msgScope
sendIntroductions introduceToMembers
where
sendIntroductions reMembers = do
updateToMemberVector reMembers
updateReMembersVectors reMembers
shuffledReMembers <- liftIO $ shuffleMembers reMembers
let events = map (memberIntroEvt gInfo) shuffledReMembers
let events = map (memberIntroEvt g) shuffledReMembers
forM_ (L.nonEmpty events) $ \events' ->
sendGroupMemberMessages user gInfo conn events'
updateToMemberVector :: [GroupMember] -> CM ()
@@ -1272,11 +1272,11 @@ memberIntroEvt gInfo reMember =
-- Forward the saved owner-signed roster verbatim (reusing its signed shared_msg_id), then the
-- blob chunks, so the recipient verifies the owner signature.
serveRoster :: User -> GroupInfo -> GroupMember -> CM ()
serveRoster user gInfo member =
serveRoster :: User -> GroupInfoKeys -> GroupMember -> CM ()
serveRoster user gInfo@(GIK g _) member =
when (member `supportsVersion` groupRosterVersion) $ do
cxt <- chatStoreCxt
withStore' (\db -> getStoredGroupRoster db gInfo) >>= \case
withStore' (\db -> getStoredGroupRoster db g) >>= \case
Just (ownerGMId, brokerTs, sm@SignedMsg {signedBody}, blob_, storedVer_) ->
case J.eitherDecodeStrict' signedBody :: Either String (ChatMessage 'Json) of
Left e -> logError $ "serveRoster: cannot decode saved roster message: " <> tshow e
@@ -1297,24 +1297,24 @@ serveRoster user gInfo member =
-- Used in groups with relays to introduce moderators and above to a new member,
-- and to announce the new member to moderators and above.
-- This doesn't create introduction records in db, compared to above methods.
introduceInChannel :: StoreCxt -> User -> GroupInfo -> GroupMember -> CM ()
introduceInChannel :: StoreCxt -> User -> GroupInfoKeys -> GroupMember -> CM ()
introduceInChannel _ _ _ GroupMember {activeConn = Nothing} = throwChatError $ CEInternalError "member connection not active"
introduceInChannel cxt user gInfo subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
introduceInChannel cxt user g@(GIK gInfo _) subscriber@GroupMember {activeConn = Just conn, indexInGroup = subscriberIdx} = do
(owners, adminsMods) <- withStore' $ \db ->
(,) <$> getGroupOwners db cxt user gInfo <*> getGroupAdminsMods db cxt user gInfo
let modMs = owners <> adminsMods
void $ sendGroupMessage' user gInfo modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
void $ sendGroupMessage' user g modMs $ XGrpMemNew (memberInfo gInfo subscriber) Nothing
withStore' $ \db ->
setMemberVectorNewRelations db subscriber [(indexInGroup m, (IDSubjectIntroduced, MRIntroduced)) | m <- modMs]
-- owner intros first so the joiner has the owner profile loaded before applying the saved roster (signed by the owner)
sendIntros owners
serveRoster user gInfo subscriber
serveRoster user g subscriber
sendIntros adminsMods
withStore' $ \db ->
setMembersVectorsNewRelation db modMs subscriberIdx IDSubjectIntroduced MRIntroduced
where
sendIntros ms = forM_ (L.nonEmpty $ map (memberIntroEvt gInfo) ms) $ \evts ->
sendGroupMemberMessages user gInfo conn evts
sendGroupMemberMessages user g conn evts
userProfileInGroup :: User -> GroupInfo -> Maybe Profile -> Profile
userProfileInGroup user g = userProfileInGroup' user (Just g)
@@ -1558,29 +1558,29 @@ splitFileDescr partSize lastSize rfdText = splitParts 1 rfdText
then fileDescr :| []
else fileDescr <| splitParts (partNo + 1) rest
setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfo -> CM (Maybe GroupLink)
setGroupLinkData' nm user gInfo =
withFastStore' (\db -> runExceptT $ getGroupLink db user gInfo) >>= \case
setGroupLinkData' :: NetworkRequestMode -> User -> GroupInfoKeys -> CM (Maybe GroupLink)
setGroupLinkData' nm user gInfo@(GIK g _) =
withFastStore' (\db -> runExceptT $ getGroupLink db user g) >>= \case
Right gLink@GroupLink {shortLinkDataSet}
| shortLinkDataSet -> Just <$> setGroupLinkData nm user gInfo gLink
_ -> pure Nothing
setGroupLinkData :: NetworkRequestMode -> User -> GroupInfo -> GroupLink -> CM GroupLink
setGroupLinkData nm user gInfo gLink = do
setGroupLinkData :: NetworkRequestMode -> User -> GroupInfoKeys -> GroupLink -> CM GroupLink
setGroupLinkData nm user g@(GIK gInfo _) gLink = do
cxt <- chatStoreCxt
(conn, groupRelays) <- withFastStore $ \db ->
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
let (userLinkData, crClientData) = groupLinkData g gLink groupRelays
linkType = if useRelays' gInfo then CCTChannel else CCTGroup
sLnk <- shortenShortLink' . setShortLinkType_ linkType =<< withAgent (\a -> setConnShortLink a nm (aConnId conn) SCMContact userLinkData (Just crClientData) False Nothing)
withFastStore' $ \db -> setGroupLinkShortLink db gLink sLnk
setGroupLinkDataAsync :: User -> GroupInfo -> GroupLink -> CM ()
setGroupLinkDataAsync user gInfo gLink = do
setGroupLinkDataAsync :: User -> GroupInfoKeys -> GroupLink -> CM ()
setGroupLinkDataAsync user g@(GIK gInfo _) gLink = do
cxt <- chatStoreCxt
(conn, groupRelays) <- withStore $ \db ->
(,) <$> getGroupLinkConnection db cxt user gInfo <*> liftIO (getPublishableGroupRelays db cxt user gInfo)
let (userLinkData, crClientData) = groupLinkData gInfo gLink groupRelays
let (userLinkData, crClientData) = groupLinkData g gLink groupRelays
setAgentConnShortLinkAsync user conn userLinkData (Just crClientData)
connectToRelayAsync :: User -> GroupInfo -> ShortLinkContact -> CM ()
@@ -1595,15 +1595,15 @@ connectToRelayAsync user gInfo relayLink = do
newConnIds <- getAgentConnShortLinkAsync user CFGetRelayDataJoin Nothing relayLink
withFastStore' $ \db -> createRelayMemberConnectionAsync db user gInfo relayMember relayLink newConnIds subMode
updatePublicGroupData :: User -> GroupInfo -> CM GroupInfo
updatePublicGroupData user gInfo
updatePublicGroupData :: User -> GroupInfo -> GroupKeys -> CM GroupInfo
updatePublicGroupData user gInfo gks
| useRelays' gInfo && memberRole' (membership gInfo) == GROwner = do
cxt <- chatStoreCxt
(gInfo', gLink) <- withStore $ \db -> do
gInfo' <- updatePublicMemberCount db cxt user gInfo
gLink <- getGroupLink db user gInfo'
pure (gInfo', gLink)
setGroupLinkDataAsync user gInfo' gLink
setGroupLinkDataAsync user (GIK gInfo' gks) gLink
pure gInfo'
| useRelays' gInfo && isRelay (membership gInfo) = do
cxt <- chatStoreCxt
@@ -1647,14 +1647,14 @@ updateContactFromLinkData user ct@Contact {profile = profile@LocalProfile {conta
verifyChanged = contactDomainVerified /= Just True || claimChanged
-- 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}, membership = GroupMember {memberId}, groupKeys} GroupLink {groupLinkId} groupRelays =
groupLinkData :: GroupInfoKeys -> GroupLink -> [GroupRelay] -> (UserConnLinkData 'CMContact, CRClientData)
groupLinkData (GIK gInfo@GroupInfo {groupProfile, groupSummary = GroupSummary {publicMemberCount}, membership = GroupMember {memberId}} gks) GroupLink {groupLinkId} groupRelays =
let direct = not $ useRelays' gInfo
relays = mapMaybe (\GroupRelay {relayLink} -> relayLink) groupRelays
publicGroupData_ = PublicGroupData <$> publicMemberCount
userData = encodeShortLinkData $ GroupShortLinkData {groupProfile, publicGroupData = publicGroupData_}
owners = case groupKeys of
Just GroupKeys {publicGroupKeys = Just PublicGroupKeys {groupRootKey = GRKPrivate rootPrivKey}, memberPrivKey} ->
owners = case gks of
GKPublicGroup {groupRootKey = GRKPrivate rootPrivKey, memberPrivKey} ->
let ownerId = unMemberId memberId
ownerKey = C.publicKey memberPrivKey
authOwnerSig = C.sign' rootPrivKey (ownerId <> C.encodePubKey ownerKey)
@@ -2308,18 +2308,19 @@ createSndMessages idsEvents = do
encodeMessage sharedMsgId =
encodeChatMessage maxEncodedMsgLength ChatMessage {chatVRange = vr, msgId = Just sharedMsgId, chatMsgEvent = evnt}
groupMsgSigning :: Bool -> GroupInfo -> ChatMsgEvent e -> Maybe MsgSigning
groupMsgSigning sign GroupInfo {membership = GroupMember {memberId}, groupKeys} evt = case groupKeys of
Just gks@GroupKeys {memberPrivKey} | shouldSign -> Just $ MsgSigning CBGroup bindingData KRMember memberPrivKey
where
tag = toCMEventTag evt
shouldSign = requiresSignature tag || (sign && signableContent tag)
bindingData = groupBindingData (Just gks) memberId (C.publicKey memberPrivKey)
_ -> Nothing
groupBindingData :: Maybe GroupKeys -> MemberId -> C.PublicKeyEd25519 -> ByteString
groupBindingData gks memberId memberKey = case gks >>= publicGroupKeys of
Just PublicGroupKeys {publicGroupId} -> smpEncode (publicGroupId, memberId)
groupMsgSigning :: Bool -> GroupInfoKeys -> ChatMsgEvent e -> Maybe MsgSigning
groupMsgSigning sign (GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) evt
| shouldSign = Just $ MsgSigning CBGroup bindingData KRMember memberPrivKey'
| otherwise = Nothing
where
memberPrivKey' = memberPrivKey gks
tag = toCMEventTag evt
shouldSign = requiresSignature tag || (sign && signableContent tag)
bindingData = groupBindingData gInfo memberId (C.publicKey memberPrivKey')
groupBindingData :: GroupInfo -> MemberId -> C.PublicKeyEd25519 -> ByteString
groupBindingData gInfo memberId memberKey = case publicGroup' gInfo of
Just PublicGroupProfile {publicGroupId} -> smpEncode (publicGroupId, memberId)
Nothing -> smpEncode (memberId, memberKey)
type HistoryFile = (FileInvitation, RcvFileDescrText, Maybe UTCTime, Maybe BadgeProof)
@@ -2330,11 +2331,11 @@ directChatBinding ct =
encodeChatBinding CBDirect <$> withAgent (`getConnectionRatchetAdHash` aConnId conn)
rcvGroupChatBinding :: GroupInfo -> Maybe GroupMember -> ShowGroupAsSender -> Maybe BadgeProof -> Maybe ByteString
rcvGroupChatBinding GroupInfo {groupKeys} m_ asGroup badge_ =
case (groupKeys >>= publicGroupKeys, asGroup, m_) of
(Just PublicGroupKeys {publicGroupId}, True, _) ->
rcvGroupChatBinding gInfo m_ asGroup badge_ =
case (publicGroup' gInfo, asGroup, m_) of
(Just PublicGroupProfile {publicGroupId}, True, _) ->
Just $ encodeChatBinding CBChannel $ smpEncode publicGroupId
(Just PublicGroupKeys {publicGroupId}, False, Just GroupMember {memberId}) ->
(Just PublicGroupProfile {publicGroupId}, False, Just GroupMember {memberId}) ->
Just $ encodeChatBinding CBGroup $ smpEncode (publicGroupId, memberId)
(Nothing, False, Just GroupMember {memberId, memberPubKey}) ->
(\k -> encodeChatBinding CBGroup $ smpEncode (memberId, k)) <$> (memberPubKey <|> proofMemberKey memberId badge_)
@@ -2387,21 +2388,13 @@ rcvFileProhibited binding_ FileInvitation {fileSize, fileBadge} = do
then Nothing
else Just FileProhibited {maxSize, badgeStatus = Just st}
createUserMemberKey :: GroupInfo -> CM GroupInfo
createUserMemberKey gInfo@GroupInfo {groupId, membership, groupKeys}
| useRelays' gInfo || isJust groupKeys = pure gInfo
| otherwise = do
(_, memberPrivKey) <- atomically . C.generateKeyPair =<< asks random
withStore' $ \db -> setUserMemberKey db groupId (groupMemberId' membership) memberPrivKey
pure gInfo {groupKeys = Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey}}
groupMemberKey :: GroupKeys -> MemberKey
groupMemberKey gks = MemberKey $ C.publicKey $ memberPrivKey gks
groupMemberKey :: GroupInfo -> Maybe MemberKey
groupMemberKey GroupInfo {groupKeys} = MemberKey . C.publicKey . memberPrivKey <$> groupKeys
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfo -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
sendGroupMemberMessages user gInfo@GroupInfo {groupId} conn events = do
sendGroupMemberMessages :: forall e. MsgEncodingI e => User -> GroupInfoKeys -> Connection -> NonEmpty (ChatMsgEvent e) -> CM ()
sendGroupMemberMessages user g@(GIK gInfo@GroupInfo {groupId} _) conn events = do
when (connDisabled conn) $ throwChatError (CEConnectionDisabled conn)
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False gInfo evt, evt)) events
let idsEvts = L.map (\evt -> (GroupId groupId, groupMsgSigning False g evt, evt)) events
(errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts
unless (null errs) $ toView $ CEvtChatErrors errs
forM_ (L.nonEmpty msgs) $ \msgs' ->
@@ -2468,15 +2461,13 @@ encodeSignedConnInfo signing chatMsgEvent = do
-- signed XMember for a relay-group join: proves the joiner holds the member key it asserts, and carries
-- viaRelay = the target relay's memberId inside the signed body so a sibling relay can't accept a replay
encodeXMemberConnInfo :: GroupInfo -> MemberId -> Profile -> CM ByteString
encodeXMemberConnInfo GroupInfo {membership = GroupMember {memberId}, groupKeys} relayMemberId profileToSend =
case groupKeys of
Just gks@GroupKeys {memberPrivKey} ->
let xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey) (Just relayMemberId)
bindingData = groupBindingData (Just gks) memberId (C.publicKey memberPrivKey)
signing = MsgSigning CBGroup bindingData KRMember memberPrivKey
in encodeSignedConnInfo signing xMemberEvt
Nothing -> throwChatError $ CEInternalError "no group keys for channel membership"
encodeXMemberConnInfo :: GroupInfoKeys -> MemberId -> Profile -> CM ByteString
encodeXMemberConnInfo (GIK gInfo@GroupInfo {membership = GroupMember {memberId}} gks) relayMemberId profileToSend =
let memberPrivKey' = memberPrivKey gks
xMemberEvt = XMember profileToSend memberId (MemberKey $ C.publicKey memberPrivKey') (Just relayMemberId)
bindingData = groupBindingData gInfo memberId (C.publicKey memberPrivKey')
signing = MsgSigning CBGroup bindingData KRMember memberPrivKey'
in encodeSignedConnInfo signing xMemberEvt
deliverMessage :: Connection -> CMEventTag e -> MsgBody -> MessageId -> CM (Int64, PQEncryption)
deliverMessage conn cmEventTag msgBody msgId = do
@@ -2539,13 +2530,13 @@ deliverMessagesB msgReqs = do
where
updatePQ = updateConnPQSndEnabled db connId pqSndEnabled'
sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> [GroupMember] -> Bool -> ChatMsgEvent e -> CM SndMessage
sendGroupMessage :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> [GroupMember] -> Bool -> ChatMsgEvent e -> CM SndMessage
sendGroupMessage user gInfo gcScope members sign chatMsgEvent = do
sendGroupMessages user gInfo gcScope False members sign (chatMsgEvent :| []) >>= \case
((Right msg) :| [], _) -> pure msg
_ -> throwChatError $ CEInternalError "sendGroupMessage: expected 1 message"
sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
sendGroupMessage' :: MsgEncodingI e => User -> GroupInfoKeys -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage
sendGroupMessage' user gInfo members chatMsgEvent =
sendGroupMessages_ user gInfo members False (chatMsgEvent :| []) >>= \case
((Right msg) :| [], _) -> pure msg
@@ -2571,8 +2562,8 @@ applyRosterDelta delta current = case delta of
-- advances past a version the owner hasn't recorded), then broadcast the matching blob with the change projected
-- onto the served roster (so it excludes demoted/removed members). Returns the reserved version for the delta
-- that follows. The blob send is best-effort - a failed send heals on the next change or on resume.
broadcastRoster :: User -> GroupInfo -> RosterDelta -> CM VersionRoster
broadcastRoster user gInfo delta = do
broadcastRoster :: User -> GroupInfoKeys -> RosterDelta -> CM VersionRoster
broadcastRoster user g@(GIK gInfo _) delta = do
let rosterVer = maybe (VersionRoster 0) (\(VersionRoster n) -> VersionRoster (n + 1)) (rosterVersion gInfo)
withStore' $ \db -> setGroupRosterVersion db gInfo rosterVer
sendRosterBlob rosterVer `catchAllErrors` eToView
@@ -2583,18 +2574,18 @@ broadcastRoster user gInfo delta = do
(relays, rosterMems) <- withStore' $ \db ->
(,) <$> getGroupRelayMembers db cxt user gInfo <*> getGroupRosterMembers db cxt user gInfo
forM_ (L.nonEmpty relays) $ \relays' ->
sendRoster user gInfo (L.toList relays') rosterVer (buildGroupRoster $ applyRosterDelta delta rosterMems)
sendRoster user g (L.toList relays') rosterVer (buildGroupRoster $ applyRosterDelta delta rosterMems)
-- Send the current roster (no version bump) to a newly added relay so it can serve joiners.
sendGroupRosterToRelay :: User -> GroupInfo -> GroupMember -> CM ()
sendGroupRosterToRelay user gInfo relayMember =
sendGroupRosterToRelay :: User -> GroupInfoKeys -> GroupMember -> CM ()
sendGroupRosterToRelay user g@(GIK gInfo _) relayMember =
forM_ (rosterVersion gInfo) $ \rosterVer -> do
cxt <- chatStoreCxt
rosterMems <- withStore' $ \db -> getGroupRosterMembers db cxt user gInfo
sendRoster user gInfo [relayMember] rosterVer (buildGroupRoster rosterMems)
sendRoster user g [relayMember] rosterVer (buildGroupRoster rosterMems)
-- Row-less send (no files/snd_files rows, so no send-side cleanup); redelivery is the agent's.
sendRoster :: User -> GroupInfo -> [GroupMember] -> VersionRoster -> [RosterMember] -> CM ()
sendRoster :: User -> GroupInfoKeys -> [GroupMember] -> VersionRoster -> [RosterMember] -> CM ()
sendRoster user gInfo members rosterVer roster = do
let blob = encodeRosterBlob roster
fileInv = InlineFileInvitation {fileSize = fromIntegral (B.length blob), fileDigest = FD.FileDigest $ LC.sha512Hash $ LB.fromStrict blob}
@@ -2602,7 +2593,7 @@ sendRoster user gInfo members rosterVer roster = do
sendInlineBlobChunks user gInfo members sharedMsgId blob
-- Send a binary blob as BFileChunks under a shared_msg_id to the given members (chunked by fileChunkSize).
sendInlineBlobChunks :: User -> GroupInfo -> [GroupMember] -> SharedMsgId -> ByteString -> CM ()
sendInlineBlobChunks :: User -> GroupInfoKeys -> [GroupMember] -> SharedMsgId -> ByteString -> CM ()
sendInlineBlobChunks user gInfo members sharedMsgId blob = do
chSize <- fromIntegral <$> asks (fileChunkSize . config)
go chSize 1 blob
@@ -2615,8 +2606,8 @@ sendInlineBlobChunks user gInfo members sharedMsgId blob = do
-- Relay advertises its current web preview capability to channel owners.
-- Idempotent: sends only when the configured web domain differs from what was last sent, and only to
-- owners whose recorded chat version supports relayWebCapVersion (older apps can't parse XGrpRelayCap).
sendRelayCapIfNeeded :: User -> GroupInfo -> CM ()
sendRelayCapIfNeeded user gInfo = do
sendRelayCapIfNeeded :: User -> GroupInfoKeys -> CM ()
sendRelayCapIfNeeded user g@(GIK gInfo _) = do
ChatConfig {webPreviewConfig} <- asks config
let currentWebDomain = (\WebPreviewConfig {webDomain} -> webDomain) <$> webPreviewConfig
sentWebDomain <- withStore' (`getRelaySentWebDomain` gInfo)
@@ -2625,24 +2616,22 @@ sendRelayCapIfNeeded user gInfo = do
owners <- withStore' $ \db -> getGroupOwners db cxt user gInfo
let capableOwners = filter (\m -> memberCurrent m && m `supportsVersion` relayWebCapVersion) owners
unless (null capableOwners) $ do
void $ sendGroupMessage' user gInfo capableOwners (XGrpRelayCap RelayCapabilities {webDomain = currentWebDomain})
void $ sendGroupMessage' user g capableOwners (XGrpRelayCap RelayCapabilities {webDomain = currentWebDomain})
withStore' $ \db -> updateRelaySentWebDomain db gInfo currentWebDomain
sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages user gInfo' scope asGroup members sign events = do
gInfo <- createUserMemberKey gInfo'
sendGroupMessages :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages user gInfo scope asGroup members sign events = do
sendGroupProfileUpdate user gInfo scope asGroup members
sendGroupMessages_ user gInfo members sign events
-- per-item signer variant of sendGroupMessages (used for per-item delete signing); preserves the profile-update prelude
sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupSignedMessages user gInfo' scope asGroup members signedEvents = do
gInfo <- createUserMemberKey gInfo'
sendGroupSignedMessages :: MsgEncodingI e => User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupSignedMessages user gInfo@(GIK g _) scope asGroup members signedEvents = do
sendGroupProfileUpdate user gInfo scope asGroup members
sendGroupSignedMessages_ gInfo members signedEvents
sendGroupSignedMessages_ g members signedEvents
sendGroupProfileUpdate :: User -> GroupInfo -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> CM ()
sendGroupProfileUpdate user gInfo scope asGroup members =
sendGroupProfileUpdate :: User -> GroupInfoKeys -> Maybe GroupChatScope -> ShowGroupAsSender -> [GroupMember] -> CM ()
sendGroupProfileUpdate user g@(GIK gInfo gks) scope asGroup members =
-- TODO [knocking] send current profile to pending member after approval?
when shouldSendProfileUpdate $
sendProfileUpdate `catchAllErrors` eToView
@@ -2661,7 +2650,7 @@ sendGroupProfileUpdate user gInfo scope asGroup members =
sendProfileUpdate = do
-- shouldSendProfileUpdate excludes incognito membership, so the badge is presented
profileUpdate <- presentUserBadge user Nothing $ redactedMemberProfile gInfo (membership gInfo) $ fromLocalProfile p
void $ sendGroupMessage' user gInfo members $ XInfo profileUpdate (groupMemberKey gInfo)
void $ sendGroupMessage' user g members $ XInfo profileUpdate (Just $ groupMemberKey gks)
currentTs <- liftIO getCurrentTime
withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs
@@ -2671,9 +2660,9 @@ data GroupSndResult = GroupSndResult
forwarded :: [GroupMember]
}
sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages_ _user gInfo recipientMembers sign events =
sendGroupSignedMessages_ gInfo recipientMembers $ L.map (\evt -> (groupMsgSigning sign gInfo evt, evt)) events
sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfoKeys -> [GroupMember] -> Bool -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupMessages_ _user gInfo@(GIK g _) recipientMembers sign events =
sendGroupSignedMessages_ g recipientMembers $ L.map (\evt -> (groupMsgSigning sign gInfo evt, evt)) events
sendGroupSignedMessages_ :: MsgEncodingI e => GroupInfo -> [GroupMember] -> NonEmpty (Maybe MsgSigning, ChatMsgEvent e) -> CM (NonEmpty (Either ChatError SndMessage), GroupSndResult)
sendGroupSignedMessages_ gInfo@GroupInfo {groupId} recipientMembers signedEvents = do
@@ -3046,10 +3035,10 @@ joinAgentConnectionAsync :: CommandId -> Bool -> ConnId -> Bool -> ConnectionReq
joinAgentConnectionAsync cmdId updateConn connId enableNtfs cReqUri cInfo subMode =
withAgent $ \a -> joinConnectionAsync a (aCorrId cmdId) updateConn connId enableNtfs cReqUri cInfo PQSupportOff subMode
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> Maybe GroupInfo -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync :: MsgEncodingI e => User -> Connection -> ConfirmationId -> Maybe GroupInfoKeys -> ChatMsgEvent e -> CM ()
allowAgentConnectionAsync user conn@Connection {pqSupport} confId gInfo_ msg = do
let signing_ = case gInfo_ of
Just gInfo | useRelays' gInfo || maxVersion (peerChatVRange conn) >= relayWebCapVersion -> groupMsgSigning False gInfo msg
Just gInfo@(GIK g _) | useRelays' g || maxVersion (peerChatVRange conn) >= relayWebCapVersion -> groupMsgSigning False gInfo msg
_ -> Nothing
dm <- case signing_ of
Just signing -> encodeSignedConnInfo signing msg
@@ -3292,7 +3281,7 @@ createChatItems ::
createChatItems user itemTs_ dirsCIContents = do
createdAt <- liftIO getCurrentTime
let itemTs = fromMaybe createdAt itemTs_
cxt <- chatStoreCxt'
cxt <- asks storeCxt
void . withStoreBatch' $ \db -> map (updateChat db cxt createdAt) dirsCIContents
withStoreBatch' $ \db -> concatMap (createACIs db itemTs createdAt) dirsCIContents
where
@@ -3390,13 +3379,9 @@ waitChatStartedAndActivated = do
unless (isJust started && activated) retry
chatStoreCxt :: CM StoreCxt
chatStoreCxt = lift chatStoreCxt'
chatStoreCxt = asks storeCxt
{-# INLINE chatStoreCxt #-}
chatStoreCxt' :: CM' StoreCxt
chatStoreCxt' = mkStoreCxt <$> asks config
{-# INLINE chatStoreCxt' #-}
chatVersionRange :: CM VersionRangeChat
chatVersionRange = lift chatVersionRange'
{-# INLINE chatVersionRange #-}
src/Simplex/Chat/Library/Subscriber.hs
+144 -132
View File
@@ -115,9 +115,9 @@ smallGroupsRcptsMemLimit = 20
-- Verifies member signatures over CBGroup <> (publicGroupId, memberId) or (memberId, pubKey) <> signedBody under the given key.
-- signatures is NonEmpty so the verification can't be vacuously true.
verifyGroupSig :: C.PublicKeyEd25519 -> Maybe GroupKeys -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
verifyGroupSig key gks memberId signatures signedBody =
let prefix = encodeChatBinding CBGroup $ groupBindingData gks memberId key
verifyGroupSig :: C.PublicKeyEd25519 -> GroupInfo -> MemberId -> NonEmpty MsgSignature -> ByteString -> Bool
verifyGroupSig key gInfo memberId signatures signedBody =
let prefix = encodeChatBinding CBGroup $ groupBindingData gInfo memberId key
in all (\case (MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 key) sig (prefix <> signedBody)) signatures
processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
@@ -138,13 +138,18 @@ processAgentMessage corrId connId msg = do
-- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
-- as in this case no need to ACK message - we can't process messages for this connection anyway.
critical connId (withStore $ getUserEntity cxt) >>= \case
Just (user, entity) -> processAgentMessageConn cxt user entity corrId connId msg `catchAllErrors` eToView
Just (user, entity, gks_) -> processAgentMessageConn cxt user entity gks_ corrId connId msg `catchAllErrors` eToView
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
where
getUserEntity :: StoreCxt -> DB.Connection -> ExceptT StoreError IO (Maybe (User, ConnectionEntity))
getUserEntity :: StoreCxt -> DB.Connection -> ExceptT StoreError IO (Maybe (User, ConnectionEntity, Maybe GroupKeys))
getUserEntity cxt db =
liftIO (getUserByAConnId db $ AgentConnId connId)
>>= mapM (\user -> (user,) <$> (getConnectionEntity db cxt user (AgentConnId connId) >>= liftIO . updateConnStatus db))
>>= mapM (\user -> do
(entity, groupKeysData_) <- getConnectionEntityKeys db cxt user (AgentConnId connId)
gks_ <- case entity of
RcvGroupMsgConnection _ gInfo _ -> mapM (mkGroupKeys db cxt gInfo) groupKeysData_
_ -> pure Nothing
(user,,gks_) <$> liftIO (updateConnStatus db entity))
updateConnStatus :: DB.Connection -> ConnectionEntity -> IO ConnectionEntity
updateConnStatus db acEntity = case agentMsgConnStatus (entityConnection acEntity) msg of
@@ -431,8 +436,8 @@ processAgentMsgRcvFile _corrId aFileId msg = do
type ShouldDeleteGroupConns = Bool
processAgentMessageConn :: StoreCxt -> User -> ConnectionEntity -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMessage =
processAgentMessageConn :: StoreCxt -> User -> ConnectionEntity -> Maybe GroupKeys -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId agentMessage =
case agentMessage of
END -> case entity of
RcvDirectMsgConnection _ (Just ct) -> toView $ CEvtContactAnotherClient user ct
@@ -441,8 +446,9 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
_ -> case entity of
RcvDirectMsgConnection conn contact_ ->
processDirectMessage agentMessage entity conn contact_
RcvGroupMsgConnection conn gInfo m ->
processGroupMessage agentMessage entity conn gInfo m
RcvGroupMsgConnection conn gInfo m -> case gks_ of
Just gks -> processGroupMessage agentMessage entity conn (GIK gInfo gks) m
Nothing -> throwChatError $ CEInternalError "group connection entity without group keys"
UserContactConnection conn uc ->
processContactConnMessage agentMessage entity conn uc
where
@@ -497,10 +503,10 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
profileToSend <-
presentUserBadge user incognitoProfile $ case gInfo_ of
Just gInfo -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
Just (GIK gInfo _) -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn'' confId gInfo_ $ XInfo profileToSend (groupMemberKey =<< gInfo_)
allowAgentConnectionAsync user conn'' confId gInfo_ $ XInfo profileToSend ((\(GIK _ gks) -> groupMemberKey gks) <$> gInfo_)
INFO pqSupport connInfo -> do
processINFOpqSupport conn pqSupport
void $ saveConnInfo conn connInfo
@@ -620,6 +626,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
void $ withStore' $ \db -> resetMemberContactFields db ct'
XGrpLinkInv glInv -> do
-- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
when (isPublicGroupInv glInv) $ throwChatError $ CEInvalidChatMessage conn'' Nothing (safeDecodeUtf8 connInfo) "x.grp.link.inv: publicGroup not allowed in p2p groups"
memberKeys <- atomically . C.generateKeyPair =<< asks random
(gInfo, host) <- withStore $ \db -> do
liftIO $ deleteContactCardKeepConn db connId ct
@@ -628,7 +635,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- [incognito] send saved profile
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile)
allowAgentConnectionAsync user conn'' confId (Just gInfo) $ XInfo profileToSend (groupMemberKey gInfo)
let gks = GKGroup {memberPrivKey = snd memberKeys}
allowAgentConnectionAsync user conn'' confId (Just $ GIK gInfo gks) $ XInfo profileToSend (Just $ groupMemberKey gks)
toView $ CEvtBusinessLinkConnecting user gInfo host ct
_ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info"
INFO pqSupport connInfo -> do
@@ -754,8 +762,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci]
processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM ()
processGroupMessage agentMsg connEntity conn@Connection {connId, customUserProfileId, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of
processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfoKeys -> GroupMember -> CM ()
processGroupMessage agentMsg connEntity conn@Connection {connId, customUserProfileId, connectionCode} g@(GIK gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} gks) m = case agentMsg of
INV (ACR _ cReq) ->
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} ->
case cReq of
@@ -780,7 +788,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
forM_ mKey $ \(MemberKey k) -> withStore' $ \db -> setMemberPubKey db (groupMemberId' m) k
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId (Just gInfo) XOk
allowAgentConnectionAsync user conn' confId (Just g) XOk
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
XGrpRelayAcpt relayLink relayCap
| memberRole' membership == GROwner && isRelay m -> do
@@ -800,7 +808,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
liftIO $ updateGroupMemberStatus db userId m GSMemLeft
pure (relay', m {memberStatus = GSMemLeft})
-- complete the contact handshake so the relay receives INFO and cleans up its transient bookkeeping
allowAgentConnectionAsync user conn' confId (Just gInfo) XOk
allowAgentConnectionAsync user conn' confId (Just g) XOk
toView $ CEvtGroupRelayUpdated user gInfo m' relay'
toViewTE $ TERelayRejected user gInfo reason
| otherwise -> messageError "x.grp.relay.reject: only owner should receive relay rejection"
@@ -812,12 +820,11 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
pgId = fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId),
useRelays' gInfo == isJust rcvPG && pgId rcvPG == pgId curPG -> do
-- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records
(gInfo'', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
gInfo' <- createUserMemberKey gInfo''
(gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db cxt user gInfo m glInv
-- [incognito] send saved profile
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo' (fromLocalProfile <$> incognitoProfile)
allowAgentConnectionAsync user conn' confId (Just gInfo') $ XInfo profileToSend (groupMemberKey gInfo')
allowAgentConnectionAsync user conn' confId (Just $ GIK gInfo' gks) $ XInfo profileToSend (Just $ groupMemberKey gks)
toView $ CEvtGroupLinkConnecting user gInfo' m'
| otherwise -> messageError "x.grp.link.inv: publicGroupId mismatch"
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
@@ -833,7 +840,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
membershipProfile <- presentUserBadge user (incognitoMembershipProfile gInfo) $ redactedMemberProfile gInfo membership $ fromLocalProfile $ memberProfile membership
-- TODO update member profile
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId (Just gInfo) $ XGrpMemInfo membershipMemId membershipProfile
allowAgentConnectionAsync user conn' confId (Just g) $ XGrpMemInfo membershipMemId membershipProfile
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
_ -> messageError "CONF from member must have x.grp.mem.info"
INFO _pqSupport connInfo -> do
@@ -914,12 +921,12 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
Nothing -> do
withStore' $ \db -> setGroupRosterVersion db gInfo (VersionRoster 0)
pure gInfo {rosterVersion = Just (VersionRoster 0)}
sendGroupRosterToRelay user gInfo' m
sendGroupRosterToRelay user (GIK gInfo' gks) m
else do
-- a relay below groupRosterVersion can't ack a roster; publish it on connect as before
-- the handshake (getPublishableGroupRelays and the LINK handler include/activate it by version)
gLink <- withStore $ \db -> getGroupLink db user gInfo
setGroupLinkDataAsync user gInfo gLink
setGroupLinkDataAsync user g gLink
| otherwise -> do
(gInfo', mStatus) <-
if not (memberPending m)
@@ -940,26 +947,25 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo'' m'
if useRelays' gInfo''
then do
introduceInChannel cxt user gInfo'' m'
introduceInChannel cxt user (GIK gInfo'' gks) m'
case mStatus of
GSMemPendingApproval -> pure ()
GSMemPendingReview -> pure ()
_ -> when (groupFeatureAllowed SGFHistory gInfo'') $ sendHistory user gInfo'' m'
else case mStatus of
GSMemPendingApproval -> pure ()
GSMemPendingReview -> introduceToModerators cxt user gInfo'' m'
GSMemPendingReview -> introduceToModerators cxt user (GIK gInfo'' gks) m'
_ -> do
introduceToAll cxt user gInfo'' m'
introduceToAll cxt user (GIK gInfo'' gks) m'
let memberIsCustomer = case businessChat gInfo'' of
Just BusinessChatInfo {chatType = BCCustomer, customerId} -> memberId' m' == customerId
_ -> False
when (groupFeatureAllowed SGFHistory gInfo'' && not memberIsCustomer) $ sendHistory user gInfo'' m'
where
sendXGrpLinkMem gInfo''' m' = do
gInfo'' <- createUserMemberKey gInfo'''
sendXGrpLinkMem gInfo'' m' = do
let incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo''
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo'' (fromIncognitoProfile <$> incognitoProfile)
sendGroupMemberMessages user gInfo'' conn [XGrpLinkMem profileToSend (groupMemberKey gInfo'')]
sendGroupMemberMessages user (GIK gInfo'' gks) conn [XGrpLinkMem profileToSend (Just $ groupMemberKey gks)]
_ -> do
unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected
notifyMemberConnected gInfo m Nothing
@@ -1023,7 +1029,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
case fwd_ of
Just fwd | SJson <- enc -> do
logInfo $ "group fwd=" <> tshow tag <> " " <> eInfo
xGrpMsgForward gInfo' scopeInfo m' fwd parsedMsg brokerTs
xGrpMsgForward (GIK gInfo' gks) scopeInfo m' fwd parsedMsg brokerTs
`catchAllErrors` \e -> eToView e
pure newDeliveryTasks
-- direct JSON and binary messages; binary events don't produce delivery tasks
@@ -1074,36 +1080,36 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName
XInfo p mKey -> fmap ctx <$> xInfoMember gInfo' m'' p mKey msg brokerTs
XGrpLinkMem p mKey -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p mKey msg
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs
XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt (GIK gInfo' gks) m'' acceptance role memberId msg brokerTs
XGrpRelayNew rl -> fmap ctx <$> xGrpRelayNew gInfo' m'' rl
XGrpRelayCap relayCap
| memberRole' membership == GROwner && isRelay m'' ->
Nothing <$ withStore' (\db -> updateRelayCapabilities db m'' relayCap)
| otherwise -> Nothing <$ messageWarning "x.grp.relay.cap: only owner should receive relay capabilities"
XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs
XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew (GIK gInfo' gks) m'' memInfo msgScope msg brokerTs
XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_
XGrpMemInv memId introInv -> Nothing <$ xGrpMemInv gInfo' m'' memId introInv
XGrpMemFwd memInfo introInv -> Nothing <$ xGrpMemFwd gInfo' m'' memInfo introInv
XGrpMemRole memId memRole memberKey rosterVer -> fmap ctx <$> xGrpMemRole gInfo' Nothing m'' memId memRole memberKey rosterVer msg brokerTs
XGrpMemRole memId memRole memberKey rosterVer -> fmap ctx <$> xGrpMemRole (GIK gInfo' gks) Nothing m'' memId memRole memberKey rosterVer msg brokerTs
XGrpMemRestrict memId memRestrictions -> fmap ctx <$> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs
XGrpMemCon memId -> Nothing <$ xGrpMemCon gInfo' m'' memId
XGrpMemDel memId withMessages rosterVer -> case encoding @e of
SJson -> fmap ctx <$> xGrpMemDel gInfo' Nothing m'' memId withMessages rosterVer verifiedMsg msg brokerTs False
SJson -> fmap ctx <$> xGrpMemDel (GIK gInfo' gks) Nothing m'' memId withMessages rosterVer verifiedMsg msg brokerTs False
SBinary -> pure Nothing
XGrpLeave -> fmap ctx <$> xGrpLeave gInfo' m'' msg brokerTs
XGrpLeave -> fmap ctx <$> xGrpLeave (GIK gInfo' gks) m'' msg brokerTs
XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs
XGrpInfo p' -> fmap ctx <$> xGrpInfo gInfo' m'' p' msg brokerTs
XGrpInfo p' -> fmap ctx <$> xGrpInfo (GIK gInfo' gks) m'' p' msg brokerTs
XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps' msg
XGrpRoster gr -> fmap ctx <$> xGrpRoster gInfo' m'' m'' gr verifiedMsg sharedMsgId_ brokerTs
XGrpRosterAck ackVer ackErr -> Nothing <$ xGrpRosterAck gInfo' m'' ackVer ackErr
XGrpRosterRequest reqVer -> Nothing <$ xGrpRosterRequest gInfo' m'' reqVer
XGrpRosterAck ackVer ackErr -> Nothing <$ xGrpRosterAck (GIK gInfo' gks) m'' ackVer ackErr
XGrpRosterRequest reqVer -> Nothing <$ xGrpRosterRequest (GIK gInfo' gks) m'' reqVer
-- TODO [knocking] why don't we forward these messages?
XGrpDirectInv connReq mContent_ msgScope -> memberCanSend (Just m'') msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs
XGrpMsgForward fwd msg' -> Nothing <$ xGrpMsgForward gInfo' Nothing m'' fwd (ParsedMsg Nothing Nothing msg') brokerTs
XGrpMsgForward fwd msg' -> Nothing <$ xGrpMsgForward (GIK gInfo' gks) Nothing m'' fwd (ParsedMsg Nothing Nothing msg') brokerTs
XInfoProbe probe -> Nothing <$ xInfoProbe (COMGroupMember m'') probe
XInfoProbeCheck probeHash -> Nothing <$ xInfoProbeCheck (COMGroupMember m'') probeHash
XInfoProbeOk probe -> Nothing <$ xInfoProbeOk (COMGroupMember m'') probe
BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup gInfo' m'' sharedMsgId chunk msgMeta
BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup (GIK gInfo' gks) m'' sharedMsgId chunk msgMeta
_ -> Nothing <$ messageError ("unsupported message: " <> tshow event)
forM deliveryTaskContext_ $ \taskContext -> do
let contentChanged :: CM ()
@@ -1170,7 +1176,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
mapM_ toView fileEvent_
unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis
when continued $ do
when (isUserGrpFwdRelay gInfo) $ serveRoster user gInfo m -- roster ahead of the resumed backlog
when (isUserGrpFwdRelay gInfo) $ serveRoster user g m -- roster ahead of the resumed backlog
sendPendingGroupMessages user gInfo m conn
SWITCH qd phase cStats -> do
toView $ CEvtGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
@@ -1241,7 +1247,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
withStore' $ \db -> updateConnLinkData db user conn cReq cReqHash groupLinkId chatV pqSup
let incognitoProfile = fromLocalProfile <$> incognitoMembershipProfile gInfo
profileToSend <- presentUserBadge user incognitoProfile $ userProfileInGroup user gInfo incognitoProfile
dm <- encodeXMemberConnInfo gInfo relayMemberId profileToSend
dm <- encodeXMemberConnInfo g relayMemberId profileToSend
subMode <- chatReadVar subscriptionMode
(cmdId, connId') <- prepareAgentJoin user (Just conn) True cReq
joinAgentConnectionAsync cmdId True connId' True cReq dm subMode
@@ -1257,7 +1263,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
(m', relay) <- setRelayLinkAccepted db cxt user m (MemberKey relayKey) relayProfile
pure (confId, m', relay)
allowAgentConnectionAsync user conn confId (Just gInfo) XOk
allowAgentConnectionAsync user conn confId (Just g) XOk
toView $ CEvtGroupRelayUpdated user gInfo m' relay
else
-- TODO [relays] owner: TBC failed RelayStatus?
@@ -1266,7 +1272,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
QCONT -> do
continued <- continueSending connEntity conn
when continued $ do
when (isUserGrpFwdRelay gInfo) $ serveRoster user gInfo m -- roster ahead of the resumed backlog
when (isUserGrpFwdRelay gInfo) $ serveRoster user g m -- roster ahead of the resumed backlog
sendPendingGroupMessages user gInfo m conn
MWARN msgId err -> do
withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSWarning $ agentSndError err)
@@ -1311,9 +1317,9 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
_ -> pure Nothing
sendGroupAutoReply mc = \case
Just UserContactRequest {welcomeSharedMsgId = Just smId} ->
void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
void $ sendGroupMessage' user g [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing
_ -> do
msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ mcSimple mc
msg <- sendGroupMessage' user g [m] $ XMsgNew $ mcSimple mc
ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndMsgContent mc)
withStore' $ \db -> createGroupSndStatus db (chatItemId' ci) (groupMemberId' m) GSSNew
toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing) ci]
@@ -1340,7 +1346,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
r n'' = Just (ci, CIRcvDecryptionError mde n'')
mdeUpdatedCI _ _ = Nothing
receiveFileChunk :: Maybe GroupInfo -> RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
receiveFileChunk :: Maybe GroupInfoKeys -> RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
receiveFileChunk gInfo_ ft@RcvFileTransfer {fileId, fileType, chunkSize} conn_ MsgMeta {recipient = (msgId, _), integrity} = \case
FileChunkCancel -> case fileType of
-- cancel only this source's transfer; other relays' in-flight transfers are independent
@@ -1408,13 +1414,13 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
CFSetShortLink ->
case (ucGroupId_, auData) of
(Just groupId, UserContactLinkData UserContactData {relays = relayLinks}) -> do
(gInfo, gLink, relays, relaysChanged, newlyActiveLinks) <- withStore $ \db -> do
gInfo <- getGroupInfo db cxt user groupId
(g@(GIK gInfo _), gLink, relays, relaysChanged, newlyActiveLinks) <- withStore $ \db -> do
g@(GIK gInfo _) <- getGroupInfoKeys db cxt user groupId
gLink <- getGroupLink db user gInfo
relays <- liftIO $ getGroupRelays db gInfo
(relays', changed, newlyActiveLinks) <- liftIO $ foldrM (updateRelay db) ([], False, []) relays
liftIO $ setGroupInProgressDone db gInfo
pure (gInfo, gLink, relays', changed, newlyActiveLinks)
pure (g, gLink, relays', changed, newlyActiveLinks)
toView $ CEvtGroupLinkDataUpdated user gInfo gLink relays relaysChanged
let GroupSummary {publicMemberCount} = groupSummary gInfo
-- Owner is counted in publicMemberCount; > 1 means at least one subscriber.
@@ -1430,7 +1436,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
allRelayMembers
events = XGrpRelayNew <$> newlyActive
unless (null recipients) $
void $ sendGroupMessages user gInfo Nothing False recipients False events
void $ sendGroupMessages user g Nothing False recipients False events
where
updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool, [ShortLinkContact]) -> IO ([GroupRelay], Bool, [ShortLinkContact])
updateRelay db relay@GroupRelay {relayLink, relayStatus} (acc, changed, newlyActiveLinks) =
@@ -1479,7 +1485,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
REContact ct ->
-- TODO [short links] update request msg
toView $ CEvtContactRequestAlreadyAccepted user ct
REBusinessChat gInfo _clientMember ->
REBusinessChat (GIK gInfo _) _clientMember ->
-- TODO [short links] update request msg
toView $ CEvtBusinessRequestAlreadyAccepted user gInfo
RSCurrentRequest prevUcr_ ucr@UserContactRequest {welcomeSharedMsgId} re_ -> case re_ of
@@ -1513,8 +1519,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
else pure Nothing
ct' <- acceptContactRequestAsync user uclId ct ucr incognitoProfile
toView $ CEvtAcceptingContactRequest user ct'
Just (REBusinessChat gInfo clientMember) -> do
(_gInfo', _clientMember') <- acceptBusinessJoinRequestAsync user uclId gInfo clientMember ucr
Just (REBusinessChat g@(GIK gInfo _) clientMember) -> do
(_gInfo', _clientMember') <- acceptBusinessJoinRequestAsync user uclId g clientMember ucr
let cd = CDGroupRcv gInfo Nothing clientMember
void $ case prevUcr_ of
Just UserContactRequest {requestSharedMsgId = prevSharedMsgId_} ->
@@ -1606,7 +1612,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- ##### Group link join requests (don't create contact requests) #####
Just gli@GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
-- TODO [short links] deduplicate request by xContactId?
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
g@(GIK gInfo _) <- withStore $ \db -> getGroupInfoKeys db cxt user groupId
if
| useRelays' gInfo ->
messageWarning $ "processContactConnMessage (group " <> groupName' gInfo <> "): ignored direct join request from " <> displayName <> " (group uses relays)"
@@ -1617,7 +1623,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
maybe (pure $ Right (GAAccepted, gLinkMemRole)) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case
Right (acceptance, useRole) -> do
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode memberKey_ Nothing
mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode memberKey_ Nothing
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem'
@@ -1661,7 +1667,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
(_ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId
case gLinkInfo_ of
Just GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
gInfo <- withStore $ \db -> getGroupInfo db cxt user groupId
g@(GIK gInfo _) <- withStore $ \db -> getGroupInfoKeys db cxt user groupId
existing_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberByMemberId db cxt user gInfo joiningMemberId)
case existing_ of
Just rosterMem
@@ -1669,21 +1675,21 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- possession of that exact key, otherwise this is an attempt to impersonate it
| isRosterRole (memberRole' rosterMem) ->
if verifyKey gInfo rosterMem
then acceptJoin gInfo (Just rosterMem) (memberRole' rosterMem)
then acceptJoin g (Just rosterMem) (memberRole' rosterMem)
else messageError "memberJoinRequestViaRelay: rejected join claiming privileged memberId (key mismatch or invalid signature)"
_ -> acceptJoin gInfo Nothing gLinkMemRole
_ -> acceptJoin g Nothing gLinkMemRole
Nothing ->
messageError "memberJoinRequestViaRelay: no group link info for relay link"
where
-- replay defense: the viaRelay == own memberId check (viaRelay is in the signed body); without it a sibling relay could replay a privileged member's signed join
verifyKey gInfo rosterMem = case (signedMsg_, groupKeys gInfo) of
(Just SignedMsg {chatBinding = CBGroup, signatures, signedBody}, Just gks) ->
verifyKey gInfo rosterMem = case signedMsg_ of
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} ->
memberPubKey rosterMem == Just joiningKey
&& verifyGroupSig joiningKey (Just gks) joiningMemberId signatures signedBody
&& verifyGroupSig joiningKey gInfo joiningMemberId signatures signedBody
&& viaRelay == Just (memberId' (membership gInfo))
_ -> False
acceptJoin gInfo existingMem_ acceptRole = do
mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p Nothing (Just joiningMemberId) Nothing GAAccepted acceptRole Nothing (Just joiningMemberKey) existingMem_
acceptJoin g@(GIK gInfo _) existingMem_ acceptRole = do
mem <- acceptGroupJoinRequestAsync user uclId g invId chatVRange p Nothing (Just joiningMemberId) Nothing GAAccepted acceptRole Nothing (Just joiningMemberKey) existingMem_
(gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem
createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem'
@@ -2592,8 +2598,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- A group BFileChunk is a normal inline file chunk or a roster blob chunk, both located by
-- (group_id, shared_msg_id). A chunk matching no in-flight transfer (an orphaned re-served roster
-- chunk, or a missing normal file) is ignored; the outer withAckMessage acks it.
bFileChunkGroup :: GroupInfo -> GroupMember -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunkGroup gInfo@GroupInfo {groupId} fromMember sharedMsgId chunk meta = do
bFileChunkGroup :: GroupInfoKeys -> GroupMember -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunkGroup gInfo@(GIK GroupInfo {groupId} _) fromMember sharedMsgId chunk meta = do
fileId_ <- withStore' $ \db -> getGroupRcvFileId db userId groupId (groupMemberId' fromMember) sharedMsgId
forM_ fileId_ $ \fileId -> do
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
@@ -2613,7 +2619,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- A roster re-serve re-sends the blob from chunk 1; discard any partial first, else chunk 1 over a
-- partial is out-of-order (RcvChunkError) and appending after the stale prefix corrupts the blob.
receiveRosterChunk :: GroupInfo -> RcvFileTransfer -> MsgMeta -> FileChunk -> CM ()
receiveRosterChunk :: GroupInfoKeys -> RcvFileTransfer -> MsgMeta -> FileChunk -> CM ()
receiveRosterChunk gInfo ft meta chunk = do
case chunk of
FileChunk {chunkNo} | chunkNo == 1 -> do
@@ -2678,14 +2684,14 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
memberKeys <- atomically . C.generateKeyPair =<< asks random
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId memberKeys
(GIK gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership} gks, hostId) <- withStore $ \db -> createGroupInvitation db cxt user ct inv customUserProfileId memberKeys
void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing Nothing (Just epochStart)
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
-- hostContact is only reported for group links, where the client replaces
-- the transient host connection view with the group and removes its chat
joinGroupAsync hostContact_ sameLink = do
subMode <- chatReadVar subscriptionMode
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (groupMemberKey gInfo)
dm <- encodeConnInfo $ XGrpAcpt membershipMemId (Just $ groupMemberKey gks)
connIds@(cmdId, acId) <- prepareAgentJoin user Nothing True connRequest
withStore' $ \db -> do
when sameLink $ setViaGroupLinkUri db groupId connId
@@ -2815,11 +2821,11 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
| otherwise -> messageError "member key not signed by that key, ignored"
where
signed = case signedMsg_ of
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} -> verifyGroupSig k (groupKeys gInfo) memberId signatures signedBody
Just SignedMsg {chatBinding = CBGroup, signatures, signedBody} -> verifyGroupSig k gInfo memberId signatures signedBody
_ -> False
xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
xGrpLinkAcpt gInfo@GroupInfo {membership} m acceptance role memberId msg brokerTs
xGrpLinkAcpt :: GroupInfoKeys -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
xGrpLinkAcpt g@(GIK gInfo@GroupInfo {membership} _) m acceptance role memberId msg brokerTs
| memberRole' m < GRModerator || memberRole' m < role =
messageError "x.grp.link.acpt with insufficient member permissions"
| sameMemberId memberId membership = processUserAccepted
@@ -2868,7 +2874,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
GAPendingApproval ->
messageWarning "x.grp.link.acpt: unexpected group acceptance - pending approval"
introduceToRemainingMembers acceptedMember = do
introduceToRemaining cxt user gInfo acceptedMember
introduceToRemaining cxt user g acceptedMember
when (groupFeatureAllowed SGFHistory gInfo) $ sendHistory user gInfo acceptedMember
maybeCreateGroupDescrLocal :: GroupInfo -> GroupMember -> CM ()
@@ -3144,7 +3150,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
toView $ CEvtContactAndMemberAssociated user c2 g m1 c2'
pure c2'
saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Maybe GroupInfo)
saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Maybe GroupInfoKeys)
saveConnInfo activeConn connInfo = do
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
conn' <- updatePeerChatVRange activeConn chatVRange
@@ -3154,21 +3160,25 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
toView $ CEvtContactConnecting user ct
pure (conn', Nothing)
XGrpLinkInv glInv -> do
when (isPublicGroupInv glInv) $ throwChatError $ CEInvalidChatMessage conn' Nothing (safeDecodeUtf8 connInfo) "x.grp.link.inv: publicGroup not allowed in p2p groups"
memberKeys <- atomically . C.generateKeyPair =<< asks random
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db cxt user conn' memberKeys glInv
toView $ CEvtGroupLinkConnecting user gInfo host
pure (conn', Just gInfo)
pure (conn', Just $ GIK gInfo GKGroup {memberPrivKey = snd memberKeys})
XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do
memberKeys <- atomically . C.generateKeyPair =<< asks random
(gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db cxt user conn' memberKeys glRjct
toView $ CEvtGroupLinkConnecting user gInfo host
toViewTE $ TEGroupLinkRejected user gInfo rejectionReason
pure (conn', Just gInfo)
pure (conn', Just $ GIK gInfo GKGroup {memberPrivKey = snd memberKeys})
-- TODO show/log error, other events in SMP confirmation
_ -> pure (conn', Nothing)
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _ assertedKey_) msgScope_ msg brokerTs = do
isPublicGroupInv :: GroupLinkInvitation -> Bool
isPublicGroupInv GroupLinkInvitation {groupProfile = GroupProfile {publicGroup}} = isJust publicGroup
xGrpMemNew :: GroupInfoKeys -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpMemNew (GIK gInfo gks) m memInfo@(MemberInfo memId memRole _ _ assertedKey_) msgScope_ msg brokerTs = do
unless (useRelays' gInfo) $ checkHostRole m memRole
if sameMemberId memId (membership gInfo)
then pure Nothing
@@ -3188,7 +3198,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
messageWarning $ "x.grp.mem.new: relay asserted key differs from roster-established key, keeping roster key, memberId=" <> safeDecodeUtf8 (strEncode memId)
updatedMember <- withStore $ \db -> updateRosterMemberAnnounced db cxt user m unknownMember memInfo initialStatus
-- roster members can't be pending, so no members-require-attention update
gInfo' <- updatePublicGroupData user gInfo
gInfo' <- updatePublicGroupData user gInfo gks
toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember
memberAnnouncedToView updatedMember gInfo'
pure $ deliveryJobScope updatedMember
@@ -3203,7 +3213,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
else pure gInfo
pure (updatedMember, gInfo')
gInfo'' <- updatePublicGroupData user gInfo'
gInfo'' <- updatePublicGroupData user gInfo' gks
toView $ CEvtUnknownMemberAnnounced user gInfo'' m unknownMember updatedMember
memberAnnouncedToView updatedMember gInfo''
pure $ deliveryJobScope updatedMember
@@ -3221,7 +3231,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
then liftIO $ increaseGroupMembersRequireAttention db user gInfo
else pure gInfo
pure (newMember, gInfo')
gInfo'' <- updatePublicGroupData user gInfo'
gInfo'' <- updatePublicGroupData user gInfo' gks
memberAnnouncedToView newMember gInfo''
pure $ deliveryJobScope newMember
where
@@ -3341,8 +3351,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- batch), then advance it in the same transaction; a strictly lower version is a replay and is ignored.
-- Only an owner sender may advance it: a non-owner signed event is rejected by the action that follows,
-- but must not bump roster_version first, or every later owner roster at a lower version is dropped.
applyAtRosterVersion :: GroupInfo -> Maybe GroupMember -> GroupMember -> Maybe VersionRoster -> CM (Maybe DeliveryJobScope) -> CM (Maybe DeliveryJobScope)
applyAtRosterVersion gInfo fwdRelay_ sender rosterVer_ action
applyAtRosterVersion :: GroupInfoKeys -> Maybe GroupMember -> GroupMember -> Maybe VersionRoster -> CM (Maybe DeliveryJobScope) -> CM (Maybe DeliveryJobScope)
applyAtRosterVersion g@(GIK gInfo _) fwdRelay_ sender rosterVer_ action
| not (useRelays' gInfo) = action
| otherwise = case rosterVer_ of
Nothing -> action
@@ -3380,19 +3390,19 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
| otherwise = case fwdRelay_ of
Just relay
| gap, relay `supportsVersion` groupRosterVersion ->
void $ sendGroupMessage' user gInfo [relay] (XGrpRosterRequest prevComplete)
void $ sendGroupMessage' user g [relay] (XGrpRosterRequest prevComplete)
_ -> pure ()
where
gap = v > nextCompleteVersion prevComplete
xGrpMemRole :: GroupInfo -> Maybe GroupMember -> GroupMember -> MemberId -> GroupMemberRole -> Maybe MemberKey -> Maybe VersionRoster -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpMemRole gInfo@GroupInfo {membership} fwdRelay_ m@GroupMember {memberRole = senderRole} memId memRole memberKey_ rosterVer_ msg@RcvMessage {msgSigned} brokerTs
xGrpMemRole :: GroupInfoKeys -> Maybe GroupMember -> GroupMember -> MemberId -> GroupMemberRole -> Maybe MemberKey -> Maybe VersionRoster -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpMemRole g@(GIK gInfo@GroupInfo {membership} _) fwdRelay_ m@GroupMember {memberRole = senderRole} memId memRole memberKey_ rosterVer_ msg@RcvMessage {msgSigned} brokerTs
| memRole == GRRelay = messageError "x.grp.mem.role: relay role can't be assigned" $> Nothing
| membershipMemId == memId =
applyAtRosterVersion gInfo fwdRelay_ m rosterVer_ $
applyAtRosterVersion g fwdRelay_ m rosterVer_ $
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
in changeMemberRole gInfo' membership False (\db -> updateGroupMemberRole db user membership memRole) (RGEUserRole memRole) True
| otherwise = applyAtRosterVersion gInfo fwdRelay_ m rosterVer_ $ do
| otherwise = applyAtRosterVersion g fwdRelay_ m rosterVer_ $ do
defaultRole <- unknownMemberRole gInfo
-- an owner-signed event with a key TOFU-creates an unknown member only for a roster role; else a plain lookup
let allowCreate = useRelays' gInfo && senderRole == GROwner && isRosterRole memRole && isJust memberKey_
@@ -3486,8 +3496,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- Blob arrived: verify the owner-attested digest over the plaintext and guard against
-- downgrade before applying; on a relay, ack the owner and re-serve to members.
rosterCompletion :: GroupInfo -> RcvFileTransfer -> CM ()
rosterCompletion gInfo RcvFileTransfer {fileId, fileStatus} =
rosterCompletion :: GroupInfoKeys -> RcvFileTransfer -> CM ()
rosterCompletion g@(GIK gInfo _) RcvFileTransfer {fileId, fileStatus} =
withStore' (\db -> getRosterTransfer db fileId) >>= \case
-- defensive: the file always has its transfer (created together, deleted together)
Nothing -> lift (closeFileHandle fileId rcvFiles) >> forM_ (rosterFilePath fileStatus) removeFsFile
@@ -3497,7 +3507,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
let isRelay' = isUserGrpFwdRelay gInfo
ackErr err = do
cleanupRosterTransferById transferId
when isRelay' $ forM_ owner_ $ \owner -> sendRosterAck gInfo owner pendingVer (Just err)
when isRelay' $ forM_ owner_ $ \owner -> sendRosterAck g owner pendingVer (Just err)
if FD.FileDigest (LC.sha512Hash (LB.fromStrict blob)) /= pendingDigest
then ackErr "relay could not verify the roster blob"
else case parseAll rosterBlobP blob of
@@ -3522,7 +3532,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
emitRosterResults gInfo author rosterBrokerTs results
-- ack while setting up (own status accepted/acknowledged); a serving (active) relay must not ack broadcasts.
when (isRelay' && (relayOwnStatus gInfo == Just RSAccepted || relayOwnStatus gInfo == Just RSAcknowledgedRoster)) $ do
sendRosterAck gInfo author pendingVer Nothing
sendRosterAck g author pendingVer Nothing
withStore' $ \db -> void $ updateRelayOwnStatusFromTo db gInfo RSAccepted RSAcknowledgedRoster
where
rosterFilePath = \case
@@ -3588,11 +3598,11 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
else pure (gInfo, author)
toView CEvtMemberRole {user, groupInfo = gInfo', byMember = author', member, fromRole, toRole, msgSigned = Just MSSVerified}
sendRosterAck :: GroupInfo -> GroupMember -> VersionRoster -> Maybe Text -> CM ()
sendRosterAck :: GroupInfoKeys -> GroupMember -> VersionRoster -> Maybe Text -> CM ()
sendRosterAck gInfo owner ackVer err = void $ sendGroupMessage' user gInfo [owner] (XGrpRosterAck ackVer err)
xGrpRosterAck :: GroupInfo -> GroupMember -> VersionRoster -> Maybe Text -> CM ()
xGrpRosterAck gInfo m ackVer err = do
xGrpRosterAck :: GroupInfoKeys -> GroupMember -> VersionRoster -> Maybe Text -> CM ()
xGrpRosterAck g@(GIK gInfo _) m ackVer err = do
relay_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupRelayByGMId db (groupMemberId' m))
case relay_ of
Just relay@GroupRelay {relayStatus = RSAccepted} -> case err of
@@ -3602,7 +3612,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
relay' <- liftIO $ updateRelayStatus db relay RSAcknowledgedRoster
gLink <- getGroupLink db user gInfo
pure (relay', gLink)
setGroupLinkDataAsync user gInfo gLink
setGroupLinkDataAsync user g gLink
toView $ CEvtGroupRelayUpdated user gInfo m relay'
| otherwise -> messageWarning "x.grp.roster.ack: stale version, awaiting ack for the current roster"
Just e -> do
@@ -3616,13 +3626,13 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- - the latter bounds reflected amplification (a member can't re-trigger a full serve). Gating on the stored
-- blob (not roster_version, the gate) means the relay serves only a blob the requester will accept.
-- serveRoster records the served version (on all serve paths) and is a no-op without a roster.
xGrpRosterRequest :: GroupInfo -> GroupMember -> Maybe VersionRoster -> CM ()
xGrpRosterRequest gInfo m reqVer_ =
xGrpRosterRequest :: GroupInfoKeys -> GroupMember -> Maybe VersionRoster -> CM ()
xGrpRosterRequest g@(GIK gInfo _) m reqVer_ =
when (isUserGrpFwdRelay gInfo) $ do
(stored_, served_) <- withStore' $ \db ->
(,) <$> getStoredRosterVersion db gInfo <*> getMemberRosterServedVersion db m
forM_ stored_ $ \stored ->
when (maybe True (stored >) reqVer_ && maybe True (stored >) served_) $ serveRoster user gInfo m
when (maybe True (stored >) reqVer_ && maybe True (stored >) served_) $ serveRoster user g m
checkHostRole :: GroupMember -> GroupMemberRole -> CM ()
checkHostRole GroupMember {memberRole, localDisplayName} memRole =
@@ -3668,11 +3678,11 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
withStore $ \db -> setMemberVectorRelationConnected db sendingMem refMem MRSubjectConnected
withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected
xGrpMemDel :: GroupInfo -> Maybe GroupMember -> GroupMember -> MemberId -> Bool -> Maybe VersionRoster -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
xGrpMemDel gInfo@GroupInfo {membership} fwdRelay_ m@GroupMember {memberRole = senderRole} memId withMessages rosterVer_ verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do
xGrpMemDel :: GroupInfoKeys -> Maybe GroupMember -> GroupMember -> MemberId -> Bool -> Maybe VersionRoster -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope)
xGrpMemDel g@(GIK gInfo@GroupInfo {membership} gks) fwdRelay_ m@GroupMember {memberRole = senderRole} memId withMessages rosterVer_ verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do
let GroupMember {memberId = membershipMemId} = membership
if membershipMemId == memId
then applyAtRosterVersion gInfo fwdRelay_ m rosterVer_ $ checkRole membership $ do
then applyAtRosterVersion g fwdRelay_ m rosterVer_ $ checkRole membership $ do
deleteGroupLinkIfExists user gInfo
-- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay
unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False
@@ -3684,7 +3694,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
deleteMemberItem msg gInfo RGEUserDeleted
toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned
pure $ Just DJSGroup {jobSpec = DJRelayRemoved}
else applyAtRosterVersion gInfo fwdRelay_ m rosterVer_ $
else applyAtRosterVersion g fwdRelay_ m rosterVer_ $
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db cxt user gInfo memId) >>= \case
Left _ -> do
messageError "x.grp.mem.del with unknown member ID"
@@ -3710,7 +3720,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
fullyDeleteMemberRecord user gInfo deletedMember
-- Undeleted "member connected" chat item will prevent deletion of member record.
| otherwise -> deleteOrUpdateMemberRecord user gInfo deletedMember
gInfo'' <- updatePublicGroupData user gInfo'
gInfo'' <- updatePublicGroupData user gInfo' gks
let wasDeleted = memberStatus == GSMemRemoved || memberStatus == GSMemLeft
-- Clear forwardedByMember if it references the deleted member,
-- as the member record was already deleted above.
@@ -3752,12 +3762,12 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
| useRelays' gInfo = asks $ channelSubscriberRole . config
| otherwise = pure GRAuthor
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpLeave gInfo m msg@RcvMessage {msgSigned} brokerTs = do
xGrpLeave :: GroupInfoKeys -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpLeave (GIK gInfo gks) m msg@RcvMessage {msgSigned} brokerTs = do
deleteMemberConnection m
-- member record is not deleted to allow creation of "member left" chat item
gInfo' <- updateMemberRecordDeleted user gInfo m GSMemLeft
gInfo'' <- updatePublicGroupData user gInfo'
gInfo'' <- updatePublicGroupData user gInfo' gks
unless (muteEventInChannel gInfo'' m) $ do
(gInfo''', m', scopeInfo) <- mkGroupChatScope gInfo'' m
(ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo''' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEMemberLeft)
@@ -3777,8 +3787,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
groupMsgToView cInfo ci
toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m' msgSigned
xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpInfo g@GroupInfo {groupProfile = p@GroupProfile {publicGroup = pg}, businessChat} m@GroupMember {memberRole} p'@GroupProfile {publicGroup = pg'} msg@RcvMessage {msgSigned} brokerTs
xGrpInfo :: GroupInfoKeys -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope)
xGrpInfo gik@(GIK g@GroupInfo {groupProfile = p@GroupProfile {publicGroup = pg}, businessChat} gks) m@GroupMember {memberRole} p'@GroupProfile {publicGroup = pg'} msg@RcvMessage {msgSigned} brokerTs
| memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" $> Nothing
| let pgId = fmap (\PublicGroupProfile {publicGroupId} -> publicGroupId),
useRelays' g && (isNothing pg' || pgId pg' /= pgId pg) = messageError "x.grp.info: publicGroupId mismatch for channel" $> Nothing
@@ -3798,10 +3808,10 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
-- other owners receiving the update do not refresh the same link
ChatConfig {updateGroupLinksFromApp} <- asks config
unless (useRelays' g'' || updateGroupLinksFromApp) $
void $ forkIO $ void $ setGroupLinkData' NRMBackground user g''
void $ forkIO $ void $ setGroupLinkData' NRMBackground user (GIK g'' gks)
Just _ -> updateGroupPrefs_ msgSigned g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
-- relay advertises its web capability now that the owner's version is known (bumped by saveGroupRcvMsg)
when (isRelay (membership g)) $ sendRelayCapIfNeeded user g
when (isRelay (membership g)) $ sendRelayCapIfNeeded user gik
pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}}
xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> RcvMessage -> CM (Maybe DeliveryJobScope)
@@ -3916,8 +3926,8 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
toViewTE $ TEContactVerificationReset user ct
createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing
xGrpMsgForward :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> GrpMsgForward -> ParsedMsg 'Json -> UTCTime -> CM ()
xGrpMsgForward gInfo scopeInfo m@GroupMember {localDisplayName} GrpMsgForward {fwdSender, fwdBrokerTs = msgTs} parsedMsg@(ParsedMsg _ _ chatMsg@ChatMessage {chatMsgEvent}) brokerTs = do
xGrpMsgForward :: GroupInfoKeys -> Maybe GroupChatScopeInfo -> GroupMember -> GrpMsgForward -> ParsedMsg 'Json -> UTCTime -> CM ()
xGrpMsgForward g@(GIK gInfo _) scopeInfo m@GroupMember {localDisplayName} GrpMsgForward {fwdSender, fwdBrokerTs = msgTs} parsedMsg@(ParsedMsg _ _ chatMsg@ChatMessage {chatMsgEvent}) brokerTs = do
unless (isMemberGrpFwdRelay gInfo m) $ throwChatError (CEGroupContactRole localDisplayName)
case fwdSender of
FwdMember memberId memberName -> do
@@ -3961,13 +3971,13 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId
XInfo p mKey -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p mKey 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 memberKey rosterVer -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo (Just m) author memId memRole memberKey rosterVer rcvMsg msgTs
XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew g author memInfo msgScope rcvMsg msgTs
XGrpMemRole memId memRole memberKey rosterVer -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole g (Just m) author memId memRole memberKey rosterVer rcvMsg msgTs
XGrpMemRestrict memId memRestrictions -> withAuthor XGrpMemRestrict_ $ \author -> void $ xGrpMemRestrict gInfo author memId memRestrictions rcvMsg msgTs
XGrpMemDel memId withMessages rosterVer -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel gInfo (Just m) author memId withMessages rosterVer verifiedMsg rcvMsg msgTs True
XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave gInfo author rcvMsg msgTs
XGrpMemDel memId withMessages rosterVer -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel g (Just m) author memId withMessages rosterVer verifiedMsg rcvMsg msgTs True
XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave g author rcvMsg msgTs
XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs
XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo gInfo author p' rcvMsg msgTs
XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo g author p' rcvMsg msgTs
XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps' rcvMsg
XGrpRoster gr -> withAuthor XGrpRoster_ $ \author -> void $ xGrpRoster gInfo m author gr verifiedMsg sharedMsgId_ msgTs
_ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event)
@@ -3978,7 +3988,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author"
withVerifiedMsg :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a)
withVerifiedMsg gInfo@GroupInfo {membership, groupKeys} scopeInfo member@GroupMember {memberPubKey, memberId} (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
withVerifiedMsg gInfo@GroupInfo {membership} scopeInfo member@GroupMember {memberPubKey, memberId} (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action =
case verified of
Just verifiedMsg -> Just <$> action verifiedMsg
Nothing -> do
@@ -3988,7 +3998,7 @@ processAgentMessageConn cxt user@User {userId} entity corrId agentConnId agentMe
verified = case signedMsg_ of
Just sm@SignedMsg {chatBinding, signatures, signedBody} -> case memberPubKey of
Just pubKey -> case chatBinding of
CBGroup -> signed MSSVerified <$ guard (verifyGroupSig pubKey groupKeys memberId signatures signedBody)
CBGroup -> signed MSSVerified <$ guard (verifyGroupSig pubKey gInfo memberId signatures signedBody)
_ -> signed MSSSignedNoKey <$ guard signatureOptional
Nothing -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag)
where
@@ -4476,10 +4486,10 @@ runRelayRequestWorker a Worker {doWork} = do
eToView e
processRelayRequest :: GroupId -> RelayRequestData -> CM ()
processRelayRequest groupId rrd = do
(gInfo, groupLink_) <- withStore $ \db -> do
gInfo <- getGroupInfo db cxt user groupId
(g@(GIK gInfo _), groupLink_) <- withStore $ \db -> do
g@(GIK gInfo _) <- getGroupInfoKeys db cxt user groupId
groupLink_ <- liftIO $ runExceptT $ getGroupLink db user gInfo
pure (gInfo, groupLink_)
pure (g, groupLink_)
-- Check if relay link already exists (recovery case)
case groupLink_ of
Right GroupLink {connLinkContact = CCLink _ sLnk_} ->
@@ -4487,11 +4497,14 @@ runRelayRequestWorker a Worker {doWork} = do
Just sLnk -> acceptOwnerConnection rrd gInfo sLnk
Nothing -> throwChatError $ CEException "processRelayRequest: relay link doesn't have short link"
Left _ -> do
(gInfo', sLnk) <- getLinkDataCreateRelayLink rrd gInfo
(gInfo', sLnk) <- getLinkDataCreateRelayLink rrd g
acceptOwnerConnection rrd gInfo' sLnk
where
getLinkDataCreateRelayLink :: RelayRequestData -> GroupInfo -> CM (GroupInfo, ShortLinkContact)
getLinkDataCreateRelayLink RelayRequestData {reqGroupLink} gInfo = do
getLinkDataCreateRelayLink :: RelayRequestData -> GroupInfoKeys -> CM (GroupInfo, ShortLinkContact)
getLinkDataCreateRelayLink RelayRequestData {reqGroupLink} (GIK gInfo gks) = do
memberPrivKey' <- case gks of
GKRelayRequest {memberPrivKey} -> pure memberPrivKey
_ -> throwChatError $ CEException "getLinkDataCreateRelayLink: group is not a relay request"
(FixedLinkData {linkEntityId, rootKey}, cData@(ContactLinkData _ UserContactData {owners}), _) <- getShortLinkConnReq' NRMBackground user reqGroupLink
liftIO (decodeLinkUserData cData) >>= \case
Nothing -> throwChatError $ CEException "getLinkDataCreateRelayLink: no group link data"
@@ -4501,10 +4514,10 @@ runRelayRequestWorker a Worker {doWork} = do
| B64UrlByteString entityId == publicGroupId -> pure pg
_ -> throwChatError $ CEException "getLinkDataCreateRelayLink: linkEntityId does not match profile publicGroupId"
validateGroupProfile gp
((_, memberPrivKey), sLnk) <- createRelayLink gInfo
sLnk <- createRelayLink gInfo (C.publicKey memberPrivKey', memberPrivKey')
gInfo' <- withStore $ \db -> do
void $ updateGroupProfile db user gInfo gp
updateRelayGroupKeys db user gInfo pg rootKey memberPrivKey owners
updateRelayGroupKeys db user gInfo pg rootKey owners
getGroupInfo db cxt user groupId
pure (gInfo', sLnk)
where
@@ -4512,14 +4525,13 @@ runRelayRequestWorker a Worker {doWork} = do
validateGroupProfile _groupProfile = do
-- TODO [relays] relay: validate group profile, verify owner's signature
pure ()
createRelayLink :: GroupInfo -> CM (C.KeyPairEd25519, ShortLinkContact)
createRelayLink gi = do
createRelayLink :: GroupInfo -> C.KeyPairEd25519 -> CM ShortLinkContact
createRelayLink gi sigKeys = do
let GroupInfo {membership} = gi
GroupMember {memberId = MemberId relayMemId, memberProfile = p} = membership
gVar <- asks random
groupLinkId <- GroupLinkId <$> drgRandomBytes 16
subMode <- chatReadVar subscriptionMode
sigKeys <- atomically $ C.generateKeyPair gVar
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) CR.IKPQOff False Nothing
@@ -4534,7 +4546,7 @@ runRelayRequestWorker a Worker {doWork} = do
-- TODO [relays] starting role should be communicated in protocol from owner to relays
subRole <- asks $ channelSubscriberRole . config
void $ withFastStore $ \db -> createGroupLink db gVar user gi connId ccLink' groupLinkId subRole subMode
pure (sigKeys, sLnk)
pure sLnk
acceptOwnerConnection :: RelayRequestData -> GroupInfo -> ShortLinkContact -> CM ()
acceptOwnerConnection RelayRequestData {relayInvId, reqChatVRange} gi relayLink = do
ownerMember <- withStore $ \db -> getHostMember db cxt user groupId
src/Simplex/Chat/Mobile.hs
+25 -9
View File
@@ -12,6 +12,7 @@ module Simplex.Chat.Mobile where
import Control.Concurrent.STM
import Control.Exception (SomeException, catch)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Data.Aeson (ToJSON (..))
@@ -35,6 +36,7 @@ import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable (poke)
import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEncoding)
import Numeric.Natural (Natural)
import Simplex.Chat
import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
import Simplex.Chat.Controller
@@ -73,6 +75,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
data DBMigrationResult
= DBMOk
| DBMInvalidConfirmation
| DBMInvalidQueueSize
| DBMErrorNotADatabase {dbFile :: String}
| DBMErrorMigration {dbFile :: String, migrationError :: MigrationError}
| DBMErrorSQL {dbFile :: String, migrationSQLError :: String}
@@ -113,6 +116,8 @@ foreign export ccall "chat_migrate_init" cChatMigrateInit :: CString -> CString
foreign export ccall "chat_migrate_init_key" cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
foreign export ccall "chat_migrate_init_queue" cChatMigrateInitQueue :: CString -> CString -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
foreign export ccall "chat_close_store" cChatCloseStore :: StablePtr ChatController -> IO CString
foreign export ccall "chat_reopen_store" cChatReopenStore :: StablePtr ChatController -> IO CString
@@ -166,7 +171,14 @@ cChatMigrateInit fp key conf = cChatMigrateInitKey fp key 0 conf 0
-- For postgres first param is schema prefix, second param is database connection string.
cChatMigrateInitKey :: CString -> CString -> CInt -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInitKey fp key keepKey conf background ctrl = do
cChatMigrateInitKey fp key keepKey conf background = cChatMigrateInit_ fp key (keepKey /= 0) conf (background /= 0) mobileQueueSize
-- | queueSize is the size of internal queues, same as terminal option --queue-size
cChatMigrateInitQueue :: CString -> CString -> CString -> CInt -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInitQueue fp key conf queueSize = cChatMigrateInit_ fp key False conf False (fromIntegral queueSize)
cChatMigrateInit_ :: CString -> CString -> Bool -> CString -> Bool -> Int -> Ptr (StablePtr ChatController) -> IO CJSONString
cChatMigrateInit_ fp key keepKey conf background queueSize ctrl = do
-- ensure we are set to UTF-8; iOS does not have locale, and will default to
-- US-ASCII all the time.
setLocaleEncoding utf8
@@ -176,7 +188,7 @@ cChatMigrateInitKey fp key keepKey conf background ctrl = do
chatDbOpts <- mobileDbOpts fp key
confirm <- peekCAString conf
r <-
chatMigrateInitKey chatDbOpts (keepKey /= 0) confirm (background /= 0) >>= \case
chatMigrateInitKey chatDbOpts keepKey confirm background queueSize >>= \case
Right cc -> (newStablePtr cc >>= poke ctrl) $> DBMOk
Left e -> pure e
newCStringFromLazyBS $ J.encode r
@@ -254,8 +266,11 @@ cChatParseBadgeCode cCode = do
cChatJsonLength :: CString -> IO CInt
cChatJsonLength s = fromIntegral . subtract 2 . LB.length . J.encode . safeDecodeUtf8 <$> B.packCString s
mobileChatOpts :: ChatDbOpts -> ChatOpts
mobileChatOpts dbOptions =
mobileQueueSize :: Int
mobileQueueSize = 4096
mobileChatOpts :: ChatDbOpts -> Natural -> ChatOpts
mobileChatOpts dbOptions tbqSize =
ChatOpts
{ coreOptions =
CoreChatOpts
@@ -268,7 +283,7 @@ mobileChatOpts dbOptions =
logServerHosts = True,
logAgent = Nothing,
logFile = Nothing,
tbqSize = 4096,
tbqSize,
maxChats = 5000,
deviceName = Nothing,
chatRelay = False,
@@ -313,18 +328,19 @@ getActiveUser_ st = find activeUser <$> withTransaction st getUsers
chatMigrateInit :: String -> ScrubbedBytes -> String -> IO (Either DBMigrationResult ChatController)
chatMigrateInit dbFilePrefix dbKey confirm = do
let chatDBOpts = ChatDbOpts {dbFilePrefix, dbKey, trackQueries = DB.TQSlow 5000, vacuumOnMigration = True}
chatMigrateInitKey chatDBOpts False confirm False
chatMigrateInitKey chatDBOpts False confirm False mobileQueueSize
#endif
chatMigrateInitKey :: ChatDbOpts -> Bool -> String -> Bool -> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey chatDbOpts keepKey confirm backgroundMode = runExceptT $ do
chatMigrateInitKey :: ChatDbOpts -> Bool -> String -> Bool -> Int -> IO (Either DBMigrationResult ChatController)
chatMigrateInitKey chatDbOpts keepKey confirm backgroundMode queueSize = runExceptT $ do
unless (queueSize > 0) $ throwError DBMInvalidQueueSize
confirmMigrations <- liftEitherWith (const DBMInvalidConfirmation) $ strDecode $ B.pack confirm
let migrationConfig = MigrationConfig confirmMigrations (Just "")
chatStore <- migrate createChatStore (toDBOpts chatDbOpts chatSuffix keepKey chatDBFunctions) migrationConfig
agentStore <- migrate createAgentStore (toDBOpts chatDbOpts agentSuffix keepKey []) migrationConfig
ExceptT $ initialize chatStore ChatDatabase {chatStore, agentStore}
where
opts = mobileChatOpts $ removeDbKey chatDbOpts
opts = mobileChatOpts (removeDbKey chatDbOpts) (fromIntegral queueSize)
initialize st db = do
user_ <- liftIO $ getActiveUser_ st
first DBMAgentError <$> newChatController db user_ defaultMobileConfig opts backgroundMode
src/Simplex/Chat/Store/Badges.hs
+60 -11
View File
@@ -4,6 +4,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
module Simplex.Chat.Store.Badges
( BadgeCodeRedemption (..),
@@ -12,6 +13,8 @@ module Simplex.Chat.Store.Badges
getBadgePurchase,
userHasBadge,
setBadgeAlertAcked,
setBadgeIssueError,
setBadgeNextWake,
clearShownBadge,
getBadgeCodeRedemption,
createBadgeCodeRedemption,
@@ -22,6 +25,7 @@ module Simplex.Chat.Store.Badges
getLatestIssuedCredential,
storeBadgeStatement,
getBadgeLedgerLastEntry,
getBadgeLedger,
getBadgeLedgerEntryId,
)
where
@@ -31,13 +35,13 @@ import Crypto.Random (ChaChaDRG)
import qualified Data.Aeson as J
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64)
import Data.Maybe (isJust)
import Data.Maybe (isJust, mapMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Simplex.Chat.Badges
import Simplex.Chat.Badges.Ledger
import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgePurchaseStatus (..))
import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..))
import Simplex.Chat.Store.Shared (insertedRowId)
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
@@ -144,6 +148,11 @@ storeBadgeIssuance db g badgePurchaseId entryId credential now =
ON CONFLICT (badge_purchase_id, entry_id) DO NOTHING
|]
((issuanceId, badgePurchaseId, entryId, badgeType) :. (periodStart, periodEnd, badgeExpiry, Binary (LB.toStrict $ J.encode credential), now))
-- a month stored ends the run of failures
DB.execute
db
"UPDATE badge_purchases SET issue_failed_since = NULL, issue_error_at = NULL, issue_error = NULL WHERE badge_purchase_id = ?"
(Only badgePurchaseId)
pure True
where
BadgeCredential {badgeInfo = BadgeInfo {badgeType, badgeExpiry}} = credential
@@ -198,7 +207,9 @@ data UserBadgePurchase = UserBadgePurchase
badgeType :: BadgeType,
shown :: Bool,
alertAcked :: Maybe (BadgeAlertKind, Text),
alertSnoozeUntil :: Maybe UTCTime
alertSnoozeUntil :: Maybe UTCTime,
issueError :: Maybe BadgeIssueError,
nextWakeAt :: Maybe UTCTime
}
-- | Newest, not the one shown_badge_id points at - retirement clears that, and the support ended
@@ -227,14 +238,15 @@ getBadgePurchase db purchaseId =
[sql|
SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type,
(CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END),
p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until
p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until,
p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at
FROM badge_purchases p
JOIN users u ON u.user_id = p.user_id
WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL
|]
(Only purchaseId)
where
toPurchase (badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) =
toPurchase ((badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) :. (failedSince_, lastAttemptAt_, reason_, nextWakeAt)) =
UserBadgePurchase
{ badgePurchaseId,
purchaseKey,
@@ -243,7 +255,9 @@ getBadgePurchase db purchaseId =
badgeType,
shown = unBI shown_,
alertAcked = (,) <$> ackedKind_ <*> ackedEpisode_,
alertSnoozeUntil
alertSnoozeUntil,
issueError = BadgeIssueError <$> failedSince_ <*> lastAttemptAt_ <*> reason_,
nextWakeAt
}
-- | Whether a badge is on the profile now: set when a redemption stores one, cleared when it is
@@ -265,6 +279,24 @@ setBadgeAlertAcked db User {userId} badgePurchaseId kind episode snoozeUntil =
"UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ? AND user_id = ?"
(kind, episode, snoozeUntil, badgePurchaseId, userId)
-- | Record a renewal that ended without a credential. The COALESCE keeps the start of the current
-- run of failures, which is the alert's episode and must survive a restart.
setBadgeIssueError :: DB.Connection -> Int64 -> UTCTime -> BadgeIssueFailure -> IO ()
setBadgeIssueError db badgePurchaseId now failure =
DB.execute
db
[sql|
UPDATE badge_purchases
SET issue_failed_since = COALESCE(issue_failed_since, ?), issue_error_at = ?, issue_error = ?
WHERE badge_purchase_id = ?
|]
(now, now, failure, badgePurchaseId)
-- | The wake the worker is about to wait for, so the state the apps hold says when it will try again.
setBadgeNextWake :: DB.Connection -> Int64 -> Maybe UTCTime -> IO ()
setBadgeNextWake db badgePurchaseId at_ =
DB.execute db "UPDATE badge_purchases SET next_wake_at = ? WHERE badge_purchase_id = ?" (at_, badgePurchaseId)
-- | Stop showing a badge that has expired unrenewed; the profile update is broadcast by the caller.
clearShownBadge :: DB.Connection -> User -> Int64 -> IO ()
clearShownBadge db User {userId} badgePurchaseId =
@@ -306,7 +338,7 @@ storeBadgeStatement db badgePurchaseId badgeType tip entries now =
-- | The balance is the last row; nothing derives it by summing the history.
getBadgeLedgerLastEntry :: DB.Connection -> Int64 -> IO (Maybe StatementEntry)
getBadgeLedgerLastEntry db badgePurchaseId =
maybeFirstRow' Nothing toEntry $
maybeFirstRow' Nothing toStatementEntry $
DB.query
db
[sql|
@@ -318,10 +350,27 @@ getBadgeLedgerLastEntry db badgePurchaseId =
LIMIT 1
|]
(Only badgePurchaseId)
where
toEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType) :. (wasPausedSince, createdAt, entryType_, credit_, debit_, value_)) =
(\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType})
<$> maybe (entryTypeFromColumns entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
-- | Oldest first. A row whose type this version cannot rebuild is left out, as it is from the tip.
getBadgeLedger :: DB.Connection -> User -> Int64 -> IO [StatementEntry]
getBadgeLedger db User {userId} badgePurchaseId =
mapMaybe toStatementEntry
<$> DB.query
db
[sql|
SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type,
l.was_paused_since, l.service_created_at, l.entry_type, l.entry_credit_type, l.entry_debit_type, l.entry_type_value
FROM badge_ledger l
JOIN badge_purchases p ON p.badge_purchase_id = l.badge_purchase_id
WHERE l.badge_purchase_id = ? AND p.user_id = ?
ORDER BY l.entry_id
|]
(badgePurchaseId, userId)
toStatementEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType) :. (Maybe UTCTime, UTCTime, Text, Maybe Text, Maybe Text, Maybe Text) -> Maybe StatementEntry
toStatementEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType) :. (wasPausedSince, createdAt, entryType_, credit_, debit_, value_)) =
(\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType})
<$> maybe (entryTypeFromColumns entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
-- | Decodes the stored JSON rather than rebuilding from the tag, so a version that has since
-- learnt the type reads it with its fields, and one that has not still gets it back verbatim.
src/Simplex/Chat/Store/Connections.hs
+14 -8
View File
@@ -12,6 +12,7 @@
module Simplex.Chat.Store.Connections
( getChatLockEntity,
getConnectionEntity,
getConnectionEntityKeys,
getConnectionEntityByConnReq,
getConnectionEntityViaShortLink,
getContactConnEntityByConnReqHash,
@@ -76,18 +77,23 @@ getChatLockEntity db agentConnId = do
-- - from receiving: getConnectionEntity, getContactConnEntityByConnReqHash
-- - from subscribing: getContactConnsToSub, getUCLConnsToSub, getMemberConnsToSub, getPendingConnsToSub
getConnectionEntity :: DB.Connection -> StoreCxt -> User -> AgentConnId -> ExceptT StoreError IO ConnectionEntity
getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
getConnectionEntity db cxt user agentConnId = fst <$> getConnectionEntityKeys db cxt user agentConnId
getConnectionEntityKeys :: DB.Connection -> StoreCxt -> User -> AgentConnId -> ExceptT StoreError IO (ConnectionEntity, Maybe GroupKeysRow)
getConnectionEntityKeys db cxt user@User {userId, userContactId} agentConnId = do
c@Connection {connType, entityId} <- getConnection_
case entityId of
Nothing ->
if connType == ConnContact
then pure $ RcvDirectMsgConnection c Nothing
then pure (RcvDirectMsgConnection c Nothing, Nothing)
else throwError $ SEInternalError $ "connection " <> show connType <> " without entity"
Just entId ->
case connType of
ConnMember -> uncurry (RcvGroupMsgConnection c) <$> getGroupAndMember_ entId c
ConnContact -> RcvDirectMsgConnection c . Just <$> getContactRec_ entId c
ConnUserContact -> UserContactConnection c <$> getUserContact_ entId
ConnMember -> do
((gInfo, keysData), m) <- getGroupAndMember_ entId c
pure (RcvGroupMsgConnection c gInfo m, Just keysData)
ConnContact -> (,Nothing) . RcvDirectMsgConnection c . Just <$> getContactRec_ entId c
ConnUserContact -> (,Nothing) . UserContactConnection c <$> getUserContact_ entId
where
getConnection_ :: ExceptT StoreError IO Connection
getConnection_ = ExceptT $ do
@@ -134,7 +140,7 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
contactRequest = UserContactRequestRef <$> contactRequestId <*> (unBI <$> rejectionSupported_)
groupDirectInv = toGroupDirectInvitation groupDirectInvRow
in Contact {contactId, localDisplayName, profile, activeConn, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, preparedContact, contactRequestId, contactRequest, contactGroupMemberId, contactGrpInvSent, groupDirectInv, chatTags, chatItemTTL, uiThemes, chatDeleted, customData}
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO ((GroupInfo, GroupKeysRow), GroupMember)
getGroupAndMember_ groupMemberId c = do
currentTs <- liftIO getCurrentTime
gm <-
@@ -178,8 +184,8 @@ getConnectionEntity db cxt user@User {userId, userContactId} agentConnId = do
AND mu.member_status NOT IN (?,?,?)
|]
(groupMemberId, userId, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
liftIO $ bitraverse (addGroupChatTags db) pure gm
toGroupAndMember :: UTCTime -> Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
liftIO $ bitraverse (\(g, keysData) -> (,keysData) <$> addGroupChatTags db g) pure gm
toGroupAndMember :: UTCTime -> Connection -> GroupInfoRow :. GroupMemberRow -> ((GroupInfo, GroupKeysRow), GroupMember)
toGroupAndMember currentTs c (groupInfoRow :. memberRow) =
let groupInfo = toGroupInfo currentTs cxt userContactId [] groupInfoRow
member = toGroupMember currentTs userContactId memberRow
src/Simplex/Chat/Store/ContactRequest.hs
+10 -8
View File
@@ -91,11 +91,12 @@ createOrUpdateContactRequest
pure $ RSAcceptedRequest cr (REContact ct)
Nothing ->
liftIO (getAcceptedBusinessChat xContactId) >>= \case
Just gInfo@GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
Just (gInfo@GroupInfo {businessChat = Just BusinessChatInfo {customerId}}, keysData) -> do
clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
cr <- liftIO $ getContactRequestByXContactId xContactId
pure $ RSAcceptedRequest cr (REBusinessChat gInfo clientMember)
Just GroupInfo {businessChat = Nothing} -> throwError SEInvalidBusinessChatContactRequest
gks <- mkGroupKeys db cxt gInfo keysData
pure $ RSAcceptedRequest cr (REBusinessChat (GIK gInfo gks) clientMember)
Just (GroupInfo {businessChat = Nothing}, _) -> throwError SEInvalidBusinessChatContactRequest
-- 2) if no legacy accepted contact or business chat was found, next we try to find an existing request
Nothing ->
liftIO (getContactRequestByXContactId xContactId) >>= \case
@@ -131,7 +132,7 @@ createOrUpdateContactRequest
|]
(userId, xContactId)
mapM (addDirectChatTags db) ct_
getAcceptedBusinessChat :: XContactId -> IO (Maybe GroupInfo)
getAcceptedBusinessChat :: XContactId -> IO (Maybe (GroupInfo, GroupKeysRow))
getAcceptedBusinessChat xContactId = do
currentTs <- getCurrentTime
g_ <-
@@ -140,7 +141,7 @@ createOrUpdateContactRequest
db
(groupInfoQuery <> " WHERE g.business_xcontact_id = ? AND g.user_id = ? AND mu.contact_id = ?")
(xContactId, userId, userContactId)
mapM (addGroupChatTags db) g_
forM g_ $ \(g, keysData) -> (,keysData) <$> addGroupChatTags db g
getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest)
getContactRequestByXContactId xContactId = do
currentTs <- getCurrentTime
@@ -214,7 +215,7 @@ createOrUpdateContactRequest
pure $ RSCurrentRequest Nothing ucr (Just $ REContact ct)
createBusinessChat = do
let groupPreferences = maybe defaultBusinessGroupPrefs businessGroupPrefs $ preferences' user
(gInfo@GroupInfo {groupId}, clientMember) <-
(gInfo@(GIK GroupInfo {groupId} _), clientMember) <-
createBusinessRequestGroup db cxt gVar user cReqChatVRange profile profileId ldn groupPreferences
liftIO $
DB.execute
@@ -302,11 +303,12 @@ createOrUpdateContactRequest
ct <- getContact db cxt user contactId
pure $ Just (REContact ct)
(Nothing, Just businessGroupId) -> do
gInfo <- getGroupInfo db cxt user businessGroupId
(gInfo, keysData) <- getGroupInfoRow db cxt user businessGroupId
case gInfo of
GroupInfo {businessChat = Just BusinessChatInfo {customerId}} -> do
clientMember <- getGroupMemberByMemberId db cxt user gInfo customerId
pure $ Just (REBusinessChat gInfo clientMember)
gks <- mkGroupKeys db cxt gInfo keysData
pure $ Just (REBusinessChat (GIK gInfo gks) clientMember)
_ -> throwError SEInvalidBusinessChatContactRequest
(Nothing, Nothing) -> pure Nothing
_ -> throwError $ SEInvalidContactRequestEntity contactRequestId
src/Simplex/Chat/Store/Direct.hs
+1 -1
View File
@@ -188,7 +188,7 @@ createConnReqConnection db userId acId preparedEntity_ cReq cReqHash sLnk xConta
connId <- insertedRowId db
case preparedEntity_ of
-- For relay groups, setPreparedGroupLinkInfo_ is called via updatePreparedRelayedGroup before the relay loop
Just (PCEGroup gInfo _) | not (useRelays' gInfo) ->
Just (PCEGroup (GIK gInfo _) _) | not (useRelays' gInfo) ->
setPreparedGroupLinkInfo_ db gInfo cReq cReqHash customUserProfileId Nothing currentTs
_ -> pure ()
pure
src/Simplex/Chat/Store/Groups.hs
+49 -68
View File
@@ -40,6 +40,7 @@ module Simplex.Chat.Store.Groups
createGroupRejectedViaLink,
setGroupInvitationChatItemId,
getGroup,
getGroupKeys_,
getGroupInfoByUserContactLinkConnReq,
getGroupInfoViaUserTarget,
getGroupViaShortLinkToConnect,
@@ -144,7 +145,7 @@ module Simplex.Chat.Store.Groups
updatePreparedRelayedGroup,
updatePublicMemberCount,
setPublicMemberCount,
updateGroupMemberKeys,
setGroupRootKey,
updateRelayGroupKeys,
updateGroupMemberStatus,
updateGroupMemberStatusById,
@@ -376,26 +377,24 @@ setGroupLinkShortLink db gLnk@GroupLink {userContactLinkId, connLinkContact = CC
pure gLnk {connLinkContact = CCLink connFullLink (Just shortLink), shortLinkDataSet = True, shortLinkLargeDataSet = BoolDef True}
-- | creates completely new group with a single member - the current user
createNewGroup :: DB.Connection -> StoreCxt -> User -> GroupProfile -> Maybe Profile -> Bool -> MemberId -> Maybe GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays memberId groupKeys publicMemberCount_ = ExceptT $ do
createNewGroup :: DB.Connection -> StoreCxt -> User -> GroupProfile -> Maybe Profile -> MemberId -> GroupKeys -> Maybe Int64 -> ExceptT StoreError IO GroupInfo
createNewGroup db cxt user@User {userId} groupProfile incognitoProfile memberId groupKeys publicMemberCount_ = ExceptT $ do
let GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission} = groupProfile
(groupType_, groupLink_, publicGroupId_) = case publicGroup of
Just PublicGroupProfile {groupType, groupLink, publicGroupId} -> (Just groupType, Just groupLink, Just publicGroupId)
Nothing -> (Nothing, Nothing, Nothing)
fullGroupPreferences = mergeGroupPreferences groupPreferences
useRelays = isPublicGroup groupKeys
rosterVersion0 = if useRelays then Just (VersionRoster 0) else Nothing
currentTs <- getCurrentTime
customUserProfileId <- mapM (createIncognitoProfile_ db userId currentTs) incognitoProfile
withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do
let (rootPrivKey_, rootPubKey_, memberPrivKey_) = case groupKeys of
Nothing -> (Nothing, Nothing, Nothing)
Just GroupKeys {publicGroupKeys, memberPrivKey} ->
let (rpk, rpub) = case publicGroupKeys of
Just PublicGroupKeys {groupRootKey} -> case groupRootKey of
GRKPrivate pk -> (Just pk, Nothing)
GRKPublic k -> (Nothing, Just k)
Nothing -> (Nothing, Nothing)
in (rpk, rpub, Just memberPrivKey)
let (rootPrivKey_, rootPubKey_) = case groupKeys of
GKPublicGroup {groupRootKey} -> case groupRootKey of
GRKPrivate pk -> (Just pk, Nothing)
GRKPublic k -> (Nothing, Just k)
_ -> (Nothing, Nothing)
memberPrivKey_ = Just $ memberPrivKey groupKeys
groupId <- liftIO $ do
DB.execute
db
@@ -423,7 +422,7 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
:. (rootPrivKey_, rootPubKey_, memberPrivKey_, publicMemberCount_, rosterVersion0)
)
insertedRowId db
let memberPubKey = C.publicKey . memberPrivKey <$> groupKeys
let memberPubKey = Just $ C.publicKey $ memberPrivKey groupKeys
membership <- createContactMemberInv_ db user groupId Nothing user (MemberIdRole memberId GROwner) GCUserMember GSMemCreator IBUser customUserProfileId memberPubKey currentTs (vr cxt)
let chatSettings = ChatSettings {enableNtfs = MFAll, sendRcpts = Nothing, favorite = False}
pure
@@ -451,18 +450,17 @@ createNewGroup db cxt user@User {userId} groupProfile incognitoProfile useRelays
customData = Nothing,
membersRequireAttention = 0,
viaGroupLinkUri = Nothing,
groupKeys,
groupDomainVerified = Nothing
}
-- | creates a new group record for the group the current user was invited to, or returns an existing one
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> C.KeyPairEd25519 -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation :: DB.Connection -> StoreCxt -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> C.KeyPairEd25519 -> ExceptT StoreError IO (GroupInfoKeys, GroupMemberId)
createGroupInvitation _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, activeConn = Just Connection {peerChatVRange}} GroupInvitation {fromMember, fromMemberKey, invitedMember, connRequest, groupProfile, business} incognitoProfileId memberKeys = do
liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_
Just gId -> do
gInfo@GroupInfo {membership, groupProfile = p'} <- getGroupInfo db cxt user gId
GIK gInfo@GroupInfo {membership, groupProfile = p'} gks <- getGroupInfoKeys db cxt user gId
hostId <- getHostMemberId_ db user gId
let GroupMember {groupMemberId, memberId, memberRole} = membership
MemberIdRole {memberId = invMemberId, memberRole = invMemberRole} = invitedMember
@@ -472,13 +470,13 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
if p' == groupProfile
then pure gInfo
else updateGroupProfile db user gInfo groupProfile
pure (gInfo', hostId)
pure (GIK gInfo' gks, hostId)
where
getInvitationGroupId_ :: IO (Maybe Int64)
getInvitationGroupId_ =
maybeFirstRow fromOnly $
DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId)
createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation_ :: ExceptT StoreError IO (GroupInfoKeys, GroupMemberId)
createGroupInvitation_ = do
let GroupProfile {displayName, fullName, shortDescr, description, image, groupPreferences, memberAdmission} = groupProfile
fullGroupPreferences = mergeGroupPreferences groupPreferences
@@ -530,9 +528,9 @@ createGroupInvitation db cxt user@User {userId} contact@Contact {contactId, acti
customData = Nothing,
membersRequireAttention = 0,
viaGroupLinkUri = Nothing,
groupKeys = Just GroupKeys {publicGroupKeys = Nothing, memberPrivKey = snd memberKeys},
groupDomainVerified = Nothing
},
}
`GIK` GKGroup {memberPrivKey = snd memberKeys},
groupMemberId
)
@@ -946,10 +944,13 @@ setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
-- TODO return the last connection that is ready, not any last connection
-- requires updating connection status
getGroup :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO Group
getGroup db cxt user groupId = do
gInfo <- getGroupInfo db cxt user groupId
getGroup db cxt user groupId = fst <$> getGroupKeys_ db cxt user groupId
getGroupKeys_ :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT StoreError IO (Group, GroupKeys)
getGroupKeys_ db cxt user groupId = do
GIK gInfo gks <- getGroupInfoKeys db cxt user groupId
members <- liftIO $ getGroupMembers db cxt user gInfo
pure $ Group gInfo members
pure (Group gInfo members, gks)
deleteGroupChatItems :: DB.Connection -> User -> GroupInfo -> IO ()
deleteGroupChatItems db User {userId} GroupInfo {groupId} =
@@ -1054,7 +1055,7 @@ getInProgressGroups db cxt user@User {userId} createdAtCutoff = do
getBaseGroupDetails :: DB.Connection -> StoreCxt -> User -> Maybe ContactId -> Maybe Text -> IO [GroupInfo]
getBaseGroupDetails db cxt User {userId, userContactId} _contactId_ search_ = do
currentTs <- getCurrentTime
map (toGroupInfo currentTs cxt userContactId [])
map (toGroupInfo_ currentTs cxt userContactId [])
<$> DB.query db (groupInfoQuery <> " " <> condition) (userId, userContactId, search, search, search, search)
where
condition =
@@ -1361,11 +1362,11 @@ getGroupInvitation :: DB.Connection -> StoreCxt -> User -> GroupId -> ExceptT St
getGroupInvitation db cxt user groupId =
getConnRec_ user >>= \case
Just connRequest -> do
groupInfo@GroupInfo {membership} <- getGroupInfo db cxt user groupId
GIK groupInfo@GroupInfo {membership} groupKeys <- getGroupInfoKeys db cxt user groupId
when (memberStatus membership /= GSMemInvited) $ throwError SEGroupAlreadyJoined
hostId <- getHostMemberId_ db user groupId
fromMember <- getGroupMember db cxt user groupId hostId
pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo}
pure ReceivedGroupInvitation {fromMember, connRequest, groupInfo, groupKeys}
_ -> throwError SEGroupInvitationNotFound
where
getConnRec_ :: User -> ExceptT StoreError IO (Maybe ConnReqInvitation)
@@ -1695,12 +1696,6 @@ setGroupMemberKeyRole db GroupMember {groupMemberId} pubKey role = do
currentTs <- getCurrentTime
DB.execute db "UPDATE group_members SET member_pub_key = ?, member_role = ?, updated_at = ? WHERE group_member_id = ?" (pubKey, role, currentTs, groupMemberId)
setUserMemberKey :: DB.Connection -> GroupId -> GroupMemberId -> C.PrivateKeyEd25519 -> IO ()
setUserMemberKey db groupId membershipId memberPrivKey = do
currentTs <- getCurrentTime
DB.execute db "UPDATE groups SET member_priv_key = ?, updated_at = ? WHERE group_id = ?" (memberPrivKey, currentTs, groupId)
DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (C.publicKey memberPrivKey, currentTs, membershipId)
setMemberPubKey :: DB.Connection -> GroupMemberId -> C.PublicKeyEd25519 -> IO ()
setMemberPubKey db groupMemberId pubKey = do
currentTs <- getCurrentTime
@@ -1914,13 +1909,13 @@ createRelayRequestGroup db cxt user@User {userId} GroupRelayInvitation {fromMemb
groupPreferences = Nothing,
memberAdmission = Nothing
}
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing Nothing currentTs
(_, memberPrivKey) <- atomically $ C.generateKeyPair (drg cxt)
(groupId, _groupLDN) <- createGroup_ db userId placeholderProfile Nothing Nothing True (Just relayStatus) Nothing (Just memberPrivKey) currentTs
-- Store relay request data for recovery
liftIO $ setRelayRequestData_ groupId currentTs
ownerMemberId <- insertOwner_ currentTs groupId
let relayMember = MemberIdRole relayMemberId GRRelay
-- TODO [member keys] should relays use member keys?
_membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing Nothing currentTs (vr cxt)
_membership <- createContactMemberInv_ db user groupId (Just ownerMemberId) user relayMember GCUserMember memberStatus IBUnknown Nothing (Just $ C.publicKey memberPrivKey) currentTs (vr cxt)
ownerMember <- getGroupMember db cxt user groupId ownerMemberId
g <- getGroupInfo db cxt user groupId
pure (g, ownerMember)
@@ -2015,16 +2010,17 @@ isRelayGroupRejected db User {userId} groupLink =
(userId, groupLink, RSRejected)
)
getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> IO [GroupInfo]
getRelayServedGroups :: DB.Connection -> StoreCxt -> User -> ExceptT StoreError IO [GroupInfoKeys]
getRelayServedGroups db cxt User {userId, userContactId} = do
currentTs <- getCurrentTime
map (toGroupInfo currentTs cxt userContactId [])
currentTs <- liftIO getCurrentTime
rows <- liftIO $ map (toGroupInfo currentTs cxt userContactId [])
<$> DB.query
db
( groupInfoQuery
<> " WHERE g.user_id = ? AND mu.contact_id = ? AND g.relay_own_status IN (?, ?, ?)"
)
(userId, userContactId, RSAccepted, RSAcknowledgedRoster, RSActive)
forM rows $ \(g, keysData) -> GIK g <$> mkGroupKeys db cxt g keysData
getRelayPublishableGroups :: DB.Connection -> User -> IO [(Int64, B64UrlByteString, Maybe PublicGroupAccess)]
getRelayPublishableGroups db User {userId, userContactId} =
@@ -2062,7 +2058,7 @@ getRelayInactiveGroups :: DB.Connection -> StoreCxt -> User -> NominalDiffTime -
getRelayInactiveGroups db cxt User {userId, userContactId} ttl = do
currentTs <- getCurrentTime
let cutoffTs = addUTCTime (- ttl) currentTs
map (toGroupInfo currentTs cxt userContactId [])
map (toGroupInfo_ currentTs cxt userContactId [])
<$> DB.query
db
( groupInfoQuery
@@ -2149,7 +2145,7 @@ createJoiningMemberConnection
Connection {connId} <- createConnection_ db userId ConnMember (Just groupMemberId) agentConnId ConnNew chatV cReqChatVRange Nothing (Just uclId) Nothing 0 createdAt subMode PQSupportOff
setCommandConnId db user cmdId connId
createBusinessRequestGroup :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfo, GroupMember)
createBusinessRequestGroup :: DB.Connection -> StoreCxt -> TVar ChaChaDRG -> User -> VersionRangeChat -> Profile -> Int64 -> Text -> GroupPreferences -> ExceptT StoreError IO (GroupInfoKeys, GroupMember)
createBusinessRequestGroup
db
cxt
@@ -2164,7 +2160,7 @@ createBusinessRequestGroup
(groupId, membership@GroupMember {memberId = userMemberId}) <- insertGroup_ currentTs
(groupMemberId, memberId) <- insertClientMember_ currentTs groupId membership
liftIO $ DB.execute db "UPDATE groups SET business_member_id = ?, customer_member_id = ? WHERE group_id = ?" (userMemberId, memberId, groupId)
groupInfo <- getGroupInfo db cxt user groupId
groupInfo <- getGroupInfoKeys db cxt user groupId
clientMember <- getGroupMemberById db cxt user groupMemberId
pure (groupInfo, clientMember)
where
@@ -2250,14 +2246,14 @@ createMemberConnectionAsync db user@User {userId} groupMemberId (cmdId, agentCon
-- which is used in single-connection flows.
updatePreparedRelayedGroup ::
DB.Connection -> StoreCxt -> User -> GroupInfo -> ConnReqContact -> ConnReqUriHash -> Maybe Profile ->
C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> Maybe Int64 ->
ExceptT StoreError IO GroupInfo
updatePreparedRelayedGroup db cxt user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey memberPrivKey publicMemberCount_ = do
C.PublicKeyEd25519 -> Maybe Int64 ->
ExceptT StoreError IO GroupInfoKeys
updatePreparedRelayedGroup db cxt user@User {userId} gInfo cReq cReqHash incognitoProfile rootPubKey publicMemberCount_ = do
currentTs <- liftIO getCurrentTime
customUserProfileId <- liftIO $ mapM (createIncognitoProfile_ db userId currentTs) incognitoProfile
liftIO $ setPreparedGroupLinkInfo_ db gInfo cReq cReqHash customUserProfileId publicMemberCount_ currentTs
liftIO $ updateGroupMemberKeys db (groupId' gInfo) rootPubKey memberPrivKey (groupMemberId' $ membership gInfo)
getGroupInfo db cxt user (groupId' gInfo)
liftIO $ setGroupRootKey db (groupId' gInfo) rootPubKey
getGroupInfoKeys db cxt user (groupId' gInfo)
updatePublicMemberCount :: DB.Connection -> StoreCxt -> User -> GroupInfo -> ExceptT StoreError IO GroupInfo
updatePublicMemberCount db cxt user GroupInfo {groupId} = do
@@ -2284,23 +2280,15 @@ setPublicMemberCount db cxt user GroupInfo {groupId} publicCount = do
liftIO $ DB.execute db "UPDATE groups SET public_member_count = ?, updated_at = ? WHERE group_id = ?" (publicCount, currentTs, groupId)
getGroupInfo db cxt user groupId
updateGroupMemberKeys :: DB.Connection -> GroupId -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> GroupMemberId -> IO ()
updateGroupMemberKeys db groupId rootPubKey memberPrivKey membershipGMId = do
setGroupRootKey :: DB.Connection -> GroupId -> C.PublicKeyEd25519 -> IO ()
setGroupRootKey db groupId rootPubKey = do
currentTs <- getCurrentTime
DB.execute
db
"UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?"
(rootPubKey, memberPrivKey, currentTs, groupId)
DB.execute
db
"UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?"
(C.publicKey memberPrivKey, currentTs, membershipGMId)
DB.execute db "UPDATE groups SET root_pub_key = ?, updated_at = ? WHERE group_id = ?" (rootPubKey, currentTs, groupId)
updateRelayGroupKeys :: DB.Connection -> User -> GroupInfo -> PublicGroupProfile -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> [OwnerAuth] -> ExceptT StoreError IO ()
updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType, groupLink, publicGroupId} rootPubKey memberPrivKey owners = do
updateRelayGroupKeys :: DB.Connection -> User -> GroupInfo -> PublicGroupProfile -> C.PublicKeyEd25519 -> [OwnerAuth] -> ExceptT StoreError IO ()
updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType, groupLink, publicGroupId} rootPubKey owners = do
currentTs <- liftIO getCurrentTime
let membershipGMId = groupMemberId' $ membership gInfo
groupId = groupId' gInfo
let groupId = groupId' gInfo
liftIO $ do
DB.execute
db
@@ -2309,14 +2297,7 @@ updateRelayGroupKeys db user@User {userId} gInfo PublicGroupProfile {groupType,
WHERE group_profile_id IN (SELECT group_profile_id FROM groups WHERE user_id = ? AND group_id = ?)
|]
(groupType, groupLink, publicGroupId, currentTs, userId, groupId)
DB.execute
db
"UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?"
(rootPubKey, memberPrivKey, currentTs, groupId)
DB.execute
db
"UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?"
(C.publicKey memberPrivKey, currentTs, membershipGMId)
setGroupRootKey db groupId rootPubKey
-- TODO [relays] relay: if not found, create owner record (multi-owner)
forM_ owners $ \OwnerAuth {ownerId, ownerKey} -> do
ownerGMId <- getGroupMemberIdViaMemberId db user gInfo (MemberId ownerId)
src/Simplex/Chat/Store/Postgres/Migrations.hs
+3 -1
View File
@@ -51,6 +51,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20260822_forward_link
import Simplex.Chat.Store.Postgres.Migrations.M20260828_file_expiry
import Simplex.Chat.Store.Postgres.Migrations.M20260904_file_badges
import Simplex.Chat.Store.Postgres.Migrations.M20260915_user_badges
import Simplex.Chat.Store.Postgres.Migrations.M20260918_badge_issue_errors
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Text, Maybe Text)]
@@ -101,7 +102,8 @@ schemaMigrations =
("20260822_forward_link", m20260822_forward_link, Just down_m20260822_forward_link),
("20260828_file_expiry", m20260828_file_expiry, Just down_m20260828_file_expiry),
("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges),
("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges)
("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges),
("20260918_badge_issue_errors", m20260918_badge_issue_errors, Just down_m20260918_badge_issue_errors)
]
-- | The list of migrations in ascending order by date
src/Simplex/Chat/Store/Postgres/Migrations/M20260918_badge_issue_errors.hs
+31
View File
@@ -0,0 +1,31 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.Postgres.Migrations.M20260918_badge_issue_errors where
import Data.Text (Text)
import Text.RawString.QQ (r)
m20260918_badge_issue_errors :: Text
m20260918_badge_issue_errors =
[r|
ALTER TABLE badge_purchases ADD COLUMN issue_failed_since TIMESTAMPTZ;
ALTER TABLE badge_purchases ADD COLUMN issue_error_at TIMESTAMPTZ;
ALTER TABLE badge_purchases ADD COLUMN issue_error TEXT;
ALTER TABLE badge_purchases ADD COLUMN next_wake_at TIMESTAMPTZ;
|]
down_m20260918_badge_issue_errors :: Text
down_m20260918_badge_issue_errors =
[r|
ALTER TABLE badge_purchases DROP COLUMN issue_failed_since;
ALTER TABLE badge_purchases DROP COLUMN issue_error_at;
ALTER TABLE badge_purchases DROP COLUMN issue_error;
ALTER TABLE badge_purchases DROP COLUMN next_wake_at;
|]
src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql
+5 -1
View File
@@ -275,7 +275,11 @@ CREATE TABLE test_chat_schema.badge_purchases (
alert_acked_kind text,
alert_acked_episode text,
alert_snooze_until timestamp with time zone,
badge_code_redemption_id bigint
badge_code_redemption_id bigint,
issue_failed_since timestamp with time zone,
issue_error_at timestamp with time zone,
issue_error text,
next_wake_at timestamp with time zone
);
src/Simplex/Chat/Store/SQLite/Migrations.hs
+3 -1
View File
@@ -174,6 +174,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20260822_forward_link
import Simplex.Chat.Store.SQLite.Migrations.M20260828_file_expiry
import Simplex.Chat.Store.SQLite.Migrations.M20260904_file_badges
import Simplex.Chat.Store.SQLite.Migrations.M20260915_user_badges
import Simplex.Chat.Store.SQLite.Migrations.M20260918_badge_issue_errors
import Simplex.Messaging.Agent.Store.Shared (Migration (..))
schemaMigrations :: [(String, Query, Maybe Query)]
@@ -347,7 +348,8 @@ schemaMigrations =
("20260822_forward_link", m20260822_forward_link, Just down_m20260822_forward_link),
("20260828_file_expiry", m20260828_file_expiry, Just down_m20260828_file_expiry),
("20260904_file_badges", m20260904_file_badges, Just down_m20260904_file_badges),
("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges)
("20260915_user_badges", m20260915_user_badges, Just down_m20260915_user_badges),
("20260918_badge_issue_errors", m20260918_badge_issue_errors, Just down_m20260918_badge_issue_errors)
]
-- | The list of migrations in ascending order by date
src/Simplex/Chat/Store/SQLite/Migrations/M20260918_badge_issue_errors.hs
+30
View File
@@ -0,0 +1,30 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Store.SQLite.Migrations.M20260918_badge_issue_errors where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20260918_badge_issue_errors :: Query
m20260918_badge_issue_errors =
[sql|
ALTER TABLE badge_purchases ADD COLUMN issue_failed_since TEXT;
ALTER TABLE badge_purchases ADD COLUMN issue_error_at TEXT;
ALTER TABLE badge_purchases ADD COLUMN issue_error TEXT;
ALTER TABLE badge_purchases ADD COLUMN next_wake_at TEXT;
|]
down_m20260918_badge_issue_errors :: Query
down_m20260918_badge_issue_errors =
[sql|
ALTER TABLE badge_purchases DROP COLUMN issue_failed_since;
ALTER TABLE badge_purchases DROP COLUMN issue_error_at;
ALTER TABLE badge_purchases DROP COLUMN issue_error;
ALTER TABLE badge_purchases DROP COLUMN next_wake_at;
|]
src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt
+72 -2
View File
@@ -1870,6 +1870,15 @@ Query:
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE groups
SET member_priv_key = COALESCE(member_priv_key, ?), updated_at = ?
WHERE group_id = ?
RETURNING member_priv_key
Plan:
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE groups
SET relay_request_inv_id = ?,
@@ -4024,6 +4033,18 @@ Query:
Plan:
SCAN group_members
Query:
SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type,
l.was_paused_since, l.service_created_at, l.entry_type, l.entry_credit_type, l.entry_debit_type, l.entry_type_value
FROM badge_ledger l
JOIN badge_purchases p ON p.badge_purchase_id = l.badge_purchase_id
WHERE l.badge_purchase_id = ? AND p.user_id = ?
ORDER BY l.entry_id
Plan:
SEARCH p USING COVERING INDEX idx_badge_purchases_user (user_id=? AND rowid=?)
SEARCH l USING INDEX idx_badge_ledger_purchase (badge_purchase_id=?)
Query:
SELECT m.group_member_id
FROM group_members m
@@ -4040,7 +4061,8 @@ SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
Query:
SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type,
(CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END),
p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until
p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until,
p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at
FROM badge_purchases p
JOIN users u ON u.user_id = p.user_id
WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL
@@ -5131,6 +5153,14 @@ SEARCH f USING INTEGER PRIMARY KEY (rowid=?)
SEARCH s USING COVERING INDEX idx_snd_files_file_id (file_id=?) LEFT-JOIN
SEARCH r USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
Query:
UPDATE badge_purchases
SET issue_failed_since = COALESCE(issue_failed_since, ?), issue_error_at = ?, issue_error = ?
WHERE badge_purchase_id = ?
Plan:
SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
Query:
UPDATE chat_items
SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted_ts = ?, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ?
@@ -7555,6 +7585,10 @@ Query: SELECT image FROM contact_profiles WHERE display_name = ? LIMIT 1
Plan:
SEARCH contact_profiles USING INDEX contact_profiles_index (display_name=?)
Query: SELECT issue_failed_since, issue_error FROM badge_purchases
Plan:
SCAN badge_purchases
Query: SELECT last_insert_rowid()
Plan:
SCAN CONSTANT ROW
@@ -7575,10 +7609,22 @@ Query: SELECT member_id FROM group_members WHERE member_role = ? LIMIT 1
Plan:
SCAN group_members
Query: SELECT member_priv_key FROM groups
Plan:
SCAN groups
Query: SELECT member_pub_key FROM group_members WHERE local_display_name = ?
Plan:
SCAN group_members
Query: SELECT member_pub_key FROM group_members WHERE member_category = 'host'
Plan:
SCAN group_members
Query: SELECT member_pub_key FROM group_members WHERE member_category = 'user'
Plan:
SCAN group_members
Query: SELECT member_pub_key FROM group_members WHERE member_role = 'moderator'
Plan:
SCAN group_members
@@ -7679,6 +7725,10 @@ Query: SELECT sent_inv_queue_info FROM group_members WHERE group_member_id = ? A
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
Query: SELECT service_created_at, balance_start_ts FROM badge_ledger ORDER BY entry_id
Plan:
SCAN badge_ledger
Query: SELECT shared_msg_id FROM chat_items WHERE shared_msg_id IS NOT NULL ORDER BY chat_item_id DESC LIMIT 1
Plan:
SCAN chat_items
@@ -7727,6 +7777,14 @@ Query: UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?,
Plan:
SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE badge_purchases SET issue_failed_since = NULL, issue_error_at = NULL, issue_error = NULL WHERE badge_purchase_id = ?
Plan:
SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE badge_purchases SET next_wake_at = ? WHERE badge_purchase_id = ?
Plan:
SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE chat_items SET item_msg_body = ?, item_chat_binding = ?, item_signatures = ?, item_signed_by_group_member_id = ? WHERE chat_item_id = ? AND include_in_history = 1
Plan:
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
@@ -7951,6 +8009,14 @@ Query: UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_m
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE group_members SET member_pub_key = NULL WHERE member_category = 'host'
Plan:
SCAN group_members
Query: UPDATE group_members SET member_pub_key = NULL WHERE member_category = 'user'
Plan:
SCAN group_members
Query: UPDATE group_members SET member_relations_vector = set_member_vector_new_relation(member_relations_vector, ?, ?, ?), updated_at = ? WHERE group_member_id = ?
Plan:
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
@@ -8043,6 +8109,10 @@ Query: UPDATE groups SET local_display_name = ?, updated_at = ? WHERE user_id =
Plan:
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE groups SET member_priv_key = NULL
Plan:
SCAN groups
Query: UPDATE groups SET members_require_attention=1 WHERE group_id=?
Plan:
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
@@ -8063,7 +8133,7 @@ Query: UPDATE groups SET request_shared_msg_id = ? WHERE group_id = ?
Plan:
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
Query: UPDATE groups SET root_pub_key = ?, member_priv_key = ?, updated_at = ? WHERE group_id = ?
Query: UPDATE groups SET root_pub_key = ?, updated_at = ? WHERE group_id = ?
Plan:
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql
+4
View File
@@ -932,6 +932,10 @@ CREATE TABLE badge_purchases(
alert_acked_episode TEXT,
alert_snooze_until TEXT,
badge_code_redemption_id INTEGER REFERENCES badge_code_redemptions,
issue_failed_since TEXT,
issue_error_at TEXT,
issue_error TEXT,
next_wake_at TEXT,
UNIQUE(purchase_key)
) STRICT;
CREATE TABLE badge_ledger(
src/Simplex/Chat/Store/Shared.hs
+46 -11
View File
@@ -694,18 +694,21 @@ type GroupMemberRow = (GroupMemberId, GroupId, Int64, MemberId, VersionChat, Ver
type ProfileRow = (ProfileId, ContactName, Text, Maybe Text, Maybe Text, Maybe ImageData, Maybe ConnLinkContact, Maybe ChatPeerType, LocalAlias, Maybe Preferences) :. BadgeRow :. ContactDomainRow
toGroupInfo :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
toGroupInfo :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> (GroupInfo, GroupKeysRow)
toGroupInfo now cxt userContactId chatTags ((groupId, localDisplayName, displayName, fullName, shortDescr, localAlias, description, image, groupType_, groupLink_, publicGroupId_) :. accessRow :. (enableNtfs_, sendRcpts, BI favorite, groupPreferences, memberAdmission) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. preparedGroupRow :. businessRow :. (BI useRelays, relayOwnStatus, uiThemes, currentMembers, publicMemberCount, rosterVersion, customData, chatItemTTL, membersRequireAttention, viaGroupLinkUri, groupDomainVerified) :. groupKeysRow :. userMemberRow) =
let membership = (toGroupMember now userContactId userMemberRow) {memberChatVRange = vr cxt}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts = unBI <$> sendRcpts, favorite}
fullGroupPreferences = mergeGroupPreferences groupPreferences
publicGroup = toPublicGroupProfile groupType_ groupLink_ publicGroupId_ (toPublicGroupAccess accessRow)
groupKeys = toGroupKeys publicGroupId_ groupKeysRow
groupProfile = GroupProfile {displayName, fullName, shortDescr, description, image, publicGroup, groupPreferences, memberAdmission}
businessChat = toBusinessChatInfo (toPublicGroupAccess accessRow >>= groupDomainClaim) businessRow
preparedGroup = toPreparedGroup preparedGroupRow
groupSummary = GroupSummary {currentMembers, publicMemberCount}
in GroupInfo {groupId, useRelays = BoolDef useRelays, relayOwnStatus, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, preparedGroup, chatTags, chatItemTTL, uiThemes, groupSummary, rosterVersion, customData, membersRequireAttention, viaGroupLinkUri, groupKeys, groupDomainVerified = unBI <$> groupDomainVerified}
gInfo = GroupInfo {groupId, useRelays = BoolDef useRelays, relayOwnStatus, localDisplayName, groupProfile, localAlias, businessChat, fullGroupPreferences, membership, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, preparedGroup, chatTags, chatItemTTL, uiThemes, groupSummary, rosterVersion, customData, membersRequireAttention, viaGroupLinkUri, groupDomainVerified = unBI <$> groupDomainVerified}
in (gInfo, groupKeysRow)
toGroupInfo_ :: UTCTime -> StoreCxt -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
toGroupInfo_ now cxt userContactId chatTags row = fst $ toGroupInfo now cxt userContactId chatTags row
toPreparedGroup :: PreparedGroupRow -> Maybe PreparedGroup
toPreparedGroup = \case
@@ -733,13 +736,35 @@ toPublicGroupAccess (groupWebPage, groupDomain_, domainWebPage_, allowEmbedding_
domainWebPage = maybe False unBI domainWebPage_
allowEmbedding = maybe False unBI allowEmbedding_
toGroupKeys :: Maybe B64UrlByteString -> GroupKeysRow -> Maybe GroupKeys
toGroupKeys publicGroupId_ (rootPrivKey, rootPubKey, memberPrivKey) =
let publicGroupKeys = case (publicGroupId_, GRKPrivate <$> rootPrivKey <|> GRKPublic <$> rootPubKey) of
(Just publicGroupId, Just groupRootKey) -> Just $ Just PublicGroupKeys {publicGroupId, groupRootKey}
(Nothing, Nothing) -> Just Nothing
_ -> Nothing -- invalid state, in which case messages won't be signed even if memberPrivKey is present
in GroupKeys <$> publicGroupKeys <*> memberPrivKey
mkGroupKeys :: DB.Connection -> StoreCxt -> GroupInfo -> GroupKeysRow -> ExceptT StoreError IO GroupKeys
mkGroupKeys db cxt g@GroupInfo {groupId, groupProfile = GroupProfile {publicGroup}, membership} (rootPrivKey, rootPubKey, memberPrivKey_) = do
memberPrivKey <- case memberPrivKey_ of
Just k -> pure k
Nothing -> do
(_, k) <- atomically $ C.generateKeyPair (drg cxt)
setUserMemberKey db groupId (groupMemberId' membership) k
pure $ case (useRelays' g, isJust publicGroup, GRKPrivate <$> rootPrivKey <|> GRKPublic <$> rootPubKey) of
(False, _, _) -> GKGroup {memberPrivKey}
(True, True, Just groupRootKey) -> GKPublicGroup {groupRootKey, memberPrivKey}
(True, True, Nothing) -> GKPreparedPublicGroup {memberPrivKey}
(True, False, _) -> GKRelayRequest {memberPrivKey}
setUserMemberKey :: DB.Connection -> GroupId -> GroupMemberId -> C.PrivateKeyEd25519 -> ExceptT StoreError IO C.PrivateKeyEd25519
setUserMemberKey db groupId membershipId newKey = do
currentTs <- liftIO getCurrentTime
memberPrivKey <-
ExceptT . firstRow fromOnly (SEGroupNotFound groupId) $
DB.query
db
[sql|
UPDATE groups
SET member_priv_key = COALESCE(member_priv_key, ?), updated_at = ?
WHERE group_id = ?
RETURNING member_priv_key
|]
(newKey, currentTs, groupId)
liftIO $ DB.execute db "UPDATE group_members SET member_pub_key = ?, updated_at = ? WHERE group_member_id = ?" (C.publicKey memberPrivKey, currentTs, membershipId)
pure memberPrivKey
toGroupMember :: UTCTime -> Int64 -> GroupMemberRow -> GroupMember
toGroupMember now userContactId ((groupMemberId, groupId, indexInGroup, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, BI showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId) :. profileRow :. (createdAt, updatedAt) :. (supportChatTs_, supportChatUnread, supportChatMemberAttention, supportChatMentions, supportChatLastMsgFromMemberTs, memberPubKey, relayLink, memberCode_, memberCodeVerifiedAt_)) =
@@ -901,8 +926,18 @@ addGroupChatTags db g@GroupInfo {groupId} = do
chatTags <- getGroupChatTags db groupId
pure (g :: GroupInfo) {chatTags}
getGroupInfoKeys :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfoKeys
getGroupInfoKeys db cxt user groupId = do
(g@GroupInfo {membership}, keysData) <- getGroupInfoRow db cxt user groupId
gks <- mkGroupKeys db cxt g keysData
let membership' = membership {memberPubKey = Just $ C.publicKey $ memberPrivKey gks} :: GroupMember
pure $ GIK (g :: GroupInfo) {membership = membership'} gks
getGroupInfo :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO GroupInfo
getGroupInfo db cxt User {userId, userContactId} groupId = ExceptT $ do
getGroupInfo db cxt user groupId = fst <$> getGroupInfoRow db cxt user groupId
getGroupInfoRow :: DB.Connection -> StoreCxt -> User -> Int64 -> ExceptT StoreError IO (GroupInfo, GroupKeysRow)
getGroupInfoRow db cxt User {userId, userContactId} groupId = ExceptT $ do
currentTs <- getCurrentTime
chatTags <- getGroupChatTags db groupId
firstRow (toGroupInfo currentTs cxt userContactId chatTags) (SEGroupNotFound groupId) $
src/Simplex/Chat/Types.hs
+33 -21
View File
@@ -30,7 +30,9 @@
module Simplex.Chat.Types where
import Control.Applicative ((<|>))
import Control.Concurrent.STM (TVar)
import Crypto.Number.Serialize (os2ip)
import Crypto.Random (ChaChaDRG)
import Data.Aeson (FromJSON (..), ToJSON (..))
import qualified Data.Aeson as J
import qualified Data.Aeson.Encoding as JE
@@ -437,7 +439,7 @@ instance ToJSON ConnReqUriHash where
data RequestEntity
= REContact Contact
| REBusinessChat GroupInfo GroupMember
| REBusinessChat GroupInfoKeys GroupMember
type RepeatRequest = Bool
@@ -479,17 +481,30 @@ groupRootPubKey :: GroupRootKey -> C.PublicKeyEd25519
groupRootPubKey (GRKPrivate pk) = C.publicKey pk
groupRootPubKey (GRKPublic pk) = pk
data GroupKeys = GroupKeys
{ publicGroupKeys :: Maybe PublicGroupKeys,
memberPrivKey :: C.PrivateKeyEd25519
}
data GroupKeys
= GKGroup
{ memberPrivKey :: C.PrivateKeyEd25519
}
| GKPublicGroup
{ groupRootKey :: GroupRootKey,
memberPrivKey :: C.PrivateKeyEd25519
}
| GKRelayRequest
{ memberPrivKey :: C.PrivateKeyEd25519
}
| GKPreparedPublicGroup
{ memberPrivKey :: C.PrivateKeyEd25519
}
deriving (Eq, Show)
data PublicGroupKeys = PublicGroupKeys
{ publicGroupId :: B64UrlByteString,
groupRootKey :: GroupRootKey
}
deriving (Eq, Show)
isPublicGroup :: GroupKeys -> Bool
isPublicGroup = \case
GKGroup {} -> False
GKPublicGroup {} -> True
GKRelayRequest {} -> True
GKPreparedPublicGroup {} -> True
data GroupInfoKeys = GIK GroupInfo GroupKeys
data GroupInfo = GroupInfo
{ groupId :: GroupId,
@@ -515,7 +530,6 @@ data GroupInfo = GroupInfo
rosterVersion :: Maybe VersionRoster,
membersRequireAttention :: Int,
viaGroupLinkUri :: Maybe ConnReqContact,
groupKeys :: Maybe GroupKeys,
groupDomainVerified :: Maybe Bool
}
deriving (Eq, Show)
@@ -523,6 +537,9 @@ data GroupInfo = GroupInfo
useRelays' :: GroupInfo -> Bool
useRelays' GroupInfo {useRelays} = isTrue useRelays
publicGroup' :: GroupInfo -> Maybe PublicGroupProfile
publicGroup' g@GroupInfo {groupProfile = GroupProfile {publicGroup}} = if useRelays' g then publicGroup else Nothing
relayServesGroup :: GroupInfo -> Bool
relayServesGroup GroupInfo {relayOwnStatus} = case relayOwnStatus of
Just RSInactive -> False
@@ -595,7 +612,7 @@ data GroupLink = GroupLink
data ContactOrGroup = CGContact Contact | CGGroup GroupInfo [GroupMember]
data PreparedChatEntity = PCEContact Contact | PCEGroup {groupInfo :: GroupInfo, hostMember :: GroupMember}
data PreparedChatEntity = PCEContact Contact | PCEGroup {groupInfo :: GroupInfoKeys, hostMember :: GroupMember}
contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId)
contactAndGroupIds = \case
@@ -1145,7 +1162,8 @@ memberRestrictions m
data ReceivedGroupInvitation = ReceivedGroupInvitation
{ fromMember :: GroupMember,
connRequest :: ConnReqInvitation,
groupInfo :: GroupInfo
groupInfo :: GroupInfo,
groupKeys :: GroupKeys
}
deriving (Eq, Show)
@@ -2240,8 +2258,8 @@ type VersionChat = Version ChatVersion
type VersionRangeChat = VersionRange ChatVersion
-- | Store-wide context passed to store functions in place of the bare `vr`
-- parameter. Built from config by mkStoreCxt; more fields are added here over time.
data StoreCxt = StoreCxt {vr :: VersionRangeChat, badgeKeys :: Map Int BBSPublicKey}
-- parameter. Built from config by storeCxt; more fields are added here over time.
data StoreCxt = StoreCxt {vr :: VersionRangeChat, badgeKeys :: Map Int BBSPublicKey, drg :: TVar ChaChaDRG}
pattern VersionChat :: Word16 -> VersionChat
pattern VersionChat v = Version v
@@ -2347,12 +2365,6 @@ instance FromJSON GroupSummary where
parseJSON = $(JQ.mkParseJSON defaultJSON ''GroupSummary)
omittedField = Just GroupSummary {currentMembers = 0, publicMemberCount = Nothing}
$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "GRK") ''GroupRootKey)
$(JQ.deriveJSON defaultJSON ''PublicGroupKeys)
$(JQ.deriveJSON defaultJSON ''GroupKeys)
$(JQ.deriveJSON defaultJSON ''GroupInfo)
$(JQ.deriveJSON defaultJSON ''Group)
src/Simplex/Chat/View.hs
+26 -3
View File
@@ -44,7 +44,9 @@ import Simplex.Chat.Help
import Simplex.Chat.Library.Commands (badgeServiceErrorText, maxImageSize)
import Simplex.Chat.Markdown
import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeState (..))
import Simplex.Chat.Badges.Ledger (creditTypeTag, debitTypeTag)
import Simplex.Chat.Badges.Service (StatementEntry (..), StatementEntryType (..))
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..))
import Simplex.Chat.Messages hiding (NewChatItem (..))
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Operators
@@ -194,6 +196,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
-- the badge is only shown when it is the one now on the profile; a replayed code's badge may not be
CRBadgeRedeemed u badge newBadge _ -> ttyUser u $ if newBadge then "badge redeemed" : viewContactBadge (Just badge) else ["badge already redeemed"]
CRBadgeState u st -> ttyUser u $ viewUserBadgeState st
CRBadgeLedger u entries -> ttyUser u $ viewBadgeLedger entries
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
@@ -1841,7 +1844,7 @@ viewContactBadge = maybe [] $ \lb ->
viewUserBadgeState :: Maybe BadgeState -> [StyledString]
viewUserBadgeState = maybe [] viewBadge
where
viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert} =
viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert, issueError, nextWakeAt} =
plain
( tshow badgePurchaseId
<> ": "
@@ -1850,15 +1853,35 @@ viewUserBadgeState = maybe [] viewBadge
<> tshow monthsLeft
<> " months left, paid through "
<> day paidThrough
<> maybe "" ((", next check " <>) . dayTime) nextWakeAt
)
: maybe [] viewBadgeAlert alert
: maybe [] viewBadgeIssueError issueError
<> maybe [] viewBadgeAlert alert
viewBadgeIssueError :: BadgeIssueError -> [StyledString]
viewBadgeIssueError BadgeIssueError {failedSince, lastAttemptAt, reason} =
[plain $ "renewal failing since " <> day failedSince <> ", last " <> dayTime lastAttemptAt <> ": " <> safeDecodeUtf8 (strEncode reason)]
viewBadgeAlert :: BadgeAlert -> [StyledString]
viewBadgeAlert BadgeAlert {kind, date} = [plain $ "badge alert: " <> textEncode kind <> " " <> day date]
viewBadgeLedger :: [StatementEntry] -> [StyledString]
viewBadgeLedger [] = ["no ledger entries"]
viewBadgeLedger entries = map viewEntry entries
where
viewEntry StatementEntry {createdAt, entryType, changeMonths, balanceMonths, balanceStartTs} =
plain $ day createdAt <> " " <> entryKind entryType <> " " <> withSign changeMonths <> " -> " <> tshow balanceMonths <> ", from " <> day balanceStartTs
entryKind = \case
SECredit c -> creditTypeTag c
SEDebit d -> debitTypeTag d
withSign n = (if n >= 0 then "+" else "") <> tshow n
day :: UTCTime -> Text
day = T.pack . formatTime defaultTimeLocale "%Y-%m-%d"
dayTime :: UTCTime -> Text
dayTime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M"
viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString]
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink, localBadge, contactDomain, contactDomainVerified, description}, activeConn, uiThemes, customData} stats incognitoProfile =
["contact ID: " <> sShow contactId]
src/Simplex/Chat/Web.hs
+3 -3
View File
@@ -42,7 +42,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Data.Time.Clock (UTCTime, getCurrentTime)
import Simplex.Chat.Controller (ChatController (..), CorsOrigin (..), PublishableGroup (..), WebPreviewConfig (..), WebPreviewState (..), mkStoreCxt)
import Simplex.Chat.Controller (ChatController (..), CorsOrigin (..), PublishableGroup (..), WebPreviewConfig (..), WebPreviewState (..), storeCxt)
import Simplex.Chat.Markdown (FormattedText (..), MarkdownList, parseMaybeMarkdownList)
import Simplex.Chat.Messages
( CChatItem (..),
@@ -137,7 +137,7 @@ webPreviewWorker cfg@WebPreviewConfig {webJsonDir, webCorsFile, webUpdateInterva
seedRoutinePending wps
forever $ workerLoop wps `catchOwn` \e -> logError ("web preview worker error: " <> tshow e)
where
cxt = mkStoreCxt (config cc)
cxt = storeCxt cc
workerLoop wps@WebPreviewState {priorityRender, filesToRemove, corsNeeded, routinePending, wakeSignal} = do
drainRemovals
@@ -262,7 +262,7 @@ renderGroupPreview WebPreviewConfig {webJsonDir, webPreviewItemCount} cc user gI
pure $ corsEntry publicGroupId <$> publicGroupAccess
Nothing -> pure Nothing
where
cxt = mkStoreCxt (config cc)
cxt = storeCxt cc
channelContentChanged :: ChatController -> Int64 -> STM ()
channelContentChanged cc gId =