mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-10-23 00:02:28 +00:00
core: attach badge proofs to files over size limit (#7455)
* core: attach badge proofs to files over size limit * types * more types * implement file badge proofs * tests * move file limits to config, add tests * more tests, work correctly in "send as group" case * fix races in tests * group badge tests * query plans * add history support, fixes * simplify * refactor * refactor * type * restructure schema for proofs * rename, refactor * refactor * fix, refactor * refactor * ui * comments * alerts * update nix, ios library * updare sharing * update simplexmq * update text * improve messages * api types * postgres schema * fix * test * query plans --------- Co-authored-by: Evgeny @ SimpleX Chat <259188159+evgeny-simplex@users.noreply.github.com>
This commit is contained in:
EvgenyandEvgeny @ SimpleX Chat authored and GitHub committed
1 parent
47d32b674a
commit
5ffbe733a8
53 files changed
+1659
-315
No files matched your search
@@ -56,7 +56,7 @@ import Data.Type.Equality
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as V4
|
||||
import Simplex.Chat.Library.Subscriber
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), badgeServerCredential, maxXFTPFileSize, mkBadgeStatus, verifyCredential)
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), LocalBadge (..), badgeServerCredential, maxSndXFTPFileSize, mkBadgeStatus, verifyCredential)
|
||||
import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Controller
|
||||
@@ -3626,7 +3626,7 @@ processChatCommand cxt nm = \case
|
||||
fsFilePath <- lift $ toFSFilePath filePath
|
||||
fileSize <- liftIO $ CF.getFileContentsSize file {filePath = fsFilePath}
|
||||
when (fileSize > toInteger maxFileSizeHard) $ throwChatError $ CEFileSize filePath
|
||||
(_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing
|
||||
(_, _, fileTransferMeta) <- xftpSndFileTransfer_ user file fileSize 1 Nothing Nothing
|
||||
pure CRSndStandaloneFileCreated {user, fileTransferMeta}
|
||||
APIStandaloneFileInfo FileDescriptionURI {clientData} -> pure . CRStandaloneFileInfo $ clientData >>= J.decodeStrict . encodeUtf8
|
||||
APIDownloadStandaloneFile userId uri file -> withUserId userId $ \user -> do
|
||||
@@ -3975,7 +3975,9 @@ processChatCommand cxt nm = \case
|
||||
fsFilePath <- lift $ toFSFilePath f
|
||||
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
|
||||
fileSize <- liftIO $ CF.getFileContentsSize $ CryptoFile fsFilePath cfArgs
|
||||
when (fromInteger fileSize > maxXFTPFileSize sndBadge) $ throwChatError $ CEFileSize f
|
||||
lims <- asks $ fileSizeLimits . config
|
||||
now <- liftIO getCurrentTime
|
||||
when (fileSize > maxSndXFTPFileSize lims now sndBadge) $ throwChatError $ CEFileSize f
|
||||
pure fileSize
|
||||
updateProfile :: User -> Profile -> CM ChatResponse
|
||||
updateProfile user p' = updateProfile_ user p' True $ withFastStore $ \db -> updateUserProfile db user p'
|
||||
@@ -4771,7 +4773,8 @@ processChatCommand cxt nm = \case
|
||||
Just file -> do
|
||||
let User {profile = LocalProfile {localBadge}} = user
|
||||
fileSize <- checkSndFile (if contactConnIncognito ct then Nothing else localBadge) file
|
||||
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 $ CGContact ct
|
||||
binding_ <- ifM ((not (contactConnIncognito ct) &&) <$> fileNeedsBadge fileSize) (directChatBinding ct) (pure Nothing)
|
||||
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize 1 (CGContact ct) binding_
|
||||
pure (Just fInv, Just ciFile)
|
||||
Nothing -> pure (Nothing, Nothing)
|
||||
prepareMsgs :: NonEmpty (ComposedMessageReq, Maybe FileInvitation) -> Maybe CITimed -> CM (NonEmpty (MsgContainer, Maybe (CIQuote 'CTDirect)))
|
||||
@@ -4802,8 +4805,10 @@ processChatCommand cxt nm = \case
|
||||
sendGroupContentMessages user gInfo scope showGroupAsSender live itemTTL sign cmrs = do
|
||||
assertMultiSendable live cmrs
|
||||
chatScopeInfo <- mapM (getChatScopeInfo cxt user) scope
|
||||
recipients <- getGroupRecipients cxt user gInfo chatScopeInfo modsCompatVersion
|
||||
sendGroupContentMessages_ user gInfo scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs
|
||||
-- the member key is created before the send, so that signatures and file badge proofs assert the same key
|
||||
gInfo' <- createUserMemberKey gInfo
|
||||
recipients <- getGroupRecipients cxt user gInfo' chatScopeInfo modsCompatVersion
|
||||
sendGroupContentMessages_ user gInfo' scope showGroupAsSender chatScopeInfo recipients live itemTTL sign cmrs
|
||||
where
|
||||
hasReport = any (\(ComposedMessage {msgContent}, _, _, _) -> isReport msgContent) cmrs
|
||||
modsCompatVersion = if hasReport then contentReportsVersion else groupKnockingVersion
|
||||
@@ -4856,7 +4861,9 @@ processChatCommand cxt nm = \case
|
||||
Just file -> do
|
||||
let User {profile = LocalProfile {localBadge}} = user
|
||||
fileSize <- checkSndFile (if incognitoMembership gInfo then Nothing else localBadge) file
|
||||
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize n $ CGGroup gInfo recipients
|
||||
needsBadge <- fileNeedsBadge fileSize
|
||||
let binding_ = if needsBadge && not (incognitoMembership gInfo) then sndGroupChatBinding gInfo showGroupAsSender else Nothing
|
||||
(fInv, ciFile) <- xftpSndFileTransfer user file fileSize n (CGGroup gInfo recipients) binding_
|
||||
fInv' <-
|
||||
if signMsgs && useRelays' gInfo
|
||||
then (\d -> (fInv :: FileInvitation) {fileDigest = Just d}) <$> cryptoFileDigest file
|
||||
@@ -4914,9 +4921,9 @@ processChatCommand cxt nm = \case
|
||||
-- batching retrieval of quoted messages (prepareMsgs).
|
||||
when (live || length (L.filter (\(ComposedMessage {quotedItemId}, _, _, _) -> isJust quotedItemId) cmrs) > 1) $
|
||||
throwCmdError "invalid multi send: live and more than one quote not supported"
|
||||
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd)
|
||||
xftpSndFileTransfer user file fileSize n contactOrGroup = do
|
||||
(fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n $ Just contactOrGroup
|
||||
xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> Maybe ByteString -> CM (FileInvitation, CIFile 'MDSnd)
|
||||
xftpSndFileTransfer user file fileSize n contactOrGroup binding_ = do
|
||||
(fInv, ciFile, ft) <- xftpSndFileTransfer_ user file fileSize n (Just contactOrGroup) binding_
|
||||
case contactOrGroup of
|
||||
CGContact Contact {activeConn} -> forM_ activeConn $ \conn ->
|
||||
withFastStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft dummyFileDescr
|
||||
@@ -5006,7 +5013,7 @@ processChatCommand cxt nm = \case
|
||||
chunkSize <- asks $ fileChunkSize . config
|
||||
withFastStore' $ \db -> do
|
||||
fileId <- createLocalFile CIFSSndStored db user nf createdAt cf fileSize chunkSize
|
||||
pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal, fileExpires = Nothing}
|
||||
pure CIFile {fileId, fileName = takeFileName filePath, fileSize, fileSource = Just cf, fileStatus = CIFSSndStored, fileProtocol = FPLocal, fileExpires = Nothing, fileProhibited = Nothing}
|
||||
prepareLocalItemsData ::
|
||||
NonEmpty ComposedMessageReq ->
|
||||
NonEmpty (Maybe (CIFile 'MDSnd)) ->
|
||||
|
||||
@@ -53,7 +53,7 @@ import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Time (addUTCTime)
|
||||
import Data.Time.Calendar (fromGregorian)
|
||||
import Data.Time.Clock (UTCTime (..), diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToDiffTime)
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), ProofPresHeader (..), BadgeProof (..), BadgeStatus (..), LocalBadge (..), badgeProof, mkBadgeStatus, verifyBadge)
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), ProofPresHeader (..), BadgeProof (..), BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), LocalBadge (..), badgeProof, badgeSndGraceInterval, generateBadgeProof, localBadgeStatus, maxXFTPFileSize, mkBadgeStatus, verifyBadge)
|
||||
import Simplex.Chat.Names (SimplexDomainClaim (..), claimDomain)
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Controller
|
||||
@@ -98,7 +98,8 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..), CryptoFileArgs (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
||||
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
||||
import Simplex.Messaging.Encoding (smpEncode)
|
||||
import Simplex.Messaging.Crypto.BBS (BBSPresHeader (..))
|
||||
import Simplex.Messaging.Encoding (smpDecode, smpEncode)
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Protocol (MsgBody, MsgFlags (..), ProtoServerWithAuth (..), ProtocolServer, ProtocolTypeI (..), SProtocolType (..), SubscriptionMode (..), UserProtocol, XFTPServer)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
@@ -435,10 +436,11 @@ roundedFDCount n
|
||||
| n <= 0 = 4
|
||||
| otherwise = max 4 $ fromIntegral $ (2 :: Integer) ^ (ceiling (logBase 2 (fromIntegral n) :: Double) :: Integer)
|
||||
|
||||
xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ = do
|
||||
xftpSndFileTransfer_ :: User -> CryptoFile -> Integer -> Int -> Maybe ContactOrGroup -> Maybe ByteString -> CM (FileInvitation, CIFile 'MDSnd, FileTransferMeta)
|
||||
xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup_ binding_ = do
|
||||
fileBadge <- pure binding_ $>>= \chatBinding -> sndBadgeProof user PHFileInv {chatBinding, fileSize = fromInteger fileSize}
|
||||
let fileName = takeFileName filePath
|
||||
fInv = xftpFileInvitation fileName fileSize dummyFileDescr
|
||||
fInv = (xftpFileInvitation fileName fileSize dummyFileDescr :: FileInvitation) {fileBadge}
|
||||
fsFilePath <- lift $ toFSFilePath filePath
|
||||
let srcFile = CryptoFile fsFilePath cfArgs
|
||||
aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) Nothing
|
||||
@@ -446,9 +448,32 @@ xftpSndFileTransfer_ user file@(CryptoFile filePath cfArgs) fileSize n contactOr
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup_ file fInv (AgentSndFileId aFileId) Nothing chSize
|
||||
let fileSource = Just $ CryptoFile filePath cfArgs
|
||||
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP, fileExpires = Nothing}
|
||||
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP, fileExpires = Nothing, fileProhibited = Nothing}
|
||||
pure (fInv, ciFile, ft)
|
||||
|
||||
fileNeedsBadge :: Integer -> CM Bool
|
||||
fileNeedsBadge fileSize = (fileSize >) . noBadge <$> asks (fileSizeLimits . config)
|
||||
|
||||
sndBadgeProof :: User -> ProofPresHeader -> CM (Maybe BadgeProof)
|
||||
sndBadgeProof user = sndBadgeProof_ user . BBSPresHeader . strEncode
|
||||
|
||||
sndBadgeProof_ :: User -> BBSPresHeader -> CM (Maybe BadgeProof)
|
||||
sndBadgeProof_ User {profile = LocalProfile {localBadge}} ph = case localBadge of
|
||||
Just (OwnBadge cred@(BadgeCredential keyIdx _ _ _) _) -> do
|
||||
keys <- asks $ badgePublicKeys . config
|
||||
case M.lookup keyIdx keys of
|
||||
Nothing -> Nothing <$ logError "sndBadgeProof: badge key index not in config"
|
||||
Just key ->
|
||||
liftIO (generateBadgeProof key cred ph) >>= \case
|
||||
Right proof -> pure $ Just proof
|
||||
Left e -> Nothing <$ logError ("sndBadgeProof: proof generation failed: " <> T.pack e)
|
||||
_ -> 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
|
||||
|
||||
cryptoFileDigest :: CryptoFile -> CM FD.FileDigest
|
||||
cryptoFileDigest (CryptoFile filePath cfArgs) = do
|
||||
fsPath <- lift $ toFSFilePath filePath
|
||||
@@ -744,10 +769,11 @@ rctFileCancelled = \case
|
||||
_ -> False
|
||||
|
||||
acceptFileReceive :: User -> RcvFileTransfer -> Bool -> Maybe Bool -> Maybe FilePath -> CM AChatItem
|
||||
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do
|
||||
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileProhibited, fileStatus, grpMemberId, cryptoArgs} userApprovedRelays rcvInline_ filePath_ = do
|
||||
unless (fileStatus == RFSNew) $ case fileStatus of
|
||||
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
|
||||
_ -> throwChatError $ CEFileAlreadyReceiving fName
|
||||
when (isJust fileProhibited) $ throwChatError $ CEFileSize fName
|
||||
cxt <- chatStoreCxt
|
||||
case (xftpRcvFile, fileConnReq) of
|
||||
-- XFTP
|
||||
@@ -1419,15 +1445,17 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
|
||||
resolveAuthor (Just gmId) = do
|
||||
cxt <- chatStoreCxt
|
||||
eitherToMaybe <$> withStore' (\db -> runExceptT $ getGroupMemberById db cxt user gmId)
|
||||
getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime))
|
||||
getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe HistoryFile)
|
||||
getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus, fileExpires} = do
|
||||
expired <- fileExpired fileExpires
|
||||
if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired
|
||||
then pure Nothing
|
||||
else do
|
||||
rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId
|
||||
pure $ invCompleteDescr ciFile rfd
|
||||
getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime))
|
||||
(rfd, (invBadge, descrBadge)) <- withStore $ \db -> do
|
||||
rfd <- getRcvFileDescrByRcvFileId db fileId
|
||||
(rfd,) <$> liftIO (getFileBadgeProofs db fileId)
|
||||
pure $ invCompleteDescr ciFile rfd invBadge descrBadge
|
||||
getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe HistoryFile)
|
||||
getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus, fileExpires} = do
|
||||
expired <- fileExpired fileExpires
|
||||
if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired
|
||||
@@ -1435,28 +1463,54 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
|
||||
else do
|
||||
-- can also lookup in extra_xftp_file_descriptions, though it can be empty;
|
||||
-- would be best if snd file had a single rcv description for all members saved in files table
|
||||
rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId
|
||||
pure $ invCompleteDescr ciFile rfd
|
||||
now <- liftIO getCurrentTime
|
||||
(rfd, (invBadge, descrBadge)) <- withStore $ \db -> do
|
||||
rfd <- getRcvFileDescrBySndFileId db fileId
|
||||
(rfd,) <$> liftIO (getFileBadgeProofs db fileId)
|
||||
-- a signed item forwards the author's original bytes, so its invitation proof cannot be replaced
|
||||
(invBadge', descrBadge') <-
|
||||
if isNothing signedMsg_ && ownBadgeActive && (staleBadge now invBadge || staleBadge now descrBadge)
|
||||
then refreshSndBadges fileId invBadge descrBadge
|
||||
else pure (invBadge, descrBadge)
|
||||
pure $ invCompleteDescr ciFile rfd invBadge' descrBadge'
|
||||
staleBadge :: UTCTime -> Maybe BadgeProof -> Bool
|
||||
staleBadge now = \case
|
||||
Just BadgeProof {badgeInfo = BadgeInfo {badgeExpiry}} -> addUTCTime badgeSndGraceInterval badgeExpiry < now
|
||||
Nothing -> False
|
||||
ownBadgeActive :: Bool
|
||||
ownBadgeActive = maybe False ((BSActive ==) . localBadgeStatus) localBadge
|
||||
where
|
||||
User {profile = LocalProfile {localBadge}} = user
|
||||
-- both proofs are made with the same badge, and are re-made with the current badge over the stored headers
|
||||
refreshSndBadges :: FileTransferId -> Maybe BadgeProof -> Maybe BadgeProof -> CM (Maybe BadgeProof, Maybe BadgeProof)
|
||||
refreshSndBadges fileId invBadge descrBadge = do
|
||||
invBadge' <- mapM reProve invBadge
|
||||
descrBadge' <- mapM reProve descrBadge
|
||||
withStore' $ \db -> do
|
||||
forM_ invBadge' $ createFileBadgeProof db fileId BPKInvitation
|
||||
forM_ descrBadge' $ createFileBadgeProof db fileId BPKDescription
|
||||
pure (invBadge', descrBadge')
|
||||
where
|
||||
reProve badge@BadgeProof {presHeader} = fromMaybe badge <$> sndBadgeProof_ user presHeader
|
||||
fileExpired :: Maybe UTCTime -> CM Bool
|
||||
fileExpired fileExpires = do
|
||||
ttl <- asks $ rcvFilesTTL . agentConfig . config
|
||||
now <- liftIO getCurrentTime
|
||||
pure $ fromMaybe (addUTCTime ttl $ chatItemTs cci) fileExpires < now
|
||||
invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime)
|
||||
invCompleteDescr CIFile {fileName, fileSize, fileExpires} RcvFileDescr {fileDescrText, fileDescrComplete}
|
||||
invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe BadgeProof -> Maybe BadgeProof -> Maybe HistoryFile
|
||||
invCompleteDescr CIFile {fileName, fileSize, fileExpires} RcvFileDescr {fileDescrText, fileDescrComplete} invBadge descrBadge
|
||||
| fileDescrComplete =
|
||||
let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
|
||||
fInv = xftpFileInvitation fileName fileSize fInvDescr
|
||||
in Just (fInv, fileDescrText, fileExpires)
|
||||
let fInv = (xftpFileInvitation fileName fileSize dummyFileDescr :: FileInvitation) {fileBadge = invBadge}
|
||||
in Just (fInv, fileDescrText, fileExpires, descrBadge)
|
||||
| otherwise = Nothing
|
||||
processContentItem :: Maybe GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText, Maybe UTCTime) -> CM [(GrpMsgForward, VerifiedMsg 'Json)]
|
||||
processContentItem :: Maybe GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe HistoryFile -> CM [(GrpMsgForward, VerifiedMsg 'Json)]
|
||||
processContentItem member_ ChatItem {formattedText, meta, quotedItem, mentions} mc fInvDescr_ =
|
||||
if isNothing fInvDescr_ && not (msgContentHasText mc)
|
||||
then pure []
|
||||
else do
|
||||
let CIMeta {itemTs, itemSharedMsgId, itemTimed, showGroupAsSender} = meta
|
||||
quotedItemId_ = quoteItemId =<< quotedItem
|
||||
fInv_ = (\(fInv, _, _) -> fInv) <$> fInvDescr_
|
||||
fInv_ = (\(fInv, _, _, _) -> fInv) <$> fInvDescr_
|
||||
(mc', _, mentions') = updatedMentionNames mc formattedText mentions
|
||||
mentions'' = M.map (\CIMention {memberId} -> MsgMention {memberId}) mentions'
|
||||
-- for channel messages default chat version range to membership range
|
||||
@@ -1475,10 +1529,10 @@ sendHistory user gInfo@GroupInfo {membership} m@GroupMember {activeConn = Just c
|
||||
(chatMsgEvent, _) <- withStore $ \db -> prepareGroupMsg db user gInfo Nothing showGroupAsSender mc' mentions'' quotedItemId_ Nothing fInv_ itemTimed False
|
||||
pure $ VMUnsigned ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent}
|
||||
fileDescrEvents <- case (fInvDescr_, itemSharedMsgId) of
|
||||
(Just (_, fileDescrText, fileExpires), Just msgId) -> do
|
||||
(Just (_, fileDescrText, fileExpires, descrBadge), Just msgId) -> do
|
||||
partSize <- asks $ xftpDescrPartSize . config
|
||||
let parts = splitFileDescr partSize fileDescrText
|
||||
pure . L.toList $ L.map (\fd -> XMsgFileDescr msgId fd fileExpires) parts
|
||||
let parts = splitFileDescr partSize (maybe partSize (const badgeDescrPartSize) descrBadge) fileDescrText
|
||||
pure . L.toList $ L.map (\fd@FileDescr {fileDescrComplete} -> XMsgFileDescr msgId fd fileExpires (if fileDescrComplete then descrBadge else Nothing)) parts
|
||||
_ -> pure []
|
||||
let fileDescrVMs = map (VMUnsigned . ChatMessage senderVRange Nothing) fileDescrEvents
|
||||
pure $ map ((,) fwd) (contentVM : fileDescrVMs)
|
||||
@@ -1488,11 +1542,16 @@ memberShortenedName GroupMember {memberProfile = LocalProfile {displayName}}
|
||||
| T.length displayName <= 16 = displayName
|
||||
| otherwise = T.take 16 displayName `T.snoc` '…'
|
||||
|
||||
splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr
|
||||
splitFileDescr partSize rfdText = splitParts 1 rfdText
|
||||
-- the description proof travels on the last part, so that part leaves room for it
|
||||
badgeDescrPartSize :: Int
|
||||
badgeDescrPartSize = 13500
|
||||
|
||||
splitFileDescr :: Int -> Int -> RcvFileDescrText -> NonEmpty FileDescr
|
||||
splitFileDescr partSize lastSize rfdText = splitParts 1 rfdText
|
||||
where
|
||||
splitParts partNo remText =
|
||||
let (part, rest) = T.splitAt partSize remText
|
||||
let n = T.length remText
|
||||
(part, rest) = T.splitAt (if n <= lastSize then n else if n <= partSize then lastSize else partSize) remText
|
||||
complete = T.null rest
|
||||
fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete}
|
||||
in if complete
|
||||
@@ -2263,6 +2322,71 @@ groupBindingData gks memberId memberKey = case gks >>= publicGroupKeys of
|
||||
Just PublicGroupKeys {publicGroupId} -> smpEncode (publicGroupId, memberId)
|
||||
Nothing -> smpEncode (memberId, memberKey)
|
||||
|
||||
type HistoryFile = (FileInvitation, RcvFileDescrText, Maybe UTCTime, Maybe BadgeProof)
|
||||
|
||||
directChatBinding :: Contact -> CM (Maybe ByteString)
|
||||
directChatBinding ct =
|
||||
forM (contactConn ct) $ \conn ->
|
||||
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, _) ->
|
||||
Just $ encodeChatBinding CBChannel $ smpEncode publicGroupId
|
||||
(Just PublicGroupKeys {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_)
|
||||
_ -> Nothing
|
||||
|
||||
proofMemberKey :: MemberId -> Maybe BadgeProof -> Maybe C.PublicKeyEd25519
|
||||
proofMemberKey memberId badge_ = do
|
||||
BadgeProof _ (BBSPresHeader phBytes) _ _ <- badge_
|
||||
binding <- headerChatBinding =<< eitherToMaybe (strDecode phBytes)
|
||||
d <- B.stripPrefix (smpEncode CBGroup) binding
|
||||
(mId, k) <- eitherToMaybe (smpDecode d :: Either String (MemberId, C.PublicKeyEd25519))
|
||||
if mId == memberId then Just k else Nothing
|
||||
where
|
||||
headerChatBinding = \case
|
||||
PHFileInv {chatBinding} -> Just chatBinding
|
||||
PHFileDescr {chatBinding} -> Just chatBinding
|
||||
_ -> Nothing
|
||||
|
||||
badgeProofStatus :: Maybe ProofPresHeader -> BadgeProof -> CM BadgeStatus
|
||||
badgeProofStatus expected_ badge@BadgeProof {presHeader = BBSPresHeader phBytes, badgeInfo} =
|
||||
case expected_ of
|
||||
Just expected | phBytes == strEncode expected -> do
|
||||
keys <- asks $ badgePublicKeys . config
|
||||
verified <- liftIO $ verifyBadge keys badge
|
||||
now <- liftIO getCurrentTime
|
||||
pure $ mkBadgeStatus now verified badgeInfo
|
||||
_ -> pure BSFailed
|
||||
|
||||
rcvDirectFileProhibited :: Contact -> FileInvitation -> CM (Maybe FileProhibited)
|
||||
rcvDirectFileProhibited ct fInv@FileInvitation {fileBadge} = do
|
||||
binding_ <- if isJust fileBadge then directChatBinding ct else pure Nothing
|
||||
rcvFileProhibited binding_ fInv
|
||||
|
||||
rcvGroupFileProhibited :: GroupInfo -> Maybe GroupMember -> ShowGroupAsSender -> FileInvitation -> CM (Maybe FileProhibited)
|
||||
rcvGroupFileProhibited gInfo m_ asGroup fInv@FileInvitation {fileBadge} =
|
||||
rcvFileProhibited (rcvGroupChatBinding gInfo m_ asGroup fileBadge) fInv
|
||||
|
||||
rcvFileProhibited :: Maybe ByteString -> FileInvitation -> CM (Maybe FileProhibited)
|
||||
rcvFileProhibited binding_ FileInvitation {fileSize, fileBadge} = do
|
||||
lims <- asks $ fileSizeLimits . config
|
||||
if fileSize <= noBadge lims
|
||||
then pure Nothing
|
||||
else case fileBadge of
|
||||
Nothing -> pure $ Just FileProhibited {maxSize = noBadge lims, badgeStatus = Nothing}
|
||||
Just badge -> do
|
||||
st <- badgeProofStatus ((\chatBinding -> PHFileInv {chatBinding, fileSize = fromInteger fileSize}) <$> binding_) badge
|
||||
let maxSize = maxXFTPFileSize lims $ Just $ PeerBadge badge st
|
||||
pure $
|
||||
if fileSize <= maxSize
|
||||
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
|
||||
|
||||
@@ -46,6 +46,7 @@ import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as V4
|
||||
import Data.Word (Word32)
|
||||
import Simplex.Chat.Badges (BadgeProof, BadgeProofKind (..), BadgeStatus (..), FileSizeLimits (..), ProofPresHeader (..))
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Delivery
|
||||
@@ -76,7 +77,7 @@ import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Shared
|
||||
import Simplex.FileTransfer.Description (ValidFileDescription)
|
||||
import qualified Simplex.FileTransfer.Description as FD
|
||||
import Simplex.FileTransfer.Protocol (FilePartyI, GrantedStorageTime (..))
|
||||
import Simplex.FileTransfer.Protocol (FileParty (..), FilePartyI, GrantedStorageTime (..))
|
||||
import qualified Simplex.FileTransfer.Transport as XFTP
|
||||
import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId)
|
||||
import Simplex.Messaging.Agent
|
||||
@@ -224,7 +225,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
-- we have 1 chunk - use it as URI whether it is redirect or not
|
||||
ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor
|
||||
toView $ CEvtSndStandaloneFileComplete user ft' $ map (decodeLatin1 . strEncode . FD.fileDescriptionURI) rfds'
|
||||
Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) ->
|
||||
Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted, showGroupAsSender}}) ->
|
||||
case (msgId_, itemDeleted) of
|
||||
(Just sharedMsgId, Nothing) -> do
|
||||
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
|
||||
@@ -232,9 +233,16 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
toView $ CEvtSndFileProgressXFTP user ci ft 1 1
|
||||
case (rfds, sfts, d, cInfo) of
|
||||
(rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do
|
||||
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
|
||||
conn@Connection {connId} <- liftEither $ contactSendConn_ ct
|
||||
sendFileDescriptions (ConnectionId connId) ((conn, sft, fileDescrText rfd) :| []) sharedMsgId fileExpires >>= \case
|
||||
let FileTransferMeta {fileSize} = ft
|
||||
binding_ <- ifM ((not (contactConnIncognito ct) &&) <$> fileNeedsBadge fileSize) (directChatBinding ct) (pure Nothing)
|
||||
descrBadge <- pure binding_ $>>= \chatBinding ->
|
||||
let FD.ValidFileDescription fd = sndDescr
|
||||
in sndBadgeProof user PHFileDescr {chatBinding, fileSize = fromInteger fileSize, descrHash = FD.sharedDescriptionHash fd, fileExpires}
|
||||
withStore' $ \db -> do
|
||||
createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
|
||||
forM_ descrBadge $ createFileBadgeProof db fileId BPKDescription
|
||||
sendFileDescriptions (ConnectionId connId) ((conn, sft, fileDescrText rfd) :| []) sharedMsgId fileExpires descrBadge >>= \case
|
||||
Just rs -> case L.last rs of
|
||||
Right ([msgDeliveryId], _) ->
|
||||
withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId
|
||||
@@ -247,9 +255,17 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
ms <- getRecipients
|
||||
let rfdsMemberFTs = zipWith (\rfd (conn, sft) -> (conn, sft, fileDescrText rfd)) rfds (memberFTs ms)
|
||||
extraRFDs = drop (length rfdsMemberFTs) rfds
|
||||
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
|
||||
FileTransferMeta {fileSize} = ft
|
||||
needsBadge <- fileNeedsBadge fileSize
|
||||
let binding_ = if needsBadge && not (incognitoMembership g) then sndGroupChatBinding g showGroupAsSender else Nothing
|
||||
descrBadge <- pure binding_ $>>= \chatBinding ->
|
||||
let FD.ValidFileDescription fd = sndDescr
|
||||
in sndBadgeProof user PHFileDescr {chatBinding, fileSize = fromInteger fileSize, descrHash = FD.sharedDescriptionHash fd, fileExpires}
|
||||
withStore' $ \db -> do
|
||||
createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
|
||||
forM_ descrBadge $ createFileBadgeProof db fileId BPKDescription
|
||||
forM_ (L.nonEmpty rfdsMemberFTs) $ \rfdsMemberFTs' ->
|
||||
sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId fileExpires
|
||||
sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId fileExpires descrBadge
|
||||
ci' <- withStore $ \db -> do
|
||||
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
|
||||
getChatItemByFileId db cxt user fileId
|
||||
@@ -278,8 +294,8 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
where
|
||||
fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
|
||||
fileDescrText = safeDecodeUtf8 . strEncode
|
||||
sendFileDescriptions :: ConnOrGroupId -> NonEmpty (Connection, SndFileTransfer, RcvFileDescrText) -> SharedMsgId -> Maybe UTCTime -> CM (Maybe (NonEmpty (Either ChatError ([Int64], PQEncryption))))
|
||||
sendFileDescriptions connOrGroupId connsTransfersDescrs sharedMsgId fileExpires = do
|
||||
sendFileDescriptions :: ConnOrGroupId -> NonEmpty (Connection, SndFileTransfer, RcvFileDescrText) -> SharedMsgId -> Maybe UTCTime -> Maybe BadgeProof -> CM (Maybe (NonEmpty (Either ChatError ([Int64], PQEncryption))))
|
||||
sendFileDescriptions connOrGroupId connsTransfersDescrs sharedMsgId fileExpires descrBadge = do
|
||||
lift . void . withStoreBatch' $ \db -> L.map (\(_, sft, rfdText) -> updateSndFTDescrXFTP db user sft rfdText) connsTransfersDescrs
|
||||
partSize <- asks $ xftpDescrPartSize . config
|
||||
let connsIdsEvts = connDescrEvents partSize
|
||||
@@ -295,7 +311,7 @@ processAgentMsgSndFile _corrId aFileId msg = do
|
||||
where
|
||||
splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json))]
|
||||
splitText (conn, _, rfdText) =
|
||||
map (\fileDescr -> (conn, (connOrGroupId, Nothing, XMsgFileDescr {msgId = sharedMsgId, fileDescr, fileExpires}))) (L.toList $ splitFileDescr partSize rfdText)
|
||||
map (\fileDescr@FileDescr {fileDescrComplete} -> (conn, (connOrGroupId, Nothing, XMsgFileDescr {msgId = sharedMsgId, fileDescr, fileExpires, fileBadge = if fileDescrComplete then descrBadge else Nothing}))) (L.toList $ splitFileDescr partSize (maybe partSize (const badgeDescrPartSize) descrBadge) rfdText)
|
||||
toMsgReq :: (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq
|
||||
toMsgReq (conn, _) SndMessage {msgId, msgBody} =
|
||||
(conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, (vrValue msgBody, [msgId]))
|
||||
@@ -550,7 +566,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
let ct'' = ct' {activeConn = Just conn''} :: Contact
|
||||
case event of
|
||||
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
|
||||
XMsgFileDescr sharedMsgId fileDescr fileExpires -> messageFileDescription ct'' sharedMsgId fileDescr fileExpires
|
||||
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> messageFileDescription ct'' sharedMsgId fileDescr fileExpires fileBadge
|
||||
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope _ -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
|
||||
XMsgDel sharedMsgId _ _ _ -> messageDelete ct'' sharedMsgId msg msgMeta
|
||||
XMsgReact sharedMsgId _ _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
|
||||
@@ -1040,7 +1056,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
where
|
||||
MsgContainer {scope, asGroup} = mc
|
||||
-- file description is always allowed, to allow sending files to support scope
|
||||
XMsgFileDescr sharedMsgId fileDescr fileExpires -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr fileExpires
|
||||
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr fileExpires fileBadge
|
||||
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
|
||||
checkSendAsGroup asGroup_ $
|
||||
memberCanSend (Just m'') msgScope $
|
||||
@@ -1896,7 +1912,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
let MsgContainer {ttl = itemTTL, live = live_} = mc
|
||||
timed_ = rcvContactCITimed ct itemTTL
|
||||
live = fromMaybe False live_
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
|
||||
file_ <- processFileInvitation fInv_ content (rcvDirectFileProhibited ct) $ \db -> createRcvFileTransfer db userId ct
|
||||
newChatItem (CIRcvMsgContent content, msgContentTexts content) (snd <$> file_) timed_ live
|
||||
autoAcceptFile file_
|
||||
where
|
||||
@@ -1912,36 +1928,37 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
ChatConfig {autoAcceptFileSize = sz} <- asks config
|
||||
when (sz > fileSize) $ receiveFileEvt' user ft False Nothing Nothing >>= toView
|
||||
|
||||
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> Maybe UTCTime -> CM ()
|
||||
messageFileDescription Contact {contactId} sharedMsgId fileDescr fileExpires = do
|
||||
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> CM ()
|
||||
messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr fileExpires fileBadge = do
|
||||
(fileId, aci) <- withStore $ \db -> do
|
||||
fileId <- getFileIdBySharedMsgId db userId contactId sharedMsgId
|
||||
aci <- getChatItemByFileId db cxt user fileId
|
||||
pure (fileId, aci)
|
||||
processFDMessage fileId aci fileDescr fileExpires
|
||||
binding_ <- if isJust fileBadge then directChatBinding ct else pure Nothing
|
||||
processFDMessage binding_ fileId aci fileDescr fileExpires fileBadge
|
||||
|
||||
groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> Maybe UTCTime -> CM (Maybe DeliveryTaskContext)
|
||||
groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr fileExpires = do
|
||||
groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> CM (Maybe DeliveryTaskContext)
|
||||
groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr fileExpires fileBadge = do
|
||||
(fileId, aci) <- withStore $ \db -> do
|
||||
fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
||||
aci <- getChatItemByFileId db cxt user fileId
|
||||
pure (fileId, aci)
|
||||
case aci of
|
||||
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir}
|
||||
AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir, meta = CIMeta {showGroupAsSender}}
|
||||
| validSender m_ chatDir -> do
|
||||
-- in processFDMessage some paths are programmed as errors,
|
||||
-- for example failure on not approved relays (CEFileNotApproved).
|
||||
-- we catch error, so that even if processFDMessage fails, message can still be forwarded.
|
||||
processFDMessage fileId aci fileDescr fileExpires `catchAllErrors` \_ -> pure ()
|
||||
processFDMessage (rcvGroupChatBinding g m_ showGroupAsSender fileBadge) fileId aci fileDescr fileExpires fileBadge `catchAllErrors` \_ -> pure ()
|
||||
pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir)
|
||||
| otherwise -> messageError "x.msg.file.descr: file/sender mismatch" $> Nothing
|
||||
_ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing
|
||||
|
||||
processFDMessage :: FileTransferId -> AChatItem -> FileDescr -> Maybe UTCTime -> CM ()
|
||||
processFDMessage fileId aci fileDescr fileExpires = do
|
||||
processFDMessage :: Maybe ByteString -> FileTransferId -> AChatItem -> FileDescr -> Maybe UTCTime -> Maybe BadgeProof -> CM ()
|
||||
processFDMessage binding_ fileId aci fileDescr fileExpires fileBadge = do
|
||||
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
(rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs, fileInvitation = FileInvitation {fileSize}}) <- withStore $ \db -> do
|
||||
(rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs, fileProhibited, fileInvitation = FileInvitation {fileSize}}) <- withStore $ \db -> do
|
||||
rfd <- appendRcvFD db userId fileId fileDescr
|
||||
forM_ fileExpires $ liftIO . setFileExpiration db user fileId
|
||||
-- reading second time in the same transaction as appending description
|
||||
@@ -1949,16 +1966,41 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
ft' <- getRcvFileTransfer db user fileId
|
||||
pure (rfd, ft')
|
||||
when fileDescrComplete $ toView $ CEvtRcvFileDescrReady user aci ft' rfd
|
||||
case (fileStatus, xftpRcvFile) of
|
||||
(RFSAccepted _, Just XFTPRcvFile {userApprovedRelays}) -> receiveViaCompleteFD user fileId rfd fileSize userApprovedRelays cryptoArgs
|
||||
_ -> pure ()
|
||||
maxSize <- asks $ noBadge . fileSizeLimits . config
|
||||
let descrBadgeRequired = fileDescrComplete && fileSize > maxSize && isNothing fileProhibited
|
||||
prohibited_ <- case fileBadge of
|
||||
_ | not descrBadgeRequired -> pure Nothing
|
||||
Nothing -> pure $ Just FileProhibited {maxSize, badgeStatus = Nothing}
|
||||
Just badge -> do
|
||||
st <- descrBadgeStatus binding_ fileSize rfd fileExpires badge
|
||||
if st == BSActive
|
||||
then do
|
||||
withStore' $ \db -> createFileBadgeProof db fileId BPKDescription badge
|
||||
pure Nothing
|
||||
else pure $ Just FileProhibited {maxSize, badgeStatus = Just st}
|
||||
case prohibited_ of
|
||||
Nothing -> case (fileStatus, xftpRcvFile) of
|
||||
(RFSAccepted _, Just XFTPRcvFile {userApprovedRelays}) -> receiveViaCompleteFD user fileId rfd fileSize userApprovedRelays cryptoArgs
|
||||
_ -> pure ()
|
||||
-- the file may already be accepted, so it is reset to an invitation the apps refuse by its prohibition
|
||||
Just prohibited -> do
|
||||
withStore' $ \db -> setFileProhibited db user fileId prohibited
|
||||
aci_ <- resetRcvCIFileStatus user fileId CIFSRcvInvitation
|
||||
forM_ aci_ $ \aci' -> toView $ CEvtChatItemUpdated user aci'
|
||||
|
||||
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
|
||||
processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv -> do
|
||||
descrBadgeStatus :: Maybe ByteString -> Integer -> RcvFileDescr -> Maybe UTCTime -> BadgeProof -> CM BadgeStatus
|
||||
descrBadgeStatus binding_ fileSize RcvFileDescr {fileDescrText} fileExpires badge = do
|
||||
FD.ValidFileDescription fd <- parseFileDescription @'FRecipient fileDescrText
|
||||
let descrHash = FD.sharedDescriptionHash fd
|
||||
badgeProofStatus ((\chatBinding -> PHFileDescr {chatBinding, fileSize = fromInteger fileSize, descrHash, fileExpires}) <$> binding_) badge
|
||||
|
||||
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (FileInvitation -> CM (Maybe FileProhibited)) -> (DB.Connection -> FileInvitation -> Maybe FileProhibited -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
|
||||
processFileInvitation fInv_ mc fileProhibited_ createRcvFT = forM fInv_ $ \fInv -> do
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv
|
||||
fileProhibited <- fileProhibited_ fInv'
|
||||
inline <- receiveInlineMode fInv' (Just mc) fileChunkSize
|
||||
ft@RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFT db fInv' inline fileChunkSize
|
||||
ft@RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFT db fInv' fileProhibited inline fileChunkSize
|
||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||
(filePath, fileStatus, ft') <- case inline of
|
||||
Just IFMSent -> do
|
||||
@@ -1970,15 +2012,19 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
_ -> pure (Nothing, CIFSRcvInvitation, ft)
|
||||
let RcvFileTransfer {cryptoArgs} = ft'
|
||||
fileSource = (`CryptoFile` cryptoArgs) <$> filePath
|
||||
pure (ft', CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires = Nothing})
|
||||
pure (ft', CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol, fileExpires = Nothing, fileProhibited})
|
||||
|
||||
mkValidFileInvitation :: FileInvitation -> FileInvitation
|
||||
mkValidFileInvitation fInv@FileInvitation {fileName} = fInv {fileName = safeFileNameStr fileName}
|
||||
|
||||
validateFileInvitation :: FileInvitation -> CM FileInvitation
|
||||
validateFileInvitation fInv@FileInvitation {fileName, fileSize}
|
||||
| fileSize > 0 = pure $ mkValidFileInvitation fInv
|
||||
| otherwise = throwChatError $ CEFileSize fileName
|
||||
validateFileInvitation fInv@FileInvitation {fileName, fileSize, fileDescr}
|
||||
| fileSize <= 0 = throwChatError $ CEFileSize fileName
|
||||
| otherwise = do
|
||||
-- a file that requires a badge is received from the description message, where the proof binds the description
|
||||
needsBadge <- fileNeedsBadge fileSize
|
||||
let fileDescr' = if needsBadge then dummyFileDescr <$ fileDescr else fileDescr
|
||||
pure $ mkValidFileInvitation fInv {fileDescr = fileDescr'}
|
||||
|
||||
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> CM ()
|
||||
messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
|
||||
@@ -2201,7 +2247,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
unless (maybe False memberBlocked m') $ autoAcceptFile file_
|
||||
processFileInv gInfo' m' =
|
||||
let fileMember_ = if sentAsGroup then Nothing else m'
|
||||
in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_ FTNormal sharedMsgId_
|
||||
in processFileInvitation fInv_ content (rcvGroupFileProhibited gInfo' m' sentAsGroup) $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_ FTNormal sharedMsgId_
|
||||
newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed live = do
|
||||
let mentions' = if maybe False memberBlocked m' then M.empty else mentions
|
||||
(ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed live mentions'
|
||||
@@ -2423,10 +2469,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
processFileInvitation' ct fInv msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv
|
||||
fileProhibited <- rcvDirectFileProhibited ct fInv'
|
||||
inline <- receiveInlineMode fInv' Nothing fileChunkSize
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv' inline fileChunkSize
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv' fileProhibited inline fileChunkSize
|
||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing}
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing, fileProhibited}
|
||||
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
||||
toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci]
|
||||
@@ -2438,10 +2485,11 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
processGroupFileInvitation' gInfo m fInv msg@RcvMessage {sharedMsgId_} brokerTs = do
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
fInv'@FileInvitation {fileName, fileSize} <- validateFileInvitation fInv
|
||||
fileProhibited <- rcvGroupFileProhibited gInfo (Just m) False fInv'
|
||||
inline <- receiveInlineMode fInv' Nothing fileChunkSize
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) FTNormal sharedMsgId_ fInv' inline fileChunkSize
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId gInfo (Just m) FTNormal sharedMsgId_ fInv' fileProhibited inline fileChunkSize
|
||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing}
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol, fileExpires = Nothing, fileProhibited}
|
||||
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
|
||||
(ci, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
||||
ci' <- blockedMemberCI gInfo m ci
|
||||
@@ -3410,7 +3458,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
cleanupRosterTransfer gInfo (groupMemberId' fromMember)
|
||||
let relayHdr = if isUserGrpFwdRelay gInfo then Just sm else Nothing
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
let rosterFInv = FileInvitation {fileName = "roster", fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Just IFMSent, fileDescr = Nothing}
|
||||
let rosterFInv = FileInvitation {fileName = "roster", fileSize, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Just IFMSent, fileDescr = Nothing, fileBadge = Nothing}
|
||||
-- transfer record + its scratch file in one transaction (file owned by the transfer, keyed per source)
|
||||
rft@RcvFileTransfer {fileId} <- withStore $ \db -> do
|
||||
transferId <- liftIO $ createRosterTransfer db gInfo (groupMemberId' fromMember) newVer fileDigest (groupMemberId' author) brokerTs relayHdr
|
||||
@@ -3899,7 +3947,7 @@ processAgentMessageConn cxt user@User {userId} corrId agentConnId agentMessage =
|
||||
where
|
||||
MsgContainer {scope} = mc
|
||||
-- file description is always allowed, to allow sending files to support scope
|
||||
XMsgFileDescr sharedMsgId fileDescr fileExpires -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires
|
||||
XMsgFileDescr sharedMsgId fileDescr fileExpires fileBadge -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr fileExpires fileBadge
|
||||
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ ->
|
||||
void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_
|
||||
XMsgDel sharedMsgId memId scope_ _ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ False rcvMsg msgTs
|
||||
|
||||
Reference in new issue
Block a user