android-apps-mirrors/SimpleX-Chat
0
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2025-06-28 20:29:53 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

core: support inline file transfers (#1187)

Browse source 
* core: support inline file transfers

* parameterize ChatMessage

* send files inline when accepted

* accept inline file transfers (almost works)

* db error SERcvFileInvalid

* inline file transfer works (TODO fix test)

* inline file transfer tests, change encodings

* fixture

* combine messages into x.file.acpt.inv, refactor

* inline file mode

* decide whether to receive file inline on the recipient side, not only via file invitation

* test inline files "sent" mode

* check that file was offered inline

* update schema

* enable encryption tests

* test name

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>

* fix the list of rcv files to subscribe too

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2022-10-14 13:06:33 +01:00 • committed by GitHub
parent f7da034cf1
commit fb03a119ea
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
14 changed files with 1341 additions and 814 deletions
Download patch file Download diff file Expand all files Collapse all files

1
simplex-chat.cabal
View file

@ -55,6 +55,7 @@ library
Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items
Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id
Simplex.Chat.Migrations.M20221011_user_contact_links_group_id
Simplex.Chat.Migrations.M20221012_inline_files
Simplex.Chat.Mobile
Simplex.Chat.Options
Simplex.Chat.ProfileGenerator

419
src/Simplex/Chat.hs
View file

@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
@ -22,7 +23,7 @@ import Crypto.Random (drgNew)
import qualified Data.Aeson as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.Bifunctor (bimap, first)
import qualified Data.ByteString.Base64 as B64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
@ -43,7 +44,6 @@ import Data.Time (NominalDiffTime, addUTCTime)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
import Data.Time.Clock.System (SystemTime, systemToUTCTime)
import Data.Time.LocalTime (getCurrentTimeZone, getZonedTime)
import Data.Word (Word32)
import qualified Database.SQLite.Simple as DB
import Simplex.Chat.Archive
import Simplex.Chat.Call
@ -98,7 +98,8 @@ defaultChatConfig =
netCfg = defaultNetworkConfig
},
tbqSize = 64,
fileChunkSize = 15780,
fileChunkSize = 15780, -- do not change
inlineFiles = defaultInlineFilesConfig,
subscriptionConcurrency = 16,
subscriptionEvents = False,
hostEvents = False,
@ -282,31 +283,33 @@ processChatCommand = \case
APISendMessage (ChatRef cType chatId) (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock $ case cType of
CTDirect -> do
ct@Contact {localDisplayName = c} <- withStore $ \db -> getContact db userId chatId
(fileInvitation_, ciFile_) <- unzipMaybe <$> setupSndFileTransfer ct
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer ct
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_
msg <- sendDirectContactMessage ct (XMsgNew msgContainer)
(msg@SndMessage {sharedMsgId}, _) <- sendDirectContactMessage ct (XMsgNew msgContainer)
case ft_ of
Just ft@FileTransferMeta {fileInline = Just IFMSent} ->
sendDirectFileInline ct ft sharedMsgId
_ -> pure ()
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_
setActive $ ActiveC c
pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
where
-- This method creates file invitation without connection request - it has to be accepted with x.acpt.file.inv message sent back to the contact
-- setupSndFileTransfer' :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd))
-- setupSndFileTransfer' ct = forM file_ $ \file -> do
-- (fileSize, chSize) <- checkSndFile file
-- let fileName = takeFileName file
-- fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing}
-- fileId <- withStore' $ \db -> createSndDirectFileTransfer db userId ct file fileInvitation chSize
-- let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
-- pure (fileInvitation, ciFile)
setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd))
setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
setupSndFileTransfer ct = forM file_ $ \file -> do
(fileSize, chSize) <- checkSndFile file
(agentConnId, fileConnReq) <- withAgent $ \a -> createConnection a True SCMInvitation
(fileSize, chSize, fileInline) <- checkSndFile file 1
(agentConnId_, fileConnReq) <-
if isJust fileInline
then pure (Nothing, Nothing)
else bimap Just Just <$> withAgent (\a -> createConnection a True SCMInvitation)
let fileName = takeFileName file
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Just fileConnReq}
fileId <- withStore' $ \db -> createSndFileTransfer db userId ct file fileInvitation agentConnId chSize
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
pure (fileInvitation, ciFile)
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq, fileInline}
withStore' $ \db -> do
ft@FileTransferMeta {fileId} <- createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize
fileStatus <- case fileInline of
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer
_ -> pure CIFSSndStored
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus}
pure (fileInvitation, ciFile, ft)
prepareMsg :: Maybe FileInvitation -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
prepareMsg fileInvitation_ = case quotedItemId_ of
Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_), Nothing)
@ -326,21 +329,32 @@ processChatCommand = \case
CTGroup -> do
Group gInfo@GroupInfo {membership, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
unless (memberActive membership) $ throwChatError CEGroupMemberUserRemoved
(fileInvitation_, ciFile_) <- unzipMaybe <$> setupSndFileTransfer gInfo
(fileInvitation_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo (length ms)
(msgContainer, quotedItem_) <- prepareMsg fileInvitation_ membership
msg <- sendGroupMessage gInfo ms (XMsgNew msgContainer)
msg@SndMessage {sharedMsgId} <- sendGroupMessage gInfo ms (XMsgNew msgContainer)
mapM_ (sendGroupFileInline ms sharedMsgId) ft_
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_
setActive $ ActiveG gName
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
where
setupSndFileTransfer :: GroupInfo -> m (Maybe (FileInvitation, CIFile 'MDSnd))
setupSndFileTransfer gInfo = forM file_ $ \file -> do
(fileSize, chSize) <- checkSndFile file
setupSndFileTransfer :: GroupInfo -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
setupSndFileTransfer gInfo n = forM file_ $ \file -> do
(fileSize, chSize, fileInline) <- checkSndFile file $ fromIntegral n
let fileName = takeFileName file
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing}
fileId <- withStore' $ \db -> createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
pure (fileInvitation, ciFile)
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing, fileInline}
fileStatus = if fileInline == Just IFMSent then CIFSSndTransfer else CIFSSndStored
withStore' $ \db -> do
ft@FileTransferMeta {fileId} <- createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus}
pure (fileInvitation, ciFile, ft)
sendGroupFileInline :: [GroupMember] -> SharedMsgId -> FileTransferMeta -> m ()
sendGroupFileInline ms sharedMsgId ft@FileTransferMeta {fileInline} =
when (fileInline == Just IFMSent) . forM_ ms $ \case
m@GroupMember {activeConn = Just conn@Connection {connStatus}} ->
when (connStatus == ConnReady || connStatus == ConnSndReady) $ do
void . withStore' $ \db -> createSndGroupInlineFT db m conn ft
sendMemberFileInline m conn ft sharedMsgId
_ -> pure ()
prepareMsg :: Maybe FileInvitation -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
prepareMsg fileInvitation_ membership = case quotedItemId_ of
Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_), Nothing)
@ -379,8 +393,9 @@ processChatCommand = \case
qText = msgContentText qmc
qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_
qTextOrFile = if T.null qText then qFileName else qText
unzipMaybe :: Maybe (a, b) -> (Maybe a, Maybe b)
unzipMaybe t = (fst <$> t, snd <$> t)
unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c)
unzipMaybe3 (Just (a, b, c)) = (Just a, Just b, Just c)
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
APIUpdateChatItem (ChatRef cType chatId) itemId mc -> withUser $ \user@User {userId} -> withChatLock $ case cType of
CTDirect -> do
(ct@Contact {contactId, localDisplayName = c}, ci) <- withStore $ \db -> (,) <$> getContact db userId chatId <*> getDirectChatItem db userId chatId itemId
@ -388,7 +403,7 @@ processChatCommand = \case
CChatItem SMDSnd ChatItem {meta = CIMeta {itemSharedMsgId}, content = ciContent} -> do
case (ciContent, itemSharedMsgId) of
(CISndMsgContent _, Just itemSharedMId) -> do
SndMessage {msgId} <- sendDirectContactMessage ct (XMsgUpdate itemSharedMId mc)
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgUpdate itemSharedMId mc)
updCi <- withStore $ \db -> updateDirectChatItem db userId contactId itemId (CISndMsgContent mc) $ Just msgId
setActive $ ActiveC c
pure . CRChatItemUpdated $ AChatItem SCTDirect SMDSnd (DirectChat ct) updCi
@ -544,7 +559,7 @@ processChatCommand = \case
dhKeyPair <- if encryptedCall callType then Just <$> liftIO C.generateKeyPair' else pure Nothing
let invitation = CallInvitation {callType, callDhPubKey = fst <$> dhKeyPair}
callState = CallInvitationSent {localCallType = callType, localDhPrivKey = snd <$> dhKeyPair}
msg <- sendDirectContactMessage ct (XCallInv callId invitation)
(msg, _) <- sendDirectContactMessage ct (XCallInv callId invitation)
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndCall CISCallPending 0) Nothing Nothing
let call' = Call {contactId, callId, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci}
call_ <- atomically $ TM.lookupInsert contactId call' calls
@ -570,7 +585,7 @@ processChatCommand = \case
offer = CallOffer {callType, rtcSession, callDhPubKey}
callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey}
aciContent = ACIContent SMDRcv $ CIRcvCall CISCallAccepted 0
SndMessage {msgId} <- sendDirectContactMessage ct (XCallOffer callId offer)
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XCallOffer callId offer)
withStore' $ \db -> updateDirectChatItemsRead db contactId $ Just (chatItemId, chatItemId)
updateDirectChatItemView userId ct chatItemId aciContent $ Just msgId
pure $ Just call {callState = callState'}
@ -581,7 +596,7 @@ processChatCommand = \case
CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} -> do
let callState' = CallNegotiated {localCallType, peerCallType, localCallSession = rtcSession, peerCallSession, sharedKey}
aciContent = ACIContent SMDSnd $ CISndCall CISCallNegotiated 0
SndMessage {msgId} <- sendDirectContactMessage ct (XCallAnswer callId CallAnswer {rtcSession})
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XCallAnswer callId CallAnswer {rtcSession})
updateDirectChatItemView userId ct chatItemId aciContent $ Just msgId
pure $ Just call {callState = callState'}
_ -> throwChatError . CECallState $ callStateTag callState
@ -590,19 +605,19 @@ processChatCommand = \case
withCurrentCall contactId $ \_ ct call@Call {callId, callState} -> case callState of
CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} -> do
-- TODO update the list of ice servers in localCallSession
_ <- sendDirectContactMessage ct (XCallExtra callId CallExtraInfo {rtcExtraInfo})
void . sendDirectContactMessage ct $ XCallExtra callId CallExtraInfo {rtcExtraInfo}
let callState' = CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey}
pure $ Just call {callState = callState'}
CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} -> do
-- TODO update the list of ice servers in localCallSession
_ <- sendDirectContactMessage ct (XCallExtra callId CallExtraInfo {rtcExtraInfo})
void . sendDirectContactMessage ct $ XCallExtra callId CallExtraInfo {rtcExtraInfo}
let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey}
pure $ Just call {callState = callState'}
_ -> throwChatError . CECallState $ callStateTag callState
APIEndCall contactId ->
-- any call party
withCurrentCall contactId $ \userId ct call@Call {callId} -> do
SndMessage {msgId} <- sendDirectContactMessage ct (XCallEnd callId)
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XCallEnd callId)
updateCallItemStatus userId ct call WCSDisconnected $ Just msgId
pure Nothing
APIGetCallInvitations -> withUser $ \User {userId} -> do
@ -769,7 +784,7 @@ processChatCommand = \case
forM_ cts $ \ct ->
void
( do
sndMsg <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing))
(sndMsg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing))
saveSndChatItem user (CDDirectSnd ct) sndMsg (CISndMsgContent mc) Nothing Nothing
)
`catchError` (toView . CRChatError)
@ -998,14 +1013,13 @@ processChatCommand = \case
unless cancelled $ do
cancelSndFile user ftm fts
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
void $
withStore (\db -> getChatRefByFileId db user fileId) >>= \case
ChatRef CTDirect contactId -> do
contact <- withStore $ \db -> getContact db userId contactId
sendDirectContactMessage contact $ XFileCancel sharedMsgId
void . sendDirectContactMessage contact $ XFileCancel sharedMsgId
ChatRef CTGroup groupId -> do
Group gInfo ms <- withStore $ \db -> getGroup db user groupId
sendGroupMessage gInfo ms $ XFileCancel sharedMsgId
void . sendGroupMessage gInfo ms $ XFileCancel sharedMsgId
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
ci <- withStore $ \db -> getChatItemByFileId db user fileId
pure $ CRSndGroupFileCancelled ci ftm fts
@ -1081,11 +1095,18 @@ processChatCommand = \case
contactMember Contact {contactId} =
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
checkSndFile :: FilePath -> m (Integer, Integer)
checkSndFile f = do
checkSndFile :: FilePath -> Integer -> m (Integer, Integer, Maybe InlineFileMode)
checkSndFile f n = do
fsFilePath <- toFSFilePath f
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
(,) <$> getFileSize fsFilePath <*> asks (fileChunkSize . config)
ChatConfig {fileChunkSize, inlineFiles} <- asks config
fileSize <- getFileSize fsFilePath
let chunks = -((-fileSize) `div` fileChunkSize)
pure (fileSize, fileChunkSize, inlineFileMode inlineFiles chunks n)
inlineFileMode InlineFilesConfig {offerChunks, sendChunks, totalSendChunks} chunks n
| chunks > offerChunks = Nothing
| chunks > sendChunks || chunks * n > totalSendChunks = Just IFMOffer
| otherwise = Just IFMSent
updateProfile :: User -> Profile -> m ChatResponse
updateProfile user@User {profile = p@LocalProfile {profileId, localAlias}} p'@Profile {displayName}
| p' == fromLocalProfile p = pure CRUserProfileNoChange
@ -1143,7 +1164,7 @@ sendGrpInvitation :: ChatMonad m => User -> Contact -> GroupInfo -> GroupMember
sendGrpInvitation user ct@Contact {localDisplayName} GroupInfo {groupId, groupProfile, membership} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
msg <- sendDirectContactMessage ct $ XGrpInv groupInv
(msg, _) <- sendDirectContactMessage ct $ XGrpInv groupInv
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
ci <- saveSndChatItem user (CDDirectSnd ct) msg content Nothing Nothing
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
@ -1223,7 +1244,7 @@ toFSFilePath f =
maybe f (<> "/" <> f) <$> (readTVarIO =<< asks filesFolder)
acceptFileReceive :: forall m. ChatMonad m => User -> RcvFileTransfer -> Maybe FilePath -> m AChatItem
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName = fName, fileConnReq}, fileStatus, grpMemberId} filePath_ = do
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId} filePath_ = do
unless (fileStatus == RFSNew) $ case fileStatus of
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
_ -> throwChatError $ CEFileAlreadyReceiving fName
@ -1231,7 +1252,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F
-- direct file protocol
Just connReq -> do
agentConnId <- withAgent $ \a -> joinConnection a True connReq . directMessage $ XFileAcpt fName
filePath <- getRcvFilePath filePath_ fName
filePath <- getRcvFilePath fileId filePath_ fName
withStore $ \db -> acceptRcvFileTransfer db user fileId agentConnId ConnJoined filePath
-- group & direct file protocol
Nothing -> do
@ -1252,15 +1273,25 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F
_ -> throwChatError $ CEFileInternal "member connection not active"
_ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer"
where
acceptFile :: m (ChatMsgEvent, AChatItem)
acceptFile :: m (ChatMsgEvent 'Json, AChatItem)
acceptFile = do
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
filePath <- getRcvFilePath fileId filePath_ fName
ChatConfig {fileChunkSize, inlineFiles} <- asks config
if
| fileInline == Just IFMOffer && fileSize <= fileChunkSize * receiveChunks inlineFiles -> do
-- accepting inline
ci <- withStore $ \db -> acceptRcvInlineFT db user fileId filePath
pure (XFileAcptInv sharedMsgId Nothing fName, ci)
| fileInline == Just IFMSent -> throwChatError $ CEFileAlreadyReceiving fName
| otherwise -> do
-- accepting via a new connection
(agentConnId, fileInvConnReq) <- withAgent $ \a -> createConnection a True SCMInvitation
filePath <- getRcvFilePath filePath_ fName
ci <- withStore (\db -> acceptRcvFileTransfer db user fileId agentConnId ConnNew filePath)
pure (XFileAcptInv sharedMsgId fileInvConnReq fName, ci)
getRcvFilePath :: Maybe FilePath -> String -> m FilePath
getRcvFilePath fPath_ fn = case fPath_ of
ci <- withStore $ \db -> acceptRcvFileTransfer db user fileId agentConnId ConnNew filePath
pure (XFileAcptInv sharedMsgId (Just fileInvConnReq) fName, ci)
getRcvFilePath :: forall m. ChatMonad m => FileTransferId -> Maybe FilePath -> String -> m FilePath
getRcvFilePath fileId fPath_ fn = case fPath_ of
Nothing ->
asks filesFolder >>= readTVarIO >>= \case
Nothing -> do
@ -1576,16 +1607,16 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
MSG msgMeta _msgFlags msgBody -> do
cmdId <- createAckCmd conn
msg@RcvMessage {chatMsgEvent} <- saveRcvMSG conn (ConnectionId connId) msgMeta msgBody cmdId
msg@RcvMessage {chatMsgEvent = ACME _ event} <- saveRcvMSG conn (ConnectionId connId) msgMeta msgBody cmdId
withAckMessage agentConnId cmdId msgMeta $
case chatMsgEvent of
case event of
XMsgNew mc -> newContentMessage ct mc msg msgMeta
XMsgUpdate sharedMsgId mContent -> messageUpdate ct sharedMsgId mContent msg msgMeta
XMsgDel sharedMsgId -> messageDelete ct sharedMsgId msg msgMeta
-- TODO discontinue XFile
XFile fInv -> processFileInvitation' ct fInv msg msgMeta
XFileCancel sharedMsgId -> xFileCancel ct sharedMsgId msgMeta
XFileAcptInv sharedMsgId fileConnReq fName -> xFileAcptInv ct sharedMsgId fileConnReq fName msgMeta
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta
XInfo p -> xInfo ct p
XGrpInv gInv -> processGroupInvitation ct gInv msg msgMeta
XInfoProbe probe -> xInfoProbe ct probe
@ -1596,10 +1627,11 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
XCallAnswer callId answer -> xCallAnswer ct callId answer msg msgMeta
XCallExtra callId extraInfo -> xCallExtra ct callId extraInfo msg msgMeta
XCallEnd callId -> xCallEnd ct callId msg msgMeta
_ -> pure ()
BFileChunk sharedMsgId chunk -> bFileChunk ct sharedMsgId chunk msgMeta
_ -> messageError $ "unsupported message: " <> T.pack (show event)
CONF confId _ connInfo -> do
-- confirming direct connection with a member
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
case chatMsgEvent of
XGrpMemInfo _memId _memProfile -> do
-- TODO check member ID
@ -1608,7 +1640,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
allowAgentConnectionAsync user conn confId XOk
_ -> messageError "CONF from member must have x.grp.mem.info"
INFO connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
case chatMsgEvent of
XGrpMemInfo _memId _memProfile -> do
-- TODO check member ID
@ -1631,7 +1663,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
Just (_, True, mc_, groupId_) -> do
forM_ mc_ $ \mc -> do
msg <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing))
(msg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing))
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) Nothing Nothing
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
forM_ groupId_ $ \groupId -> do
@ -1650,6 +1682,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
when (memberCategory m == GCPreMember) $ probeMatchingContacts ct connectedIncognito
SENT msgId -> do
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
withStore' (\db -> getDirectChatItemByAgentMsgId db userId contactId connId msgId) >>= \case
Just (CChatItem SMDSnd ci) -> do
chatItem <- withStore $ \db -> updateDirectChatItemStatus db userId contactId (chatItemId' ci) CISSndSent
@ -1690,7 +1723,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
sendXGrpMemIntro hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
CONF confId _ connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
case memberCategory m of
GCInviteeMember ->
case chatMsgEvent of
@ -1711,7 +1744,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
_ -> messageError "CONF from member must have x.grp.mem.info"
INFO connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
case chatMsgEvent of
XGrpMemInfo memId _memProfile
| sameMemberId memId m -> do
@ -1759,16 +1792,16 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
when (memberCategory m == GCPreMember) $ probeMatchingContacts ct connectedIncognito
MSG msgMeta _msgFlags msgBody -> do
cmdId <- createAckCmd conn
msg@RcvMessage {chatMsgEvent} <- saveRcvMSG conn (GroupId groupId) msgMeta msgBody cmdId
msg@RcvMessage {chatMsgEvent = ACME _ event} <- saveRcvMSG conn (GroupId groupId) msgMeta msgBody cmdId
withAckMessage agentConnId cmdId msgMeta $
case chatMsgEvent of
case event of
XMsgNew mc -> newGroupContentMessage gInfo m mc msg msgMeta
XMsgUpdate sharedMsgId mContent -> groupMessageUpdate gInfo m sharedMsgId mContent msg msgMeta
XMsgDel sharedMsgId -> groupMessageDelete gInfo m sharedMsgId msg
-- TODO discontinue XFile
XFile fInv -> processGroupFileInvitation' gInfo m fInv msg msgMeta
XFileCancel sharedMsgId -> xFileCancelGroup gInfo m sharedMsgId msgMeta
XFileAcptInv sharedMsgId fileConnReq fName -> xFileAcptInvGroup gInfo m sharedMsgId fileConnReq fName msgMeta
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m sharedMsgId fileConnReq_ fName msgMeta
XGrpMemNew memInfo -> xGrpMemNew gInfo m memInfo msg msgMeta
XGrpMemIntro memInfo -> xGrpMemIntro gInfo m memInfo
XGrpMemInv memId introInv -> xGrpMemInv gInfo m memId introInv
@ -1778,9 +1811,11 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
XGrpLeave -> xGrpLeave gInfo m msg msgMeta
XGrpDel -> xGrpDel gInfo m msg msgMeta
XGrpInfo p' -> xGrpInfo gInfo m p' msg msgMeta
_ -> messageError $ "unsupported message: " <> T.pack (show chatMsgEvent)
SENT msgId ->
BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta
_ -> messageError $ "unsupported message: " <> T.pack (show event)
SENT msgId -> do
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
OK ->
-- [async agent commands] continuation on receiving OK
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction, cmdId} ->
@ -1798,7 +1833,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
-- SMP CONF for SndFileConnection happens for direct file protocol
-- when recipient of the file "joins" connection created by the sender
CONF confId _ connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
case chatMsgEvent of
-- TODO save XFileAcpt message
XFileAcpt name
@ -1837,26 +1872,41 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
_ -> pure ()
processRcvFileConn :: ACommand 'Agent -> Connection -> RcvFileTransfer -> m ()
processRcvFileConn agentMsg conn ft@RcvFileTransfer {fileId, chunkSize, cancelled} =
processRcvFileConn agentMsg conn ft =
case agentMsg of
-- SMP CONF for RcvFileConnection happens for group file protocol
-- when sender of the file "joins" connection created by the recipient
-- (sender doesn't create connections for all group members)
CONF confId _ connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
case chatMsgEvent of
XOk -> allowAgentConnectionAsync user conn confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability
_ -> pure ()
CON -> do
CON -> startReceivingFile ft
MSG meta _ msgBody -> do
cmdId <- createAckCmd conn
withAckMessage agentConnId cmdId meta $
parseFileChunk msgBody >>= receiveFileChunk ft (Just conn) meta
OK ->
-- [async agent commands] continuation on receiving OK
withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
MERR _ err -> toView . CRChatError $ ChatErrorAgent err
ERR err -> do
toView . CRChatError $ ChatErrorAgent err
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
startReceivingFile :: RcvFileTransfer -> m ()
startReceivingFile ft@RcvFileTransfer {fileId} = do
ci <- withStore $ \db -> do
liftIO $ updateRcvFileStatus db ft FSConnected
liftIO $ updateCIFileStatus db user fileId CIFSRcvTransfer
getChatItemByFileId db user fileId
toView $ CRRcvFileStart ci
MSG meta@MsgMeta {recipient = (msgId, _), integrity} _ msgBody -> do
cmdId <- createAckCmd conn
withAckMessage agentConnId cmdId meta $ do
parseFileChunk msgBody >>= \case
receiveFileChunk :: RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> m ()
receiveFileChunk ft@RcvFileTransfer {fileId, chunkSize, cancelled} conn_ MsgMeta {recipient = (msgId, _), integrity} = \case
FileChunkCancel ->
unless cancelled $ do
cancelRcvFileTransfer user ft
@ -1885,23 +1935,14 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
getChatItemByFileId db user fileId
toView $ CRRcvFileComplete ci
closeFileHandle fileId rcvFiles
deleteAgentConnectionAsync user conn
mapM_ (deleteAgentConnectionAsync user) conn_
RcvChunkDuplicate -> pure ()
RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
OK ->
-- [async agent commands] continuation on receiving OK
withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
MERR _ err -> toView . CRChatError $ ChatErrorAgent err
ERR err -> do
toView . CRChatError $ ChatErrorAgent err
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
processUserContactRequest :: ACommand 'Agent -> Connection -> UserContact -> m ()
processUserContactRequest agentMsg conn UserContact {userContactLinkId} = case agentMsg of
REQ invId _ connInfo -> do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
case chatMsgEvent of
XContact p xContactId_ -> profileContactRequest invId p xContactId_
XInfo p -> profileContactRequest invId p Nothing
@ -2029,20 +2070,24 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
newContentMessage ct@Contact {localDisplayName = c, chatSettings} mc msg msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
let (ExtMsgContent content fileInvitation_) = mcExtMsgContent mc
ciFile_ <- processFileInvitation fileInvitation_ $
\fi chSize -> withStore' $ \db -> createRcvFileTransfer db userId ct fi chSize
ciFile_ <- processFileInvitation fileInvitation_ $ \db -> createRcvFileTransfer db userId ct
ci@ChatItem {formattedText} <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent content) ciFile_
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
when (enableNtfs chatSettings) $ showMsgToast (c <> "> ") content formattedText
setActive $ ActiveC c
processFileInvitation :: Maybe FileInvitation -> (FileInvitation -> Integer -> m RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
processFileInvitation fileInvitation_ createRcvFileTransferF =
forM fileInvitation_ $ \fileInvitation@FileInvitation {fileName, fileSize} -> do
processFileInvitation :: Maybe FileInvitation -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
processFileInvitation fInv_ createRcvFT = forM fInv_ $ \fInv@FileInvitation {fileName, fileSize} -> do
chSize <- asks $ fileChunkSize . config
RcvFileTransfer {fileId} <- createRcvFileTransferF fileInvitation chSize
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation}
pure ciFile
inline <- receiveInlineMode fInv chSize
ft@RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFT db fInv inline chSize
(filePath, fileStatus) <- case inline of
Just IFMSent -> do
fPath <- getRcvFilePath fileId Nothing fileName
withStore' $ \db -> startRcvInlineFT db user ft fPath
pure (Just fPath, CIFSRcvAccepted)
_ -> pure (Nothing, CIFSRcvInvitation)
pure CIFile {fileId, fileName, fileSize, filePath, fileStatus}
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> m ()
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta = do
@ -2082,9 +2127,8 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
newGroupContentMessage gInfo@GroupInfo {chatSettings} m@GroupMember {localDisplayName = c} mc msg msgMeta = do
let (ExtMsgContent content fileInvitation_) = mcExtMsgContent mc
ciFile_ <- processFileInvitation fileInvitation_ $
\fi chSize -> withStore' $ \db -> createRcvGroupFileTransfer db userId m fi chSize
let (ExtMsgContent content fInv_) = mcExtMsgContent mc
ciFile_ <- processFileInvitation fInv_ $ \db -> createRcvGroupFileTransfer db userId m
ci@ChatItem {formattedText} <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvMsgContent content) ciFile_
groupMsgToView gInfo m ci msgMeta
let g = groupName' gInfo
@ -2133,7 +2177,8 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
processFileInvitation' ct@Contact {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
chSize <- asks $ fileChunkSize . config
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFileTransfer db userId ct fInv chSize
inline <- receiveInlineMode fInv chSize
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvFileTransfer db userId ct fInv inline chSize
let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation}
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent $ MCFile "") ciFile
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
@ -2144,7 +2189,8 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
processGroupFileInvitation' gInfo m@GroupMember {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg msgMeta = do
chSize <- asks $ fileChunkSize . config
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvGroupFileTransfer db userId m fInv chSize
inline <- receiveInlineMode fInv chSize
RcvFileTransfer {fileId} <- withStore' $ \db -> createRcvGroupFileTransfer db userId m fInv inline chSize
let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation}
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvMsgContent $ MCFile "") ciFile
groupMsgToView gInfo m ci msgMeta
@ -2152,6 +2198,13 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
setActive $ ActiveG g
receiveInlineMode :: FileInvitation -> Integer -> m (Maybe InlineFileMode)
receiveInlineMode FileInvitation {fileSize, fileInline} chSize = case fileInline of
inline@(Just _) -> do
rcvChunks <- asks $ receiveChunks . inlineFiles . config
pure $ if fileSize <= rcvChunks * chSize then inline else Nothing
_ -> pure Nothing
xFileCancel :: Contact -> SharedMsgId -> MsgMeta -> m ()
xFileCancel ct@Contact {contactId} sharedMsgId msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
@ -2161,18 +2214,65 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
cancelRcvFileTransfer user ft
toView $ CRRcvFileSndCancelled ft
xFileAcptInv :: Contact -> SharedMsgId -> ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInv ct sharedMsgId fileConnReq fName msgMeta = do
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInv ct sharedMsgId fileConnReq_ fName msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId
(FileTransferMeta {fileName, cancelled}, _) <- withStore (\db -> getSndFileTransfer db user fileId)
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
if fName == fileName
then unless cancelled $ do
then unless cancelled $ case fileConnReq_ of
-- receiving via a separate connection
Just fileConnReq -> do
connIds <- joinAgentConnectionAsync user True fileConnReq $ directMessage XOk
withStore' $ \db -> createSndDirectFTConnection db user fileId connIds
-- receiving inline
_ -> do
event <- withStore $ \db -> do
ci <- updateDirectCIFileStatus db user fileId CIFSSndTransfer
sft <- liftIO $ createSndDirectInlineFT db ct ft
pure $ CRSndFileStart ci sft
toView event
ifM
(allowSendInline fileSize fileInline)
(sendDirectFileInline ct ft sharedMsgId)
(messageError "x.file.acpt.inv: fileSize is bigger than allowed to send inline")
else messageError "x.file.acpt.inv: fileName is different from expected"
checkSndInlineFTComplete :: Connection -> AgentMsgId -> m ()
checkSndInlineFTComplete conn agentMsgId = do
ft_ <- withStore' $ \db -> getSndInlineFTViaMsgDelivery db user conn agentMsgId
forM_ ft_ $ \ft@SndFileTransfer {fileId} -> do
ci <- withStore $ \db -> do
liftIO $ updateSndFileStatus db ft FSComplete
liftIO $ deleteSndFileChunks db ft
updateDirectCIFileStatus db user fileId CIFSSndComplete
toView $ CRSndFileComplete ci ft
allowSendInline :: Integer -> Maybe InlineFileMode -> m Bool
allowSendInline fileSize = \case
Just IFMOffer -> do
ChatConfig {fileChunkSize, inlineFiles} <- asks config
pure $ fileSize <= fileChunkSize * offerChunks inlineFiles
_ -> pure False
bFileChunk :: Contact -> SharedMsgId -> FileChunk -> MsgMeta -> m ()
bFileChunk ct sharedMsgId chunk meta = do
ft <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId >>= getRcvFileTransfer db user
receiveInlineChunk ft chunk meta
bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> m ()
bFileChunkGroup GroupInfo {groupId} sharedMsgId chunk meta = do
ft <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId >>= getRcvFileTransfer db user
receiveInlineChunk ft chunk meta
receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> m ()
receiveInlineChunk ft chunk meta = do
case chunk of
FileChunk {chunkNo} -> when (chunkNo == 1) $ startReceivingFile ft
_ -> pure ()
receiveFileChunk ft Nothing meta chunk
xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> MsgMeta -> m ()
xFileCancelGroup g@GroupInfo {groupId} mem@GroupMember {groupMemberId, memberId} sharedMsgId msgMeta = do
checkIntegrityCreateItem (CDGroupRcv g mem) msgMeta
@ -2189,16 +2289,31 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id
(SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel"
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInvGroup g@GroupInfo {groupId} m sharedMsgId fileConnReq fName msgMeta = do
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m ()
xFileAcptInvGroup g@GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName msgMeta = do
checkIntegrityCreateItem (CDGroupRcv g m) msgMeta
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
(FileTransferMeta {fileName, cancelled}, _) <- withStore (\db -> getSndFileTransfer db user fileId)
-- TODO check that it's not already accpeted
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
if fName == fileName
then unless cancelled $ do
then unless cancelled $ case (fileConnReq_, activeConn) of
(Just fileConnReq, _) -> do
-- receiving via a separate connection
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
connIds <- joinAgentConnectionAsync user True fileConnReq $ directMessage XOk
withStore' $ \db -> createSndGroupFileTransferConnection db user fileId connIds m
(_, Just conn) -> do
-- receiving inline
event <- withStore $ \db -> do
ci <- updateDirectCIFileStatus db user fileId CIFSSndTransfer
sft <- liftIO $ createSndGroupInlineFT db m conn ft
pure $ CRSndFileStart ci sft
toView event
ifM
(allowSendInline fileSize fileInline)
(sendMemberFileInline m conn ft sharedMsgId)
(messageError "x.file.acpt.inv: fileSize is bigger than allowed to send inline")
_ -> messageError "x.file.acpt.inv: member connection is not active"
else messageError "x.file.acpt.inv: fileName is different from expected"
groupMsgToView :: GroupInfo -> GroupMember -> ChatItem 'CTGroup 'MDRcv -> MsgMeta -> m ()
@ -2370,7 +2485,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
saveConnInfo :: Connection -> ConnInfo -> m ()
saveConnInfo activeConn connInfo = do
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
case chatMsgEvent of
XInfo p -> do
ct <- withStore $ \db -> createDirectContact db userId activeConn p
@ -2528,8 +2643,33 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
groupMsgToView g' m ci msgMeta
toView . CRGroupUpdated g g' $ Just m
parseChatMessage :: ByteString -> Either ChatError ChatMessage
parseChatMessage = first (ChatError . CEInvalidChatMessage) . strDecode
sendDirectFileInline :: ChatMonad m => Contact -> FileTransferMeta -> SharedMsgId -> m ()
sendDirectFileInline ct ft sharedMsgId = do
msgDeliveryId <- sendFileInline_ ft sharedMsgId $ sendDirectContactMessage ct
withStore' $ \db -> updateSndDirectFTDelivery db ct ft msgDeliveryId
sendMemberFileInline :: ChatMonad m => GroupMember -> Connection -> FileTransferMeta -> SharedMsgId -> m ()
sendMemberFileInline m@GroupMember {groupId} conn ft sharedMsgId = do
msgDeliveryId <- sendFileInline_ ft sharedMsgId $ \msg -> sendDirectMessage conn msg $ GroupId groupId
withStore' $ \db -> updateSndGroupFTDelivery db m conn ft msgDeliveryId
sendFileInline_ :: ChatMonad m => FileTransferMeta -> SharedMsgId -> (ChatMsgEvent 'Binary -> m (SndMessage, Int64)) -> m Int64
sendFileInline_ FileTransferMeta {filePath, chunkSize} sharedMsgId sendMsg =
sendChunks 1 =<< liftIO . B.readFile =<< toFSFilePath filePath
where
sendChunks chunkNo bytes = do
let (chunk, rest) = B.splitAt chSize bytes
(_, msgDeliveryId) <- sendMsg $ BFileChunk sharedMsgId $ FileChunk chunkNo chunk
if B.null rest
then pure msgDeliveryId
else sendChunks (chunkNo + 1) rest
chSize = fromIntegral chunkSize
parseChatMessage :: ChatMonad m => ByteString -> m (ChatMessage 'Json)
parseChatMessage = liftEither . first (ChatError . CEInvalidChatMessage) . strDecode
parseAChatMessage :: ChatMonad m => ByteString -> m AChatMessage
parseAChatMessage = liftEither . first (ChatError . CEInvalidChatMessage) . strDecode
sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m ()
sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, connId, agentConnId} =
@ -2563,24 +2703,8 @@ readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do
when (pos /= pos') $ hSeek h AbsoluteSeek pos'
liftIO . B.hGet h $ fromInteger chunkSize
data FileChunk = FileChunk {chunkNo :: Integer, chunkBytes :: ByteString} | FileChunkCancel
instance Encoding FileChunk where
smpEncode = \case
FileChunk {chunkNo, chunkBytes} -> smpEncode ('F', fromIntegral chunkNo :: Word32, Tail chunkBytes)
FileChunkCancel -> smpEncode 'C'
smpP =
smpP >>= \case
'F' -> do
chunkNo <- fromIntegral <$> smpP @Word32
Tail chunkBytes <- smpP
pure FileChunk {chunkNo, chunkBytes}
'C' -> pure FileChunkCancel
_ -> fail "bad FileChunk"
parseFileChunk :: ChatMonad m => ByteString -> m FileChunk
parseFileChunk msg =
liftEither . first (ChatError . CEFileRcvChunk) $ parseAll smpP msg
parseFileChunk = liftEither . first (ChatError . CEFileRcvChunk) . smpDecode
appendFileChunk :: ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> m ()
appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk =
@ -2617,13 +2741,13 @@ isFileActive fileId files = do
isJust . M.lookup fileId <$> readTVarIO fs
cancelRcvFileTransfer :: ChatMonad m => User -> RcvFileTransfer -> m ()
cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, fileStatus} = do
cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, fileStatus, rcvFileInline} = do
closeFileHandle fileId rcvFiles
withStore' $ \db -> do
updateFileCancelled db user fileId CIFSRcvCancelled
updateRcvFileStatus db ft FSCancelled
deleteRcvFileChunks db ft
case fileStatus of
when (isNothing rcvFileInline) $ case fileStatus of
RFSAccepted RcvFileInfo {connId, agentConnId} ->
deleteAgentConnectionAsync' user connId agentConnId
RFSConnected RcvFileInfo {connId, agentConnId} ->
@ -2661,45 +2785,44 @@ deleteMemberConnection user GroupMember {activeConn} = do
-- withStore $ \db -> deleteGroupMemberConnection db userId m
sendDirectContactMessage :: ChatMonad m => Contact -> ChatMsgEvent -> m SndMessage
sendDirectContactMessage :: (MsgEncodingI e, ChatMonad m) => Contact -> ChatMsgEvent e -> m (SndMessage, Int64)
sendDirectContactMessage ct@Contact {activeConn = conn@Connection {connId, connStatus}} chatMsgEvent = do
if connStatus == ConnReady || connStatus == ConnSndReady
then sendDirectMessage conn chatMsgEvent (ConnectionId connId)
else throwChatError $ CEContactNotReady ct
sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> ConnOrGroupId -> m SndMessage
sendDirectMessage :: (MsgEncodingI e, ChatMonad m) => Connection -> ChatMsgEvent e -> ConnOrGroupId -> m (SndMessage, Int64)
sendDirectMessage conn chatMsgEvent connOrGroupId = do
msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent connOrGroupId
deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId
pure msg
(msg,) <$> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId
createSndMessage :: ChatMonad m => ChatMsgEvent -> ConnOrGroupId -> m SndMessage
createSndMessage :: (MsgEncodingI e, ChatMonad m) => ChatMsgEvent e -> ConnOrGroupId -> m SndMessage
createSndMessage chatMsgEvent connOrGroupId = do
gVar <- asks idsDrg
withStore $ \db -> createNewSndMessage db gVar connOrGroupId $ \sharedMsgId ->
let msgBody = strEncode ChatMessage {msgId = Just sharedMsgId, chatMsgEvent}
in NewMessage {chatMsgEvent, msgBody}
directMessage :: ChatMsgEvent -> ByteString
directMessage :: MsgEncodingI e => ChatMsgEvent e -> ByteString
directMessage chatMsgEvent = strEncode ChatMessage {msgId = Nothing, chatMsgEvent}
deliverMessage :: ChatMonad m => Connection -> CMEventTag -> MsgBody -> MessageId -> m ()
deliverMessage :: ChatMonad m => Connection -> CMEventTag e -> MsgBody -> MessageId -> m Int64
deliverMessage conn@Connection {connId} cmEventTag msgBody msgId = do
let msgFlags = MsgFlags {notification = hasNotification cmEventTag}
agentMsgId <- withAgent $ \a -> sendMessage a (aConnId conn) msgFlags msgBody
let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId}
withStore' $ \db -> createSndMsgDelivery db sndMsgDelivery msgId
sendGroupMessage :: ChatMonad m => GroupInfo -> [GroupMember] -> ChatMsgEvent -> m SndMessage
sendGroupMessage :: (MsgEncodingI e, ChatMonad m) => GroupInfo -> [GroupMember] -> ChatMsgEvent e -> m SndMessage
sendGroupMessage GroupInfo {groupId} members chatMsgEvent =
sendGroupMessage' members chatMsgEvent groupId Nothing $ pure ()
sendXGrpMemInv :: ChatMonad m => GroupInfo -> GroupMember -> ChatMsgEvent -> Int64 -> m SndMessage
sendXGrpMemInv :: (MsgEncodingI e, ChatMonad m) => GroupInfo -> GroupMember -> ChatMsgEvent e -> Int64 -> m SndMessage
sendXGrpMemInv GroupInfo {groupId} reMember chatMsgEvent introId =
sendGroupMessage' [reMember] chatMsgEvent groupId (Just introId) $
withStore' $ \db -> updateIntroStatus db introId GMIntroInvForwarded
sendGroupMessage' :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> Int64 -> Maybe Int64 -> m () -> m SndMessage
sendGroupMessage' :: (MsgEncodingI e, ChatMonad m) => [GroupMember] -> ChatMsgEvent e -> Int64 -> Maybe Int64 -> m () -> m SndMessage
sendGroupMessage' members chatMsgEvent groupId introId_ postDeliver = do
msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent (GroupId groupId)
-- TODO collect failed deliveries into a single error
@ -2718,16 +2841,18 @@ sendPendingGroupMessages :: ChatMonad m => GroupMember -> Connection -> m ()
sendPendingGroupMessages GroupMember {groupMemberId, localDisplayName} conn = do
pendingMessages <- withStore' $ \db -> getPendingGroupMessages db groupMemberId
-- TODO ensure order - pending messages interleave with user input messages
forM_ pendingMessages $ \PendingGroupMessage {msgId, cmEventTag, msgBody, introId_} -> do
deliverMessage conn cmEventTag msgBody msgId
forM_ pendingMessages $ \PendingGroupMessage {msgId, cmEventTag = ACMEventTag _ tag, msgBody, introId_} -> do
void $ deliverMessage conn tag msgBody msgId
withStore' $ \db -> deletePendingGroupMessage db groupMemberId msgId
when (cmEventTag == XGrpMemFwd_) $ case introId_ of
Nothing -> throwChatError $ CEGroupMemberIntroNotFound localDisplayName
case tag of
XGrpMemFwd_ -> case introId_ of
Just introId -> withStore' $ \db -> updateIntroStatus db introId GMIntroInvForwarded
_ -> throwChatError $ CEGroupMemberIntroNotFound localDisplayName
_ -> pure ()
saveRcvMSG :: ChatMonad m => Connection -> ConnOrGroupId -> MsgMeta -> MsgBody -> CommandId -> m RcvMessage
saveRcvMSG Connection {connId} connOrGroupId agentMsgMeta msgBody agentAckCmdId = do
ChatMessage {msgId = sharedMsgId_, chatMsgEvent} <- liftEither $ parseChatMessage msgBody
ACMsg _ ChatMessage {msgId = sharedMsgId_, chatMsgEvent} <- parseAChatMessage msgBody
let agentMsgId = fst $ recipient agentMsgMeta
newMsg = NewMessage {chatMsgEvent, msgBody}
rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId}
@ -2769,7 +2894,7 @@ joinAgentConnectionAsync user enableNtfs cReqUri cInfo = do
connId <- withAgent $ \a -> joinConnectionAsync a (aCorrId cmdId) enableNtfs cReqUri cInfo
pure (cmdId, connId)
allowAgentConnectionAsync :: ChatMonad m => User -> Connection -> ConfirmationId -> ChatMsgEvent -> m ()
allowAgentConnectionAsync :: (MsgEncodingI e, ChatMonad m) => User -> Connection -> ConfirmationId -> ChatMsgEvent e -> m ()
allowAgentConnectionAsync user conn@Connection {connId} confId msg = do
cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFAllowConn
withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId $ directMessage msg

17
src/Simplex/Chat/Controller.hs
View file

@ -67,12 +67,29 @@ data ChatConfig = ChatConfig
defaultServers :: InitialAgentServers,
tbqSize :: Natural,
fileChunkSize :: Integer,
inlineFiles :: InlineFilesConfig,
subscriptionConcurrency :: Int,
subscriptionEvents :: Bool,
hostEvents :: Bool,
testView :: Bool
}
data InlineFilesConfig = InlineFilesConfig
{ offerChunks :: Integer,
sendChunks :: Integer,
totalSendChunks :: Integer,
receiveChunks :: Integer
}
defaultInlineFilesConfig :: InlineFilesConfig
defaultInlineFilesConfig =
InlineFilesConfig
{ offerChunks = 15, -- max when chunks are offered - limited to 255 on the encoding level
sendChunks = 0, -- max per file when chunks will be sent inline without acceptance
totalSendChunks = 30, -- max per conversation when chunks will be sent inline without acceptance
receiveChunks = 5 -- max when chunks are accepted
}
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
deriving (Eq)

10
src/Simplex/Chat/Messages.hs
View file

@ -338,6 +338,8 @@ data CIFileStatus (d :: MsgDirection) where
CIFSRcvComplete :: CIFileStatus 'MDRcv
CIFSRcvCancelled :: CIFileStatus 'MDRcv
deriving instance Eq (CIFileStatus d)
deriving instance Show (CIFileStatus d)
ciFileEnded :: CIFileStatus d -> Bool
@ -836,8 +838,8 @@ instance ChatTypeI 'CTDirect where chatTypeI = SCTDirect
instance ChatTypeI 'CTGroup where chatTypeI = SCTGroup
data NewMessage = NewMessage
{ chatMsgEvent :: ChatMsgEvent,
data NewMessage e = NewMessage
{ chatMsgEvent :: ChatMsgEvent e,
msgBody :: MsgBody
}
deriving (Show)
@ -850,14 +852,14 @@ data SndMessage = SndMessage
data RcvMessage = RcvMessage
{ msgId :: MessageId,
chatMsgEvent :: ChatMsgEvent,
chatMsgEvent :: AChatMsgEvent,
sharedMsgId_ :: Maybe SharedMsgId,
msgBody :: MsgBody
}
data PendingGroupMessage = PendingGroupMessage
{ msgId :: MessageId,
cmEventTag :: CMEventTag,
cmEventTag :: ACMEventTag,
msgBody :: MsgBody,
introId_ :: Maybe Int64
}

20
src/Simplex/Chat/Migrations/M20221012_inline_files.hs Normal file
View file

@ -0,0 +1,20 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20221012_inline_files where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20221012_inline_files :: Query
m20221012_inline_files =
[sql|
DROP INDEX idx_messages_direct_shared_msg_id;
ALTER TABLE files ADD COLUMN file_inline TEXT;
ALTER TABLE rcv_files ADD COLUMN rcv_file_inline TEXT;
ALTER TABLE rcv_files ADD COLUMN file_inline TEXT;
ALTER TABLE snd_files ADD COLUMN file_inline TEXT;
ALTER TABLE snd_files ADD COLUMN last_inline_msg_delivery_id INTEGER;
CREATE UNIQUE INDEX idx_snd_files_last_inline_msg_delivery_id ON snd_files(last_inline_msg_delivery_id);
|]

17
src/Simplex/Chat/Migrations/chat_schema.sql
View file

@ -182,7 +182,8 @@ CREATE TABLE files(
chat_item_id INTEGER DEFAULT NULL REFERENCES chat_items ON DELETE CASCADE,
updated_at TEXT CHECK(updated_at NOT NULL),
cancelled INTEGER,
ci_file_status TEXT
ci_file_status TEXT,
file_inline TEXT
);
CREATE TABLE snd_files(
file_id INTEGER NOT NULL REFERENCES files ON DELETE CASCADE,
@ -191,6 +192,8 @@ CREATE TABLE snd_files(
group_member_id INTEGER REFERENCES group_members ON DELETE CASCADE,
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL),
file_inline TEXT,
last_inline_msg_delivery_id INTEGER,
PRIMARY KEY(file_id, connection_id)
) WITHOUT ROWID;
CREATE TABLE rcv_files(
@ -200,7 +203,9 @@ CREATE TABLE rcv_files(
file_queue_info BLOB
,
created_at TEXT CHECK(created_at NOT NULL),
updated_at TEXT CHECK(updated_at NOT NULL)
updated_at TEXT CHECK(updated_at NOT NULL),
rcv_file_inline TEXT,
file_inline TEXT
);
CREATE TABLE snd_file_chunks(
file_id INTEGER NOT NULL,
@ -370,11 +375,6 @@ CREATE TABLE smp_servers(
UNIQUE(host, port)
);
CREATE INDEX idx_messages_shared_msg_id ON messages(shared_msg_id);
CREATE UNIQUE INDEX idx_messages_direct_shared_msg_id ON messages(
connection_id,
shared_msg_id_user,
shared_msg_id
);
CREATE INDEX idx_chat_items_shared_msg_id ON chat_items(shared_msg_id);
CREATE TABLE calls(
-- stores call invitations state for communicating state between NSE and app when call notification comes
@ -431,3 +431,6 @@ CREATE INDEX idx_msg_deliveries_message_id ON msg_deliveries(message_id);
CREATE UNIQUE INDEX idx_user_contact_links_group_id ON user_contact_links(
group_id
);
CREATE UNIQUE INDEX idx_snd_files_last_inline_msg_delivery_id ON snd_files(
last_inline_msg_delivery_id
);

418
src/Simplex/Chat/Protocol.hs
View file

@ -9,7 +9,9 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
module Simplex.Chat.Protocol where
@ -22,19 +24,25 @@ import qualified Data.Aeson.KeyMap as JM
import qualified Data.Aeson.Types as JT
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w, w2c)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Type.Equality
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Chat.Call
import Simplex.Chat.Types
import Simplex.Chat.Util (safeDecodeUtf8)
import Simplex.Messaging.Encoding
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (fromTextField_, fstToLower, sumTypeJSON)
import Simplex.Messaging.Parsers (fromTextField_, fstToLower, parseAll, sumTypeJSON)
import Simplex.Messaging.Util (eitherToMaybe, (<$?>))
data ConnectionEntity
@ -59,18 +67,64 @@ updateEntityConnStatus connEntity connStatus = case connEntity of
where
st c = c {connStatus}
data MsgEncoding = Binary | Json
data SMsgEncoding (e :: MsgEncoding) where
SBinary :: SMsgEncoding 'Binary
SJson :: SMsgEncoding 'Json
deriving instance Show (SMsgEncoding e)
class MsgEncodingI (e :: MsgEncoding) where
encoding :: SMsgEncoding e
instance MsgEncodingI 'Binary where encoding = SBinary
instance MsgEncodingI 'Json where encoding = SJson
data ACMEventTag = forall e. MsgEncodingI e => ACMEventTag (SMsgEncoding e) (CMEventTag e)
instance TestEquality SMsgEncoding where
testEquality SBinary SBinary = Just Refl
testEquality SJson SJson = Just Refl
testEquality _ _ = Nothing
checkEncoding :: forall t e e'. (MsgEncodingI e, MsgEncodingI e') => t e' -> Either String (t e)
checkEncoding x = case testEquality (encoding @e) (encoding @e') of
Just Refl -> Right x
Nothing -> Left "bad encoding"
data AppMessage (e :: MsgEncoding) where
AMJson :: AppMessageJson -> AppMessage 'Json
AMBinary :: AppMessageBinary -> AppMessage 'Binary
-- chat message is sent as JSON with these properties
data AppMessage = AppMessage
data AppMessageJson = AppMessageJson
{ msgId :: Maybe SharedMsgId,
event :: Text,
params :: J.Object
}
deriving (Generic, FromJSON)
instance ToJSON AppMessage where
data AppMessageBinary = AppMessageBinary
{ msgId :: Maybe SharedMsgId,
tag :: Char,
body :: ByteString
}
instance ToJSON AppMessageJson where
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
instance StrEncoding AppMessageBinary where
strEncode AppMessageBinary {tag, msgId, body} = smpEncode (tag, msgId', Tail body)
where
msgId' = maybe B.empty (\(SharedMsgId mId') -> mId') msgId
strP = do
(tag, msgId', Tail body) <- smpP
let msgId = if B.null msgId' then Nothing else Just (SharedMsgId msgId')
pure AppMessageBinary {tag, msgId, body}
newtype SharedMsgId = SharedMsgId ByteString
deriving (Eq, Show)
@ -105,51 +159,99 @@ instance ToJSON MsgRef where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data ChatMessage = ChatMessage {msgId :: Maybe SharedMsgId, chatMsgEvent :: ChatMsgEvent}
data ChatMessage e = ChatMessage {msgId :: Maybe SharedMsgId, chatMsgEvent :: ChatMsgEvent e}
deriving (Eq, Show)
instance StrEncoding ChatMessage where
strEncode = LB.toStrict . J.encode . chatToAppMessage
strDecode = appToChatMessage <=< J.eitherDecodeStrict'
strP = strDecode <$?> A.takeByteString
data AChatMessage = forall e. MsgEncodingI e => ACMsg (SMsgEncoding e) (ChatMessage e)
data ChatMsgEvent
= XMsgNew MsgContainer
| XMsgUpdate SharedMsgId MsgContent
| XMsgDel SharedMsgId
| XMsgDeleted
| XFile FileInvitation -- TODO discontinue
| XFileAcpt String -- direct file protocol
| XFileAcptInv SharedMsgId ConnReqInvitation String -- group file protocol
| XFileCancel SharedMsgId
| XInfo Profile
| XContact Profile (Maybe XContactId)
| XGrpInv GroupInvitation
| XGrpAcpt MemberId
| XGrpMemNew MemberInfo
| XGrpMemIntro MemberInfo
| XGrpMemInv MemberId IntroInvitation
| XGrpMemFwd MemberInfo IntroInvitation
| XGrpMemInfo MemberId Profile
| XGrpMemRole MemberId GroupMemberRole
| XGrpMemCon MemberId -- TODO not implemented
| XGrpMemConAll MemberId -- TODO not implemented
| XGrpMemDel MemberId
| XGrpLeave
| XGrpDel
| XGrpInfo GroupProfile
| XInfoProbe Probe
| XInfoProbeCheck ProbeHash
| XInfoProbeOk Probe
| XCallInv CallId CallInvitation
| XCallOffer CallId CallOffer
| XCallAnswer CallId CallAnswer
| XCallExtra CallId CallExtraInfo
| XCallEnd CallId
| XOk
| XUnknown {event :: Text, params :: J.Object}
instance MsgEncodingI e => StrEncoding (ChatMessage e) where
strEncode msg = case chatToAppMessage msg of
AMJson m -> LB.toStrict $ J.encode m
AMBinary m -> strEncode m
strP = (\(ACMsg _ m) -> checkEncoding m) <$?> strP
instance StrEncoding AChatMessage where
strEncode (ACMsg _ m) = strEncode m
strP =
A.peekChar' >>= \case
'{' -> ACMsg SJson <$> ((appJsonToCM <=< J.eitherDecodeStrict') <$?> A.takeByteString)
_ -> ACMsg SBinary <$> (appBinaryToCM <$?> strP)
data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgUpdate :: SharedMsgId -> MsgContent -> ChatMsgEvent 'Json
XMsgDel :: SharedMsgId -> ChatMsgEvent 'Json
XMsgDeleted :: ChatMsgEvent 'Json
XFile :: FileInvitation -> ChatMsgEvent 'Json -- TODO discontinue
XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol
XFileAcptInv :: SharedMsgId -> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json
XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
XInfo :: Profile -> ChatMsgEvent 'Json
XContact :: Profile -> Maybe XContactId -> ChatMsgEvent 'Json
XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json
XGrpAcpt :: MemberId -> ChatMsgEvent 'Json
XGrpMemNew :: MemberInfo -> ChatMsgEvent 'Json
XGrpMemIntro :: MemberInfo -> ChatMsgEvent 'Json
XGrpMemInv :: MemberId -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemFwd :: MemberInfo -> IntroInvitation -> ChatMsgEvent 'Json
XGrpMemInfo :: MemberId -> Profile -> ChatMsgEvent 'Json
XGrpMemRole :: MemberId -> GroupMemberRole -> ChatMsgEvent 'Json
XGrpMemCon :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
XGrpMemConAll :: MemberId -> ChatMsgEvent 'Json -- TODO not implemented
XGrpMemDel :: MemberId -> ChatMsgEvent 'Json
XGrpLeave :: ChatMsgEvent 'Json
XGrpDel :: ChatMsgEvent 'Json
XGrpInfo :: GroupProfile -> ChatMsgEvent 'Json
XInfoProbe :: Probe -> ChatMsgEvent 'Json
XInfoProbeCheck :: ProbeHash -> ChatMsgEvent 'Json
XInfoProbeOk :: Probe -> ChatMsgEvent 'Json
XCallInv :: CallId -> CallInvitation -> ChatMsgEvent 'Json
XCallOffer :: CallId -> CallOffer -> ChatMsgEvent 'Json
XCallAnswer :: CallId -> CallAnswer -> ChatMsgEvent 'Json
XCallExtra :: CallId -> CallExtraInfo -> ChatMsgEvent 'Json
XCallEnd :: CallId -> ChatMsgEvent 'Json
XOk :: ChatMsgEvent 'Json
XUnknown :: {event :: Text, params :: J.Object} -> ChatMsgEvent 'Json
BFileChunk :: SharedMsgId -> FileChunk -> ChatMsgEvent 'Binary
deriving instance Eq (ChatMsgEvent e)
deriving instance Show (ChatMsgEvent e)
data AChatMsgEvent = forall e. MsgEncodingI e => ACME (SMsgEncoding e) (ChatMsgEvent e)
deriving instance Show AChatMsgEvent
data FileChunk = FileChunk {chunkNo :: Integer, chunkBytes :: ByteString} | FileChunkCancel
deriving (Eq, Show)
instance Encoding FileChunk where
smpEncode = \case
FileChunk {chunkNo, chunkBytes} -> smpEncode ('F', fromIntegral chunkNo :: Word32, Tail chunkBytes)
FileChunkCancel -> smpEncode 'C'
smpP =
smpP >>= \case
'F' -> do
chunkNo <- fromIntegral <$> smpP @Word32
Tail chunkBytes <- smpP
pure FileChunk {chunkNo, chunkBytes}
'C' -> pure FileChunkCancel
_ -> fail "bad FileChunk"
newtype InlineFileChunk = IFC {unIFC :: FileChunk}
instance Encoding InlineFileChunk where
smpEncode (IFC chunk) = case chunk of
FileChunk {chunkNo, chunkBytes} -> smpEncode (w2c $ fromIntegral chunkNo, Tail chunkBytes)
FileChunkCancel -> smpEncode '\NUL'
smpP = do
c <- A.anyChar
IFC <$> case c of
'\NUL' -> pure FileChunkCancel
_ -> do
Tail chunkBytes <- smpP
pure FileChunk {chunkNo = fromIntegral $ c2w c, chunkBytes}
data QuotedMsg = QuotedMsg {msgRef :: MsgRef, content :: MsgContent}
deriving (Eq, Show, Generic, FromJSON)
@ -157,9 +259,9 @@ instance ToJSON QuotedMsg where
toEncoding = J.genericToEncoding J.defaultOptions
toJSON = J.genericToJSON J.defaultOptions
cmToQuotedMsg :: ChatMsgEvent -> Maybe QuotedMsg
cmToQuotedMsg :: AChatMsgEvent -> Maybe QuotedMsg
cmToQuotedMsg = \case
XMsgNew (MCQuote quotedMsg _) -> Just quotedMsg
ACME _ (XMsgNew (MCQuote quotedMsg _)) -> Just quotedMsg
_ -> Nothing
data MsgContentTag = MCText_ | MCLink_ | MCImage_ | MCFile_ | MCUnknown_ Text
@ -273,7 +375,7 @@ msgContainerJSON = \case
where
withFile l = \case
Nothing -> l
Just f -> l <> ["file" .= fileInvitationJSON f]
Just f -> l <> ["file" .= f]
instance ToJSON MsgContent where
toJSON = \case
@ -295,44 +397,48 @@ instance ToField MsgContent where
instance FromField MsgContent where
fromField = fromTextField_ $ J.decode . LB.fromStrict . encodeUtf8
data CMEventTag
= XMsgNew_
| XMsgUpdate_
| XMsgDel_
| XMsgDeleted_
| XFile_
| XFileAcpt_
| XFileAcptInv_
| XFileCancel_
| XInfo_
| XContact_
| XGrpInv_
| XGrpAcpt_
| XGrpMemNew_
| XGrpMemIntro_
| XGrpMemInv_
| XGrpMemFwd_
| XGrpMemInfo_
| XGrpMemRole_
| XGrpMemCon_
| XGrpMemConAll_
| XGrpMemDel_
| XGrpLeave_
| XGrpDel_
| XGrpInfo_
| XInfoProbe_
| XInfoProbeCheck_
| XInfoProbeOk_
| XCallInv_
| XCallOffer_
| XCallAnswer_
| XCallExtra_
| XCallEnd_
| XOk_
| XUnknown_ Text
deriving (Eq, Show)
data CMEventTag (e :: MsgEncoding) where
XMsgNew_ :: CMEventTag 'Json
XMsgUpdate_ :: CMEventTag 'Json
XMsgDel_ :: CMEventTag 'Json
XMsgDeleted_ :: CMEventTag 'Json
XFile_ :: CMEventTag 'Json
XFileAcpt_ :: CMEventTag 'Json
XFileAcptInv_ :: CMEventTag 'Json
XFileCancel_ :: CMEventTag 'Json
XInfo_ :: CMEventTag 'Json
XContact_ :: CMEventTag 'Json
XGrpInv_ :: CMEventTag 'Json
XGrpAcpt_ :: CMEventTag 'Json
XGrpMemNew_ :: CMEventTag 'Json
XGrpMemIntro_ :: CMEventTag 'Json
XGrpMemInv_ :: CMEventTag 'Json
XGrpMemFwd_ :: CMEventTag 'Json
XGrpMemInfo_ :: CMEventTag 'Json
XGrpMemRole_ :: CMEventTag 'Json
XGrpMemCon_ :: CMEventTag 'Json
XGrpMemConAll_ :: CMEventTag 'Json
XGrpMemDel_ :: CMEventTag 'Json
XGrpLeave_ :: CMEventTag 'Json
XGrpDel_ :: CMEventTag 'Json
XGrpInfo_ :: CMEventTag 'Json
XInfoProbe_ :: CMEventTag 'Json
XInfoProbeCheck_ :: CMEventTag 'Json
XInfoProbeOk_ :: CMEventTag 'Json
XCallInv_ :: CMEventTag 'Json
XCallOffer_ :: CMEventTag 'Json
XCallAnswer_ :: CMEventTag 'Json
XCallExtra_ :: CMEventTag 'Json
XCallEnd_ :: CMEventTag 'Json
XOk_ :: CMEventTag 'Json
XUnknown_ :: Text -> CMEventTag 'Json
BFileChunk_ :: CMEventTag 'Binary
instance StrEncoding CMEventTag where
deriving instance Show (CMEventTag e)
deriving instance Eq (CMEventTag e)
instance MsgEncodingI e => StrEncoding (CMEventTag e) where
strEncode = \case
XMsgNew_ -> "x.msg.new"
XMsgUpdate_ -> "x.msg.update"
@ -368,45 +474,54 @@ instance StrEncoding CMEventTag where
XCallEnd_ -> "x.call.end"
XOk_ -> "x.ok"
XUnknown_ t -> encodeUtf8 t
strDecode = \case
"x.msg.new" -> Right XMsgNew_
"x.msg.update" -> Right XMsgUpdate_
"x.msg.del" -> Right XMsgDel_
"x.msg.deleted" -> Right XMsgDeleted_
"x.file" -> Right XFile_
"x.file.acpt" -> Right XFileAcpt_
"x.file.acpt.inv" -> Right XFileAcptInv_
"x.file.cancel" -> Right XFileCancel_
"x.info" -> Right XInfo_
"x.contact" -> Right XContact_
"x.grp.inv" -> Right XGrpInv_
"x.grp.acpt" -> Right XGrpAcpt_
"x.grp.mem.new" -> Right XGrpMemNew_
"x.grp.mem.intro" -> Right XGrpMemIntro_
"x.grp.mem.inv" -> Right XGrpMemInv_
"x.grp.mem.fwd" -> Right XGrpMemFwd_
"x.grp.mem.info" -> Right XGrpMemInfo_
"x.grp.mem.role" -> Right XGrpMemRole_
"x.grp.mem.con" -> Right XGrpMemCon_
"x.grp.mem.con.all" -> Right XGrpMemConAll_
"x.grp.mem.del" -> Right XGrpMemDel_
"x.grp.leave" -> Right XGrpLeave_
"x.grp.del" -> Right XGrpDel_
"x.grp.info" -> Right XGrpInfo_
"x.info.probe" -> Right XInfoProbe_
"x.info.probe.check" -> Right XInfoProbeCheck_
"x.info.probe.ok" -> Right XInfoProbeOk_
"x.call.inv" -> Right XCallInv_
"x.call.offer" -> Right XCallOffer_
"x.call.answer" -> Right XCallAnswer_
"x.call.extra" -> Right XCallExtra_
"x.call.end" -> Right XCallEnd_
"x.ok" -> Right XOk_
t -> Right . XUnknown_ $ safeDecodeUtf8 t
BFileChunk_ -> "F"
strDecode = (\(ACMEventTag _ t) -> checkEncoding t) <=< strDecode
strP = strDecode <$?> A.takeTill (== ' ')
toCMEventTag :: ChatMsgEvent -> CMEventTag
toCMEventTag = \case
instance StrEncoding ACMEventTag where
strEncode (ACMEventTag _ t) = strEncode t
strP =
((,) <$> A.peekChar' <*> A.takeTill (== ' ')) >>= \case
('x', t) -> pure . ACMEventTag SJson $ case t of
"x.msg.new" -> XMsgNew_
"x.msg.update" -> XMsgUpdate_
"x.msg.del" -> XMsgDel_
"x.msg.deleted" -> XMsgDeleted_
"x.file" -> XFile_
"x.file.acpt" -> XFileAcpt_
"x.file.acpt.inv" -> XFileAcptInv_
"x.file.cancel" -> XFileCancel_
"x.info" -> XInfo_
"x.contact" -> XContact_
"x.grp.inv" -> XGrpInv_
"x.grp.acpt" -> XGrpAcpt_
"x.grp.mem.new" -> XGrpMemNew_
"x.grp.mem.intro" -> XGrpMemIntro_
"x.grp.mem.inv" -> XGrpMemInv_
"x.grp.mem.fwd" -> XGrpMemFwd_
"x.grp.mem.info" -> XGrpMemInfo_
"x.grp.mem.role" -> XGrpMemRole_
"x.grp.mem.con" -> XGrpMemCon_
"x.grp.mem.con.all" -> XGrpMemConAll_
"x.grp.mem.del" -> XGrpMemDel_
"x.grp.leave" -> XGrpLeave_
"x.grp.del" -> XGrpDel_
"x.grp.info" -> XGrpInfo_
"x.info.probe" -> XInfoProbe_
"x.info.probe.check" -> XInfoProbeCheck_
"x.info.probe.ok" -> XInfoProbeOk_
"x.call.inv" -> XCallInv_
"x.call.offer" -> XCallOffer_
"x.call.answer" -> XCallAnswer_
"x.call.extra" -> XCallExtra_
"x.call.end" -> XCallEnd_
"x.ok" -> XOk_
_ -> XUnknown_ $ safeDecodeUtf8 t
(_, "F") -> pure $ ACMEventTag SBinary BFileChunk_
_ -> fail "bad ACMEventTag"
toCMEventTag :: ChatMsgEvent e -> CMEventTag e
toCMEventTag msg = case msg of
XMsgNew _ -> XMsgNew_
XMsgUpdate _ _ -> XMsgUpdate_
XMsgDel _ -> XMsgDel_
@ -441,18 +556,25 @@ toCMEventTag = \case
XCallEnd _ -> XCallEnd_
XOk -> XOk_
XUnknown t _ -> XUnknown_ t
BFileChunk _ _ -> BFileChunk_
cmEventTagT :: Text -> Maybe CMEventTag
cmEventTagT = eitherToMaybe . strDecode . encodeUtf8
instance MsgEncodingI e => TextEncoding (CMEventTag e) where
textEncode = decodeLatin1 . strEncode
textDecode = eitherToMaybe . strDecode . encodeUtf8
serializeCMEventTag :: CMEventTag -> Text
serializeCMEventTag = decodeLatin1 . strEncode
instance TextEncoding ACMEventTag where
textEncode (ACMEventTag _ t) = textEncode t
textDecode = eitherToMaybe . strDecode . encodeUtf8
instance FromField CMEventTag where fromField = fromTextField_ cmEventTagT
instance (MsgEncodingI e, Typeable e) => FromField (CMEventTag e) where fromField = fromTextField_ textDecode
instance ToField CMEventTag where toField = toField . serializeCMEventTag
instance MsgEncodingI e => ToField (CMEventTag e) where toField = toField . textEncode
hasNotification :: CMEventTag -> Bool
instance FromField ACMEventTag where fromField = fromTextField_ textDecode
instance ToField ACMEventTag where toField = toField . textEncode
hasNotification :: CMEventTag e -> Bool
hasNotification = \case
XMsgNew_ -> True
XFile_ -> True
@ -463,8 +585,18 @@ hasNotification = \case
XCallInv_ -> True
_ -> False
appToChatMessage :: AppMessage -> Either String ChatMessage
appToChatMessage AppMessage {msgId, event, params} = do
appBinaryToCM :: AppMessageBinary -> Either String (ChatMessage 'Binary)
appBinaryToCM AppMessageBinary {msgId, tag, body} = do
eventTag <- strDecode $ B.singleton tag
chatMsgEvent <- parseAll (msg eventTag) body
pure ChatMessage {msgId, chatMsgEvent}
where
msg :: CMEventTag 'Binary -> A.Parser (ChatMsgEvent 'Binary)
msg = \case
BFileChunk_ -> BFileChunk <$> (SharedMsgId <$> smpP) <*> (unIFC <$> smpP)
appJsonToCM :: AppMessageJson -> Either String (ChatMessage 'Json)
appJsonToCM AppMessageJson {msgId, event, params} = do
eventTag <- strDecode $ encodeUtf8 event
chatMsgEvent <- msg eventTag
pure ChatMessage {msgId, chatMsgEvent}
@ -473,6 +605,7 @@ appToChatMessage AppMessage {msgId, event, params} = do
p key = JT.parseEither (.: key) params
opt :: FromJSON a => J.Key -> Either String (Maybe a)
opt key = JT.parseEither (.:? key) params
msg :: CMEventTag 'Json -> Either String (ChatMsgEvent 'Json)
msg = \case
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content"
@ -480,7 +613,7 @@ appToChatMessage AppMessage {msgId, event, params} = do
XMsgDeleted_ -> pure XMsgDeleted
XFile_ -> XFile <$> p "file"
XFileAcpt_ -> XFileAcpt <$> p "fileName"
XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> p "fileConnReq" <*> p "fileName"
XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> opt "fileConnReq" <*> p "fileName"
XFileCancel_ -> XFileCancel <$> p "msgId"
XInfo_ -> XInfo <$> p "profile"
XContact_ -> XContact <$> p "profile" <*> opt "contactReqId"
@ -509,21 +642,29 @@ appToChatMessage AppMessage {msgId, event, params} = do
XOk_ -> pure XOk
XUnknown_ t -> pure $ XUnknown t params
chatToAppMessage :: ChatMessage -> AppMessage
chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, params}
chatToAppMessage :: forall e. MsgEncodingI e => ChatMessage e -> AppMessage e
chatToAppMessage ChatMessage {msgId, chatMsgEvent} = case encoding @e of
SBinary ->
let (binaryMsgId, body) = toBody chatMsgEvent
in AMBinary AppMessageBinary {msgId = binaryMsgId, tag = B.head $ strEncode tag, body}
SJson -> AMJson AppMessageJson {msgId, event = textEncode tag, params = params chatMsgEvent}
where
event = serializeCMEventTag . toCMEventTag $ chatMsgEvent
tag = toCMEventTag chatMsgEvent
o :: [(J.Key, J.Value)] -> J.Object
o = JM.fromList
key .=? value = maybe id ((:) . (key .=)) value
params = case chatMsgEvent of
toBody :: ChatMsgEvent 'Binary -> (Maybe SharedMsgId, ByteString)
toBody = \case
BFileChunk (SharedMsgId msgId') chunk -> (Nothing, smpEncode (msgId', IFC chunk))
params :: ChatMsgEvent 'Json -> J.Object
params = \case
XMsgNew container -> msgContainerJSON container
XMsgUpdate msgId' content -> o ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' -> o ["msgId" .= msgId']
XMsgDeleted -> JM.empty
XFile fileInv -> o ["file" .= fileInvitationJSON fileInv]
XFile fileInv -> o ["file" .= fileInv]
XFileAcpt fileName -> o ["fileName" .= fileName]
XFileAcptInv sharedMsgId fileConnReq fileName -> o ["msgId" .= sharedMsgId, "fileConnReq" .= fileConnReq, "fileName" .= fileName]
XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName]
XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId]
XInfo profile -> o ["profile" .= profile]
XContact profile xContactId -> o $ ("contactReqId" .=? xContactId) ["profile" .= profile]
@ -551,8 +692,3 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
XCallEnd callId -> o ["callId" .= callId]
XOk -> JM.empty
XUnknown _ ps -> ps
fileInvitationJSON :: FileInvitation -> J.Object
fileInvitationJSON FileInvitation {fileName, fileSize, fileConnReq} = case fileConnReq of
Nothing -> JM.fromList ["fileName" .= fileName, "fileSize" .= fileSize]
Just fConnReq -> JM.fromList ["fileName" .= fileName, "fileSize" .= fileSize, "fileConnReq" .= fConnReq]

259
src/Simplex/Chat/Store.hs
View file

@ -111,11 +111,15 @@ module Simplex.Chat.Store
matchReceivedProbeHash,
matchSentProbe,
mergeContactRecords,
createSndFileTransfer,
createSndDirectFileTransfer,
createSndDirectFTConnection,
createSndGroupFileTransfer,
createSndGroupFileTransferConnection,
createSndDirectInlineFT,
createSndGroupInlineFT,
updateSndDirectFTDelivery,
updateSndGroupFTDelivery,
getSndInlineFTViaMsgDelivery,
updateFileCancelled,
updateCIFileStatus,
getSharedMsgIdByFileId,
@ -132,6 +136,8 @@ module Simplex.Chat.Store
createRcvGroupFileTransfer,
getRcvFileTransfer,
acceptRcvFileTransfer,
acceptRcvInlineFT,
startRcvInlineFT,
updateRcvFileStatus,
createRcvFileChunk,
updatedRcvFileChunkStored,
@ -139,6 +145,7 @@ module Simplex.Chat.Store
updateFileTransferChatItemId,
getFileTransfer,
getFileTransferProgress,
getFileTransferMeta,
getSndFileTransfer,
getContactFileInfo,
getContactMaxItemTs,
@ -270,6 +277,7 @@ import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices
import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items
import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id
import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id
import Simplex.Chat.Migrations.M20221012_inline_files
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
@ -310,7 +318,8 @@ schemaMigrations =
("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices),
("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items),
("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id),
("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id)
("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id),
("20221012_inline_files", m20221012_inline_files)
]
-- | The list of migrations in ascending order by date
@ -1057,7 +1066,7 @@ getLiveSndFileTransfers db User {userId} = do
SELECT DISTINCT f.file_id
FROM files f
JOIN snd_files s
WHERE f.user_id = ? AND s.file_status IN (?, ?, ?)
WHERE f.user_id = ? AND s.file_status IN (?, ?, ?) AND s.file_inline IS NULL
|]
(userId, FSNew, FSAccepted, FSConnected)
concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds
@ -1075,7 +1084,7 @@ getLiveRcvFileTransfers db user@User {userId} = do
SELECT f.file_id
FROM files f
JOIN rcv_files r
WHERE f.user_id = ? AND r.file_status IN (?, ?)
WHERE f.user_id = ? AND r.file_status IN (?, ?) AND r.rcv_file_inline IS NULL
|]
(userId, FSAccepted, FSConnected)
rights <$> mapM (runExceptT . getRcvFileTransfer db user) fileIds
@ -1373,7 +1382,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
DB.query
db
[sql|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, cs.local_display_name, m.local_display_name
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, cs.local_display_name, m.local_display_name
FROM snd_files s
JOIN files f USING (file_id)
LEFT JOIN contacts cs USING (contact_id)
@ -1381,10 +1390,10 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ?
|]
(userId, fileId, connId)
sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, contactName_, memberName_) =
sndFileTransfer_ :: Int64 -> Int64 -> (FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer_ fileId connId (fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, contactName_, memberName_) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId}
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
getUserContact_ :: Int64 -> ExceptT StoreError IO UserContact
getUserContact_ userContactLinkId = ExceptT $ do
@ -2118,30 +2127,22 @@ getViaGroupContact db User {userId} GroupMember {groupMemberId} =
activeConn = toConnection connRow
in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, chatSettings, createdAt, updatedAt}
createSndFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> ConnId -> Integer -> IO Int64
createSndFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize} acId chunkSize = do
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Maybe ConnId -> Integer -> IO FileTransferMeta
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize, fileInline} acId_ chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, filePath, fileSize, chunkSize, fileInline, CIFSSndStored, currentTs, currentTs)
fileId <- insertedRowId db
forM_ acId_ $ \acId -> do
Connection {connId} <- createSndFileConnection_ db userId fileId acId
let fileStatus = FSNew
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, fileStatus, connId, currentTs, currentTs)
pure fileId
createSndDirectFileTransfer :: DB.Connection -> UserId -> Contact -> FilePath -> FileInvitation -> Integer -> IO Int64
createSndDirectFileTransfer db userId Contact {contactId} filePath FileInvitation {fileName, fileSize} chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
insertedRowId db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, fileStatus, fileInline, connId, currentTs, currentTs)
pure FileTransferMeta {fileId, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndDirectFTConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> IO ()
createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do
@ -2153,14 +2154,15 @@ createSndDirectFTConnection db user@User {userId} fileId (cmdId, acId) = do
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, FSAccepted, connId, currentTs, currentTs)
createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO Int64
createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize} chunkSize = do
createSndGroupFileTransfer :: DB.Connection -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> IO FileTransferMeta
createSndGroupFileTransfer db userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize, fileInline} chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, filePath, fileSize, chunkSize, CIFSSndStored, currentTs, currentTs)
insertedRowId db
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, filePath, fileSize, chunkSize, fileInline, CIFSSndStored, currentTs, currentTs)
fileId <- insertedRowId db
pure FileTransferMeta {fileId, fileName, filePath, fileSize, fileInline, chunkSize, cancelled = False}
createSndGroupFileTransferConnection :: DB.Connection -> User -> Int64 -> (CommandId, ConnId) -> GroupMember -> IO ()
createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId) GroupMember {groupMemberId} = do
@ -2172,6 +2174,63 @@ createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId)
"INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs)
createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer
createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
currentTs <- getCurrentTime
let fileStatus = FSConnected
fileInline' = Just $ fromMaybe (IFMOffer) fileInline
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, fileStatus, fileInline', connId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, fileStatus, fileInline = fileInline'}
createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> IO SndFileTransfer
createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
currentTs <- getCurrentTime
let fileStatus = FSConnected
fileInline' = Just $ fromMaybe (IFMOffer) fileInline
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, fileStatus, fileInline = fileInline'}
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO ()
updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, connId, fileId)
updateSndGroupFTDelivery :: DB.Connection -> GroupMember -> Connection -> FileTransferMeta -> Int64 -> IO ()
updateSndGroupFTDelivery db GroupMember {groupMemberId} Connection {connId} FileTransferMeta {fileId} msgDeliveryId =
DB.execute
db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE group_member_id = ? AND connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
(msgDeliveryId, groupMemberId, connId, fileId)
getSndInlineFTViaMsgDelivery :: DB.Connection -> User -> Connection -> AgentMsgId -> IO (Maybe SndFileTransfer)
getSndInlineFTViaMsgDelivery db User {userId} Connection {connId, agentConnId} agentMsgId = do
(sndFileTransfer_ <=< listToMaybe)
<$> DB.query
db
[sql|
SELECT s.file_id, s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, c.local_display_name, m.local_display_name
FROM msg_deliveries d
JOIN snd_files s ON s.connection_id = d.connection_id AND s.last_inline_msg_delivery_id = d.msg_delivery_id
JOIN files f ON f.file_id = s.file_id
LEFT JOIN contacts c USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE d.connection_id = ? AND d.agent_msg_id = ? AND f.user_id = ? AND s.file_inline IS NOT NULL
|]
(connId, agentMsgId, userId)
where
sndFileTransfer_ :: (Int64, FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe ContactName, Maybe ContactName) -> Maybe SndFileTransfer
sndFileTransfer_ (fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, contactName_, memberName_) =
(\n -> SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName = n, connId, agentConnId})
<$> (contactName_ <|> memberName_)
updateFileCancelled :: MsgDirectionI d => DB.Connection -> User -> Int64 -> CIFileStatus d -> IO ()
updateFileCancelled db User {userId} fileId ciFileStatus = do
currentTs <- getCurrentTime
@ -2308,43 +2367,44 @@ deleteSndFileChunks :: DB.Connection -> SndFileTransfer -> IO ()
deleteSndFileChunks db SndFileTransfer {fileId, connId} =
DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId)
createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Integer -> IO RcvFileTransfer
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize = do
createRcvFileTransfer :: DB.Connection -> UserId -> Contact -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer
createRcvFileTransfer db userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline} rcvFileInline chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, fileSize, chunkSize, CIFSRcvInvitation, currentTs, currentTs)
"INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, currentTs, currentTs)
fileId <- insertedRowId db
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, FSNew, fileConnReq, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Integer -> IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize = do
createRcvGroupFileTransfer :: DB.Connection -> UserId -> GroupMember -> FileInvitation -> Maybe InlineFileMode -> Integer -> IO RcvFileTransfer
createRcvGroupFileTransfer db userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq, fileInline} rcvFileInline chunkSize = do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, fileSize, chunkSize, CIFSRcvInvitation, currentTs, currentTs)
"INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size, file_inline, ci_file_status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, fileSize, chunkSize, fileInline, CIFSRcvInvitation, currentTs, currentTs)
fileId <- insertedRowId db
DB.execute
db
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, groupMemberId, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
"INSERT INTO rcv_files (file_id, file_status, file_queue_info, file_inline, rcv_file_inline, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(fileId, FSNew, fileConnReq, fileInline, rcvFileInline, groupMemberId, currentTs, currentTs)
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, rcvFileInline, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
getRcvFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO RcvFileTransfer
getRcvFileTransfer db User {userId} fileId =
ExceptT . firstRow' rcvFileTransfer (SERcvFileNotFound fileId) $
getRcvFileTransfer db user@User {userId} fileId = do
rftRow <-
ExceptT . firstRow id (SERcvFileNotFound fileId) $
DB.query
db
[sql|
SELECT r.file_status, r.file_queue_info, r.group_member_id, f.file_name,
f.file_size, f.chunk_size, f.cancelled, cs.local_display_name, m.local_display_name,
f.file_path, c.connection_id, c.agent_conn_id
f.file_size, f.chunk_size, f.cancelled, cs.contact_id, cs.local_display_name, m.group_id, m.group_member_id, m.local_display_name,
f.file_path, r.file_inline, r.rcv_file_inline, c.connection_id, c.agent_conn_id
FROM rcv_files r
JOIN files f USING (file_id)
LEFT JOIN connections c ON r.file_id = c.rcv_file_id
@ -2353,34 +2413,61 @@ getRcvFileTransfer db User {userId} fileId =
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
rcvFileTransfer rftRow
where
rcvFileTransfer ::
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe AgentConnId) ->
Either StoreError RcvFileTransfer
rcvFileTransfer (fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_, contactName_, memberName_, filePath_, connId_, agentConnId_) =
let fileInv = FileInvitation {fileName, fileSize, fileConnReq}
fileInfo = (filePath_, connId_, agentConnId_)
in case contactName_ <|> memberName_ of
Nothing -> Left $ SERcvFileInvalid fileId
Just name ->
(FileStatus, Maybe ConnReqInvitation, Maybe Int64, String, Integer, Integer, Maybe Bool) :. (Maybe Int64, Maybe ContactName, Maybe Int64, Maybe Int64, Maybe ContactName, Maybe FilePath, Maybe InlineFileMode, Maybe InlineFileMode) :. (Maybe Int64, Maybe AgentConnId) ->
ExceptT StoreError IO RcvFileTransfer
rcvFileTransfer ((fileStatus', fileConnReq, grpMemberId, fileName, fileSize, chunkSize, cancelled_) :. (contactId_, contactName_, groupId_, groupMemberId_, memberName_, filePath_, fileInline, rcvFileInline) :. (connId_, agentConnId_)) = do
let fileInv = FileInvitation {fileName, fileSize, fileConnReq, fileInline}
fileInfo = (filePath_, connId_, agentConnId_, contactId_, groupId_, groupMemberId_, isJust fileInline)
case contactName_ <|> memberName_ of
Nothing -> throwError $ SERcvFileInvalid fileId
Just name -> do
case fileStatus' of
FSNew -> ft name fileInv RFSNew
FSAccepted -> ft name fileInv . RFSAccepted =<< rfi fileInfo
FSConnected -> ft name fileInv . RFSConnected =<< rfi fileInfo
FSComplete -> ft name fileInv . RFSComplete =<< rfi fileInfo
FSCancelled -> ft name fileInv . RFSCancelled $ rfi_ fileInfo
FSNew -> pure $ ft name fileInv RFSNew
FSAccepted -> ft name fileInv . RFSAccepted <$> rfi fileInfo
FSConnected -> ft name fileInv . RFSConnected <$> rfi fileInfo
FSComplete -> ft name fileInv . RFSComplete <$> rfi fileInfo
FSCancelled -> ft name fileInv . RFSCancelled <$> rfi_ fileInfo
where
ft senderDisplayName fileInvitation fileStatus =
Right RcvFileTransfer {fileId, fileInvitation, fileStatus, senderDisplayName, chunkSize, cancelled, grpMemberId}
rfi fileInfo = maybe (Left $ SERcvFileInvalid fileId) Right $ rfi_ fileInfo
RcvFileTransfer {fileId, fileInvitation, fileStatus, rcvFileInline, senderDisplayName, chunkSize, cancelled, grpMemberId}
rfi fileInfo = maybe (throwError $ SERcvFileInvalid fileId) pure =<< rfi_ fileInfo
rfi_ = \case
(Just filePath, Just connId, Just agentConnId) -> Just RcvFileInfo {filePath, connId, agentConnId}
_ -> Nothing
(Just filePath, Just connId, Just agentConnId, _, _, _, _) -> pure $ Just RcvFileInfo {filePath, connId, agentConnId}
(Just filePath, Nothing, Nothing, Just contactId, _, _, True) -> do
Contact {activeConn = Connection {connId, agentConnId}} <- getContact db userId contactId
pure $ Just RcvFileInfo {filePath, connId, agentConnId}
(Just filePath, Nothing, Nothing, _, Just groupId, Just groupMemberId, True) -> do
getGroupMember db user groupId groupMemberId >>= \case
GroupMember {activeConn = Just Connection {connId, agentConnId}} ->
pure $ Just RcvFileInfo {filePath, connId, agentConnId}
_ -> pure Nothing
_ -> pure Nothing
cancelled = fromMaybe False cancelled_
acceptRcvFileTransfer :: DB.Connection -> User -> Int64 -> ConnId -> ConnStatus -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvFileTransfer db user@User {userId} fileId agentConnId connStatus filePath = ExceptT $ do
currentTs <- getCurrentTime
acceptRcvFT_ db user fileId filePath currentTs
DB.execute
db
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(agentConnId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs)
runExceptT $ getChatItemByFileId db user fileId
acceptRcvInlineFT :: DB.Connection -> User -> Int64 -> FilePath -> ExceptT StoreError IO AChatItem
acceptRcvInlineFT db user fileId filePath = do
liftIO $ acceptRcvFT_ db user fileId filePath =<< getCurrentTime
getChatItemByFileId db user fileId
startRcvInlineFT :: DB.Connection -> User -> RcvFileTransfer -> FilePath -> IO ()
startRcvInlineFT db user RcvFileTransfer {fileId} filePath =
acceptRcvFT_ db user fileId filePath =<< getCurrentTime
acceptRcvFT_ :: DB.Connection -> User -> Int64 -> FilePath -> UTCTime -> IO ()
acceptRcvFT_ db User {userId} fileId filePath currentTs = do
DB.execute
db
"UPDATE files SET file_path = ?, ci_file_status = ?, updated_at = ? WHERE user_id = ? AND file_id = ?"
@ -2389,11 +2476,6 @@ acceptRcvFileTransfer db user@User {userId} fileId agentConnId connStatus filePa
db
"UPDATE rcv_files SET file_status = ?, updated_at = ? WHERE file_id = ?"
(FSAccepted, currentTs, fileId)
DB.execute
db
"INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
(agentConnId, connStatus, ConnRcvFile, fileId, userId, currentTs, currentTs)
runExceptT $ getChatItemByFileId db user fileId
updateRcvFileStatus :: DB.Connection -> RcvFileTransfer -> FileStatus -> IO ()
updateRcvFileStatus db RcvFileTransfer {fileId} status = do
@ -2485,18 +2567,18 @@ getFileTransfer db user@User {userId} fileId =
(userId, fileId)
getSndFileTransfer :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO (FileTransferMeta, [SndFileTransfer])
getSndFileTransfer db User {userId} fileId = do
fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId
getSndFileTransfer db user@User {userId} fileId = do
fileTransferMeta <- getFileTransferMeta db user fileId
sndFileTransfers <- ExceptT $ getSndFileTransfers_ db userId fileId
pure (fileTransferMeta, sndFileTransfers)
getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer])
getSndFileTransfers_ db userId fileId =
sndFileTransfers
mapM sndFileTransfer
<$> DB.query
db
[sql|
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.connection_id, c.agent_conn_id,
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, s.file_inline, s.connection_id, c.agent_conn_id,
cs.local_display_name, m.local_display_name
FROM snd_files s
JOIN files f USING (file_id)
@ -2507,29 +2589,27 @@ getSndFileTransfers_ db userId fileId =
|]
(userId, fileId)
where
sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, AgentConnId, Maybe ContactName, Maybe ContactName)] -> Either StoreError [SndFileTransfer]
sndFileTransfers [] = Right []
sndFileTransfers fts = mapM sndFileTransfer fts
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId, contactName_, memberName_) =
sndFileTransfer :: (FileStatus, String, Integer, Integer, FilePath, Maybe InlineFileMode, Int64, AgentConnId, Maybe ContactName, Maybe ContactName) -> Either StoreError SndFileTransfer
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, connId, agentConnId, contactName_, memberName_) =
case contactName_ <|> memberName_ of
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId}
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, fileInline, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
getFileTransferMeta_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError FileTransferMeta)
getFileTransferMeta_ db userId fileId =
firstRow fileTransferMeta (SEFileNotFound fileId) $
getFileTransferMeta :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO FileTransferMeta
getFileTransferMeta db User {userId} fileId =
ExceptT . firstRow fileTransferMeta (SEFileNotFound fileId) $
DB.query
db
[sql|
SELECT f.file_name, f.file_size, f.chunk_size, f.file_path, f.cancelled
SELECT f.file_name, f.file_size, f.chunk_size, f.file_path, f.file_inline, f.cancelled
FROM files f
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
where
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, cancelled_) =
FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, cancelled = fromMaybe False cancelled_}
fileTransferMeta :: (String, Integer, Integer, FilePath, Maybe InlineFileMode, Maybe Bool) -> FileTransferMeta
fileTransferMeta (fileName, fileSize, chunkSize, filePath, fileInline, cancelled_) =
FileTransferMeta {fileId, fileName, fileSize, chunkSize, filePath, fileInline, cancelled = fromMaybe False cancelled_}
getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
getContactFileInfo db User {userId} Contact {contactId} =
@ -2601,7 +2681,7 @@ updateGroupTs db User {userId} GroupInfo {groupId} updatedAt =
"UPDATE groups SET updated_at = ? WHERE user_id = ? AND group_id = ?"
(updatedAt, userId, groupId)
createNewSndMessage :: DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> ExceptT StoreError IO SndMessage
createNewSndMessage :: MsgEncodingI e => DB.Connection -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage e) -> ExceptT StoreError IO SndMessage
createNewSndMessage db gVar connOrGroupId mkMessage =
createWithRandomId gVar $ \sharedMsgId -> do
let NewMessage {chatMsgEvent, msgBody} = mkMessage $ SharedMsgId sharedMsgId
@ -2622,13 +2702,14 @@ createNewSndMessage db gVar connOrGroupId mkMessage =
ConnectionId connId -> (Just connId, Nothing)
GroupId groupId -> (Nothing, Just groupId)
createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO ()
createSndMsgDelivery :: DB.Connection -> SndMsgDelivery -> MessageId -> IO Int64
createSndMsgDelivery db sndMsgDelivery messageId = do
currentTs <- getCurrentTime
msgDeliveryId <- createSndMsgDelivery_ db sndMsgDelivery messageId currentTs
createMsgDeliveryEvent_ db msgDeliveryId MDSSndAgent currentTs
pure msgDeliveryId
createNewMessageAndRcvMsgDelivery :: DB.Connection -> ConnOrGroupId -> NewMessage -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage
createNewMessageAndRcvMsgDelivery :: forall e. MsgEncodingI e => DB.Connection -> ConnOrGroupId -> NewMessage e -> Maybe SharedMsgId -> RcvMsgDelivery -> IO RcvMessage
createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msgBody} sharedMsgId_ RcvMsgDelivery {connId, agentMsgId, agentMsgMeta, agentAckCmdId} = do
currentTs <- getCurrentTime
DB.execute
@ -2642,7 +2723,7 @@ createNewMessageAndRcvMsgDelivery db connOrGroupId NewMessage {chatMsgEvent, msg
(msgId, connId, agentMsgId, msgMetaJson agentMsgMeta, agentAckCmdId, snd $ broker agentMsgMeta, currentTs, currentTs)
msgDeliveryId <- insertedRowId db
createMsgDeliveryEvent_ db msgDeliveryId MDSRcvAgent currentTs
pure RcvMessage {msgId, chatMsgEvent, sharedMsgId_, msgBody}
pure RcvMessage {msgId, chatMsgEvent = ACME (encoding @e) chatMsgEvent, sharedMsgId_, msgBody}
where
(connId_, groupId_) = case connOrGroupId of
ConnectionId connId' -> (Just connId', Nothing)

42
src/Simplex/Chat/Types.hs
View file

@ -613,7 +613,8 @@ data SndFileTransfer = SndFileTransfer
recipientDisplayName :: ContactName,
connId :: Int64,
agentConnId :: AgentConnId,
fileStatus :: FileStatus
fileStatus :: FileStatus,
fileInline :: Maybe InlineFileMode
}
deriving (Eq, Show, Generic)
@ -627,16 +628,48 @@ type FileTransferId = Int64
data FileInvitation = FileInvitation
{ fileName :: String,
fileSize :: Integer,
fileConnReq :: Maybe ConnReqInvitation
fileConnReq :: Maybe ConnReqInvitation,
fileInline :: Maybe InlineFileMode
}
deriving (Eq, Show, Generic, FromJSON)
deriving (Eq, Show, Generic)
instance ToJSON FileInvitation where toEncoding = J.genericToEncoding J.defaultOptions
instance ToJSON FileInvitation where
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
instance FromJSON FileInvitation where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
data InlineFileMode
= IFMOffer -- file will be sent inline once accepted
| IFMSent -- file is sent inline without acceptance
deriving (Eq, Show, Generic)
instance TextEncoding InlineFileMode where
textEncode = \case
IFMOffer -> "offer"
IFMSent -> "sent"
textDecode = \case
"offer" -> Just IFMOffer
"sent" -> Just IFMSent
_ -> Nothing
instance FromField InlineFileMode where fromField = fromTextField_ textDecode
instance ToField InlineFileMode where toField = toField . textEncode
instance FromJSON InlineFileMode where
parseJSON = J.withText "InlineFileMode" $ maybe (fail "bad InlineFileMode") pure . textDecode
instance ToJSON InlineFileMode where
toJSON = J.String . textEncode
toEncoding = JE.text . textEncode
data RcvFileTransfer = RcvFileTransfer
{ fileId :: FileTransferId,
fileInvitation :: FileInvitation,
fileStatus :: RcvFileStatus,
rcvFileInline :: Maybe InlineFileMode,
senderDisplayName :: ContactName,
chunkSize :: Integer,
cancelled :: Bool,
@ -724,6 +757,7 @@ data FileTransferMeta = FileTransferMeta
fileName :: String,
filePath :: String,
fileSize :: Integer,
fileInline :: Maybe InlineFileMode,
chunkSize :: Integer,
cancelled :: Bool
}

41
src/Simplex/Chat/View.hs
View file

@ -241,7 +241,7 @@ showSMPServer = B.unpack . strEncode . host
viewHostEvent :: AProtocolType -> TransportHost -> String
viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h)
viewChatItem :: MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> [StyledString]
viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> [StyledString]
viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} doShow = case chat of
DirectChat c -> case chatDir of
CIDirectSnd -> case content of
@ -748,9 +748,14 @@ viewSentBroadcast :: MsgContent -> Int -> ZonedTime -> [StyledString]
viewSentBroadcast mc n ts = prependFirst (highlight' "/feed" <> " (" <> sShow n <> ") " <> ttyMsgTime ts <> " ") (ttyMsgContent mc)
viewSentFileInvitation :: StyledString -> CIFile d -> CIMeta d -> [StyledString]
viewSentFileInvitation to CIFile {fileId, filePath} = case filePath of
Just fPath -> sentWithTime_ $ ttySentFile to fileId fPath
viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} = case filePath of
Just fPath -> sentWithTime_ $ ttySentFile fPath
_ -> const []
where
ttySentFile fPath = ["/f " <> to <> ttyFilePath fPath] <> cancelSending
cancelSending = case fileStatus of
CIFSSndTransfer -> []
_ -> ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
sentWithTime_ :: [StyledString] -> CIMeta d -> [StyledString]
sentWithTime_ styledMsg CIMeta {localItemTs} =
@ -762,9 +767,6 @@ ttyMsgTime = styleTime . formatTime defaultTimeLocale "%H:%M"
ttyMsgContent :: MsgContent -> [StyledString]
ttyMsgContent = msgPlain . msgContentText
ttySentFile :: StyledString -> FileTransferId -> FilePath -> [StyledString]
ttySentFile to fId fPath = ["/f " <> to <> ttyFilePath fPath, "use " <> highlight ("/fc " <> show fId) <> " to cancel sending"]
prependFirst :: StyledString -> [StyledString] -> [StyledString]
prependFirst s [] = [s]
prependFirst s (s' : ss) = (s <> s') : ss
@ -793,21 +795,11 @@ viewReceivedFileInvitation :: StyledString -> CIFile d -> CIMeta d -> [StyledStr
viewReceivedFileInvitation from file meta = receivedWithTime_ from [] meta (receivedFileInvitation_ file)
receivedFileInvitation_ :: CIFile d -> [StyledString]
receivedFileInvitation_ CIFile {fileId, fileName, fileSize} =
[ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)",
-- below is printed for auto-accepted files as well; auto-accept is disabled in terminal though so in reality it never happens
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
]
-- TODO remove
viewReceivedFileInvitation' :: StyledString -> RcvFileTransfer -> CIMeta d -> [StyledString]
viewReceivedFileInvitation' from RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} meta = receivedWithTime_ from [] meta (receivedFileInvitation_' fileId fileName fileSize)
receivedFileInvitation_' :: Int64 -> String -> Integer -> [StyledString]
receivedFileInvitation_' fileId fileName fileSize =
[ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)",
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
]
receivedFileInvitation_ CIFile {fileId, fileName, fileSize, fileStatus} =
["sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)"]
<> case fileStatus of
CIFSRcvAccepted -> []
_ -> ["use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"]
humanReadableSize :: Integer -> StyledString
humanReadableSize size
@ -849,9 +841,8 @@ fileTransferStr fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath
viewFileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
viewFileTransferStatus (FTSnd FileTransferMeta {fileId, fileName, cancelled} [], _) =
[ "sending " <> fileTransferStr fileId fileName <> ": no file transfers"
<> if cancelled then ", file transfer cancelled" else ""
]
["sending " <> fileTransferStr fileId fileName <> ": no file transfers"]
<> ["file transfer cancelled" | cancelled]
viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksNum) =
recipientStatuses <> ["file transfer cancelled" | cancelled]
where
@ -978,7 +969,7 @@ viewChatError = \case
CEGroupCantResendInvitation g c -> viewCannotResendInvitation g c
CEGroupInternal s -> ["chat group bug: " <> plain s]
CEFileNotFound f -> ["file not found: " <> plain f]
CEFileAlreadyReceiving f -> ["file is already accepted: " <> plain f]
CEFileAlreadyReceiving f -> ["file is already being received: " <> plain f]
CEFileCancelled f -> ["file cancelled: " <> plain f]
CEFileAlreadyExists f -> ["file already exists: " <> plain f]
CEFileRead f e -> ["cannot read file " <> plain f, sShow e]

7
tests/ChatClient.hs
View file

@ -13,6 +13,7 @@ import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception (bracket, bracket_)
import Control.Monad.Except
import Data.Functor (($>))
import Data.List (dropWhileEnd, find)
import Data.Maybe (fromJust, isNothing)
import qualified Data.Text as T
@ -145,7 +146,11 @@ withNewTestChatOpts :: ChatOpts -> String -> Profile -> (TestCC -> IO a) -> IO a
withNewTestChatOpts = withNewTestChatCfgOpts testCfg
withNewTestChatCfgOpts :: ChatConfig -> ChatOpts -> String -> Profile -> (TestCC -> IO a) -> IO a
withNewTestChatCfgOpts cfg opts dbPrefix profile = bracket (createTestChat cfg opts dbPrefix profile) (\cc -> cc <// 100000 >> stopTestChat cc)
withNewTestChatCfgOpts cfg opts dbPrefix profile runTest =
bracket
(createTestChat cfg opts dbPrefix profile)
stopTestChat
(\cc -> runTest cc >>= ((cc <// 100000) $>))
withTestChatV1 :: String -> (TestCC -> IO a) -> IO a
withTestChatV1 = withTestChatCfg testCfgV1

271
tests/ChatTests.hs
View file

@ -1,7 +1,9 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PostfixOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module ChatTests where
@ -9,15 +11,18 @@ import ChatClient
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_)
import Control.Concurrent.STM
import Control.Monad (forM_, when)
import Control.Monad (forM_, unless, when)
import Data.Aeson (ToJSON)
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isDigit)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import Data.String
import qualified Data.Text as T
import Simplex.Chat.Call
import Simplex.Chat.Controller (ChatController (..))
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), InlineFilesConfig (..), defaultInlineFilesConfig)
import Simplex.Chat.Options (ChatOpts (..))
import Simplex.Chat.Types (ConnStatus (..), GroupMemberRole (..), ImageData (..), LocalProfile (..), Profile (..), User (..))
import Simplex.Messaging.Encoding.String
@ -66,15 +71,17 @@ chatTests = do
it "update user profiles and notify contacts" testUpdateProfile
it "update user profile with image" testUpdateProfileImage
describe "sending and receiving files" $ do
it "send and receive file" testFileTransfer
it "send and receive a small file" testSmallFileTransfer
it "sender cancelled file transfer before transfer" testFileSndCancelBeforeTransfer
describe "send and receive file" $ fileTestMatrix2 runTestFileTransfer
it "send and receive file inline (without accepting)" testInlineFileTransfer
describe "send and receive a small file" $ fileTestMatrix2 runTestSmallFileTransfer
describe "sender cancelled file transfer before transfer" $ fileTestMatrix2 runTestFileSndCancelBeforeTransfer
it "sender cancelled file transfer during transfer" testFileSndCancelDuringTransfer
it "recipient cancelled file transfer" testFileRcvCancel
it "send and receive file to group" testGroupFileTransfer
it "sender cancelled group file transfer before transfer" testGroupFileSndCancelBeforeTransfer
describe "send and receive file to group" $ fileTestMatrix3 runTestGroupFileTransfer
it "send and receive file inline to group (without accepting)" testInlineGroupFileTransfer
describe "sender cancelled group file transfer before transfer" $ fileTestMatrix3 runTestGroupFileSndCancelBeforeTransfer
describe "messages with files" $ do
it "send and receive message with file" testMessageWithFile
describe "send and receive message with file" $ fileTestMatrix2 runTestMessageWithFile
it "send and receive image" testSendImage
it "files folder: send and receive image" testFilesFoldersSendImage
it "files folder: sender deleted file during transfer" testFilesFoldersImageSndDelete
@ -133,40 +140,56 @@ versionTestMatrix2 :: (TestCC -> TestCC -> IO ()) -> Spec
versionTestMatrix2 runTest = do
it "v2" $ testChat2 aliceProfile bobProfile runTest
it "v1" $ testChatCfg2 testCfgV1 aliceProfile bobProfile runTest
it "v1 to v2" . withTmpFiles $
withNewTestChat "alice" aliceProfile $ \alice ->
withNewTestChatV1 "bob" bobProfile $ \bob ->
runTest alice bob
it "v2 to v1" . withTmpFiles $
withNewTestChatV1 "alice" aliceProfile $ \alice ->
withNewTestChat "bob" bobProfile $ \bob ->
runTest alice bob
it "v1 to v2" $ runTestCfg2 testCfg testCfgV1 runTest
it "v2 to v1" $ runTestCfg2 testCfgV1 testCfg runTest
versionTestMatrix3 :: (TestCC -> TestCC -> TestCC -> IO ()) -> Spec
versionTestMatrix3 runTest = do
it "v2" $ testChat3 aliceProfile bobProfile cathProfile runTest
-- it "v1" $ testChatCfg3 testCfgV1 aliceProfile bobProfile cathProfile runTest
-- it "v1 to v2" . withTmpFiles $
-- withNewTestChat "alice" aliceProfile $ \alice ->
-- withNewTestChatV1 "bob" bobProfile $ \bob ->
-- withNewTestChatV1 "cath" cathProfile $ \cath ->
-- runTest alice bob cath
-- it "v2+v1 to v2" . withTmpFiles $
-- withNewTestChat "alice" aliceProfile $ \alice ->
-- withNewTestChat "bob" bobProfile $ \bob ->
-- withNewTestChatV1 "cath" cathProfile $ \cath ->
-- runTest alice bob cath
-- it "v2 to v1" . withTmpFiles $
-- withNewTestChatV1 "alice" aliceProfile $ \alice ->
-- withNewTestChat "bob" bobProfile $ \bob ->
-- withNewTestChat "cath" cathProfile $ \cath ->
-- runTest alice bob cath
-- it "v2+v1 to v1" . withTmpFiles $
-- withNewTestChatV1 "alice" aliceProfile $ \alice ->
-- withNewTestChat "bob" bobProfile $ \bob ->
-- withNewTestChatV1 "cath" cathProfile $ \cath ->
-- runTest alice bob cath
-- it "v1 to v2" $ runTestCfg3 testCfg testCfgV1 testCfgV1 runTest
-- it "v2+v1 to v2" $ runTestCfg3 testCfg testCfg testCfgV1 runTest
-- it "v2 to v1" $ runTestCfg3 testCfgV1 testCfg testCfg runTest
-- it "v2+v1 to v1" $ runTestCfg3 testCfgV1 testCfg testCfgV1 runTest
inlineCfg :: Integer -> ChatConfig
inlineCfg n = testCfg {inlineFiles = defaultInlineFilesConfig {offerChunks = n, receiveChunks = n}}
fileTestMatrix2 :: (TestCC -> TestCC -> IO ()) -> Spec
fileTestMatrix2 runTest = do
it "via connection" $ runTestCfg2 viaConn viaConn runTest
it "inline (accepting)" $ runTestCfg2 inline inline runTest
it "via connection (inline offered)" $ runTestCfg2 inline viaConn runTest
it "via connection (inline supported)" $ runTestCfg2 viaConn inline runTest
where
inline = inlineCfg 100
viaConn = inlineCfg 0
fileTestMatrix3 :: (TestCC -> TestCC -> TestCC -> IO ()) -> Spec
fileTestMatrix3 runTest = do
it "via connection" $ runTestCfg3 viaConn viaConn viaConn runTest
it "inline" $ runTestCfg3 inline inline inline runTest
it "via connection (inline offered)" $ runTestCfg3 inline viaConn viaConn runTest
it "via connection (inline supported)" $ runTestCfg3 viaConn inline inline runTest
where
inline = inlineCfg 100
viaConn = inlineCfg 0
runTestCfg2 :: ChatConfig -> ChatConfig -> (TestCC -> TestCC -> IO ()) -> IO ()
runTestCfg2 aliceCfg bobCfg runTest =
withTmpFiles $
withNewTestChatCfg aliceCfg "alice" aliceProfile $ \alice ->
withNewTestChatCfg bobCfg "bob" bobProfile $ \bob ->
runTest alice bob
runTestCfg3 :: ChatConfig -> ChatConfig -> ChatConfig -> (TestCC -> TestCC -> TestCC -> IO ()) -> IO ()
runTestCfg3 aliceCfg bobCfg cathCfg runTest =
withTmpFiles $
withNewTestChatCfg aliceCfg "alice" aliceProfile $ \alice ->
withNewTestChatCfg bobCfg "bob" bobProfile $ \bob ->
withNewTestChatCfg cathCfg "cath" cathProfile $ \cath ->
runTest alice bob cath
testAddContact :: Spec
testAddContact = versionTestMatrix2 runTestAddContact
@ -1351,28 +1374,47 @@ testUpdateProfileImage =
bob <## "use @alice2 <message> to send messages"
(bob </)
testFileTransfer :: IO ()
testFileTransfer =
testChat2 aliceProfile bobProfile $
\alice bob -> do
runTestFileTransfer :: TestCC -> TestCC -> IO ()
runTestFileTransfer alice bob = do
connectUsers alice bob
startFileTransfer alice bob
startFileTransfer' alice bob "test.pdf" "266.0 KiB / 272376 bytes"
concurrentlyN_
[ do
bob #> "@alice receiving here..."
bob <## "completed receiving file 1 (test.jpg) from alice",
do
alice <# "bob> receiving here..."
alice <## "completed sending file 1 (test.jpg) to bob"
bob <## "completed receiving file 1 (test.pdf) from alice",
alice
<### [ WithTime "bob> receiving here...",
"completed sending file 1 (test.pdf) to bob"
]
]
src <- B.readFile "./tests/fixtures/test.pdf"
dest <- B.readFile "./tests/tmp/test.pdf"
dest `shouldBe` src
testInlineFileTransfer :: IO ()
testInlineFileTransfer =
testChatCfg2 cfg aliceProfile bobProfile $ \alice bob -> do
connectUsers alice bob
bob ##> "/_files_folder ./tests/tmp/"
bob <## "ok"
alice #> "/f @bob ./tests/fixtures/test.jpg"
-- below is not shown in "sent" mode
-- alice <## "use /fc 1 to cancel sending"
bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
-- below is not shown in "sent" mode
-- bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
bob <## "started receiving file 1 (test.jpg) from alice"
concurrently_
(alice <## "completed sending file 1 (test.jpg) to bob")
(bob <## "completed receiving file 1 (test.jpg) from alice")
src <- B.readFile "./tests/fixtures/test.jpg"
dest <- B.readFile "./tests/tmp/test.jpg"
dest `shouldBe` src
where
cfg = testCfg {inlineFiles = defaultInlineFilesConfig {offerChunks = 100, sendChunks = 100, receiveChunks = 100}}
testSmallFileTransfer :: IO ()
testSmallFileTransfer =
testChat2 aliceProfile bobProfile $
\alice bob -> do
runTestSmallFileTransfer :: TestCC -> TestCC -> IO ()
runTestSmallFileTransfer alice bob = do
connectUsers alice bob
alice #> "/f @bob ./tests/fixtures/test.txt"
alice <## "use /fc 1 to cancel sending"
@ -1392,10 +1434,8 @@ testSmallFileTransfer =
dest <- B.readFile "./tests/tmp/test.txt"
dest `shouldBe` src
testFileSndCancelBeforeTransfer :: IO ()
testFileSndCancelBeforeTransfer =
testChat2 aliceProfile bobProfile $
\alice bob -> do
runTestFileSndCancelBeforeTransfer :: TestCC -> TestCC -> IO ()
runTestFileSndCancelBeforeTransfer alice bob = do
connectUsers alice bob
alice #> "/f @bob ./tests/fixtures/test.txt"
alice <## "use /fc 1 to cancel sending"
@ -1403,11 +1443,14 @@ testFileSndCancelBeforeTransfer =
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
alice ##> "/fc 1"
concurrentlyN_
[ alice <## "cancelled sending file 1 (test.txt) to bob",
[ alice <##. "cancelled sending file 1 (test.txt)",
bob <## "alice cancelled sending file 1 (test.txt)"
]
alice ##> "/fs 1"
alice <## "sending file 1 (test.txt) cancelled: bob"
alice
<##.. [ "sending file 1 (test.txt): no file transfers",
"sending file 1 (test.txt) cancelled: bob"
]
alice <## "file transfer cancelled"
bob ##> "/fs 1"
bob <## "receiving file 1 (test.txt) cancelled"
@ -1456,10 +1499,8 @@ testFileRcvCancel =
]
checkPartialTransfer "test.jpg"
testGroupFileTransfer :: IO ()
testGroupFileTransfer =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
runTestGroupFileTransfer :: TestCC -> TestCC -> TestCC -> IO ()
runTestGroupFileTransfer alice bob cath = do
createGroup3 "team" alice bob cath
alice #> "/f #team ./tests/fixtures/test.jpg"
alice <## "use /fc 1 to cancel sending"
@ -1497,11 +1538,51 @@ testGroupFileTransfer =
cath <## "started receiving file 1 (test.jpg) from alice"
cath <## "completed receiving file 1 (test.jpg) from alice"
]
src <- B.readFile "./tests/fixtures/test.jpg"
dest1 <- B.readFile "./tests/tmp/test.jpg"
dest2 <- B.readFile "./tests/tmp/test_1.jpg"
dest1 `shouldBe` src
dest2 `shouldBe` src
testGroupFileSndCancelBeforeTransfer :: IO ()
testGroupFileSndCancelBeforeTransfer =
testChat3 aliceProfile bobProfile cathProfile $
testInlineGroupFileTransfer :: IO ()
testInlineGroupFileTransfer =
testChatCfg3 cfg aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
bob ##> "/_files_folder ./tests/tmp/bob/"
bob <## "ok"
cath ##> "/_files_folder ./tests/tmp/cath/"
cath <## "ok"
alice #> "/f #team ./tests/fixtures/test.jpg"
-- below is not shown in "sent" mode
-- alice <## "use /fc 1 to cancel sending"
concurrentlyN_
[ do
alice
<### [ "completed sending file 1 (test.jpg) to bob",
"completed sending file 1 (test.jpg) to cath"
]
alice ##> "/fs 1"
alice <##. "sending file 1 (test.jpg) complete",
do
bob <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
bob <## "started receiving file 1 (test.jpg) from alice"
bob <## "completed receiving file 1 (test.jpg) from alice",
do
cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
cath <## "started receiving file 1 (test.jpg) from alice"
cath <## "completed receiving file 1 (test.jpg) from alice"
]
src <- B.readFile "./tests/fixtures/test.jpg"
dest1 <- B.readFile "./tests/tmp/bob/test.jpg"
dest2 <- B.readFile "./tests/tmp/cath/test.jpg"
dest1 `shouldBe` src
dest2 `shouldBe` src
where
cfg = testCfg {inlineFiles = defaultInlineFilesConfig {offerChunks = 100, sendChunks = 100, totalSendChunks = 100, receiveChunks = 100}}
runTestGroupFileSndCancelBeforeTransfer :: TestCC -> TestCC -> TestCC -> IO ()
runTestGroupFileSndCancelBeforeTransfer alice bob cath = do
createGroup3 "team" alice bob cath
alice #> "/f #team ./tests/fixtures/test.txt"
alice <## "use /fc 1 to cancel sending"
@ -1520,16 +1601,15 @@ testGroupFileSndCancelBeforeTransfer =
cath <## "alice cancelled sending file 1 (test.txt)"
]
alice ##> "/fs 1"
alice <## "sending file 1 (test.txt): no file transfers, file transfer cancelled"
alice <## "sending file 1 (test.txt): no file transfers"
alice <## "file transfer cancelled"
bob ##> "/fs 1"
bob <## "receiving file 1 (test.txt) cancelled"
bob ##> "/fr 1 ./tests/tmp"
bob <## "file cancelled: test.txt"
testMessageWithFile :: IO ()
testMessageWithFile =
testChat2 aliceProfile bobProfile $
\alice bob -> do
runTestMessageWithFile :: TestCC -> TestCC -> IO ()
runTestMessageWithFile alice bob = do
connectUsers alice bob
alice ##> "/_send @2 json {\"filePath\": \"./tests/fixtures/test.jpg\", \"msgContent\": {\"type\": \"text\", \"text\": \"hi, sending a file\"}}"
alice <# "@bob hi, sending a file"
@ -2278,7 +2358,7 @@ testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfil
do
dan <## "#secret_club: you joined the group"
dan
<### [ "#secret_club: member " <> cathIncognito <> " is connected",
<### [ ConsoleString $ "#secret_club: member " <> cathIncognito <> " is connected",
"#secret_club: member bob_1 (Bob) is connected",
"contact bob_1 is merged into bob",
"use @bob <message> to send messages"
@ -2338,28 +2418,28 @@ testJoinGroupIncognito = testChat4 aliceProfile bobProfile cathProfile danProfil
alice
<### [ "alice (Alice): owner, you, created group",
"bob (Bob): admin, invited, connected",
cathIncognito <> ": admin, invited, connected",
ConsoleString $ cathIncognito <> ": admin, invited, connected",
"dan (Daniel): admin, invited, connected"
]
bob ##> "/ms secret_club"
bob
<### [ "alice (Alice): owner, host, connected",
"bob (Bob): admin, you, connected",
cathIncognito <> ": admin, connected",
ConsoleString $ cathIncognito <> ": admin, connected",
"dan (Daniel): admin, connected"
]
cath ##> "/ms secret_club"
cath
<### [ "alice (Alice): owner, host, connected",
"bob_1 (Bob): admin, connected",
"i " <> cathIncognito <> ": admin, you, connected",
ConsoleString $ "i " <> cathIncognito <> ": admin, you, connected",
"dan_1 (Daniel): admin, connected"
]
dan ##> "/ms secret_club"
dan
<### [ "alice (Alice): owner, host, connected",
"bob (Bob): admin, connected",
cathIncognito <> ": admin, connected",
ConsoleString $ cathIncognito <> ": admin, connected",
"dan (Daniel): admin, you, connected"
]
-- remove member
@ -3456,18 +3536,44 @@ cc <## line = do
when (l /= line) $ print ("expected: " <> line, ", got: " <> l)
l `shouldBe` line
getInAnyOrder :: (String -> String) -> TestCC -> [String] -> Expectation
(<##.) :: TestCC -> String -> Expectation
cc <##. line = do
l <- getTermLine cc
let prefix = line `isPrefixOf` l
unless prefix $ print ("expected to start from: " <> line, ", got: " <> l)
prefix `shouldBe` True
(<##..) :: TestCC -> [String] -> Expectation
cc <##.. ls = do
l <- getTermLine cc
let prefix = any (`isPrefixOf` l) ls
unless prefix $ print ("expected to start from one of: " <> show ls, ", got: " <> l)
prefix `shouldBe` True
data ConsoleResponse = ConsoleString String | WithTime String
deriving (Show)
instance IsString ConsoleResponse where fromString = ConsoleString
-- this assumes that the string can only match one option
getInAnyOrder :: (String -> String) -> TestCC -> [ConsoleResponse] -> Expectation
getInAnyOrder _ _ [] = pure ()
getInAnyOrder f cc ls = do
line <- f <$> getTermLine cc
if line `elem` ls
then getInAnyOrder f cc $ filter (/= line) ls
let rest = filter (not . expected line) ls
if length rest < length ls
then getInAnyOrder f cc rest
else error $ "unexpected output: " <> line
where
expected :: String -> ConsoleResponse -> Bool
expected l = \case
ConsoleString s -> l == s
WithTime s -> dropTime_ l == Just s
(<###) :: TestCC -> [String] -> Expectation
(<###) :: TestCC -> [ConsoleResponse] -> Expectation
(<###) = getInAnyOrder id
(<##?) :: TestCC -> [String] -> Expectation
(<##?) :: TestCC -> [ConsoleResponse] -> Expectation
(<##?) = getInAnyOrder dropTime
(<#) :: TestCC -> String -> Expectation
@ -3489,13 +3595,16 @@ cc1 <#? cc2 = do
cc1 <## ("to reject: /rc " <> name <> " (the sender will NOT be notified)")
dropTime :: String -> String
dropTime msg = case splitAt 6 msg of
([m, m', ':', s, s', ' '], text) ->
if all isDigit [m, m', s, s'] then text else err
_ -> err
dropTime msg = fromMaybe err $ dropTime_ msg
where
err = error $ "invalid time: " <> msg
dropTime_ :: String -> Maybe String
dropTime_ msg = case splitAt 6 msg of
([m, m', ':', s, s', ' '], text) ->
if all isDigit [m, m', s, s'] then Just text else Nothing
_ -> Nothing
getInvitation :: TestCC -> IO String
getInvitation cc = do
cc <## "pass this invitation link to your contact (via another channel):"

29
tests/ProtocolTests.hs
View file

@ -52,28 +52,28 @@ testE2ERatchetParams = E2ERatchetParamsUri e2eEncryptVRange testDhPubKey testDhP
testConnReq :: ConnectionRequestUri 'CMInvitation
testConnReq = CRInvitationUri connReqData testE2ERatchetParams
(==##) :: ByteString -> ChatMessage -> Expectation
(==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation
s ==## msg = do
strDecode s `shouldBe` Right msg
parseAll strP s `shouldBe` Right msg
(##==) :: ByteString -> ChatMessage -> Expectation
(##==) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation
s ##== msg =
J.eitherDecodeStrict' (strEncode msg)
`shouldBe` (J.eitherDecodeStrict' s :: Either String J.Value)
(##==##) :: ByteString -> ChatMessage -> Expectation
(##==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation
s ##==## msg = do
s ##== msg
s ==## msg
(==#) :: ByteString -> ChatMsgEvent -> Expectation
(==#) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation
s ==# msg = s ==## ChatMessage Nothing msg
(#==) :: ByteString -> ChatMsgEvent -> Expectation
(#==) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation
s #== msg = s ##== ChatMessage Nothing msg
(#==#) :: ByteString -> ChatMsgEvent -> Expectation
(#==#) :: MsgEncodingI e => ByteString -> ChatMsgEvent e -> Expectation
s #==# msg = do
s #== msg
s ==# msg
@ -122,10 +122,10 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing))
it "x.msg.new simple text with file" $
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing})))
#==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing})))
it "x.msg.new simple file with file" $
"{\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"\",\"type\":\"file\"},\"file\":{\"fileSize\":12345,\"fileName\":\"file.txt\"}}}"
#==# XMsgNew (MCSimple (ExtMsgContent (MCFile "") (Just FileInvitation {fileName = "file.txt", fileSize = 12345, fileConnReq = Nothing})))
#==# XMsgNew (MCSimple (ExtMsgContent (MCFile "") (Just FileInvitation {fileName = "file.txt", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing})))
it "x.msg.new quote with file" $
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
##==## ChatMessage
@ -138,13 +138,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
)
( ExtMsgContent
(MCText "hello to you too")
(Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing})
(Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing})
)
)
)
it "x.msg.new forward with file" $
"{\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing})))
##==## ChatMessage (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing})))
it "x.msg.update" $
"{\"event\":\"x.msg.update\",\"params\":{\"msgId\":\"AQIDBA==\", \"content\":{\"text\":\"hello\",\"type\":\"text\"}}}"
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello")
@ -156,16 +156,19 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
#==# XMsgDeleted
it "x.file" $
"{\"event\":\"x.file\",\"params\":{\"file\":{\"fileConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
#==# XFile FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Just testConnReq}
#==# XFile FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Just testConnReq, fileInline = Nothing}
it "x.file without file invitation" $
"{\"event\":\"x.file\",\"params\":{\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}"
#==# XFile FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing}
#==# XFile FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileConnReq = Nothing, fileInline = Nothing}
it "x.file.acpt" $
"{\"event\":\"x.file.acpt\",\"params\":{\"fileName\":\"photo.jpg\"}}"
#==# XFileAcpt "photo.jpg"
it "x.file.acpt.inv" $
"{\"event\":\"x.file.acpt.inv\",\"params\":{\"msgId\":\"AQIDBA==\",\"fileName\":\"photo.jpg\",\"fileConnReq\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"}}"
#==# XFileAcptInv (SharedMsgId "\1\2\3\4") testConnReq "photo.jpg"
#==# XFileAcptInv (SharedMsgId "\1\2\3\4") (Just testConnReq) "photo.jpg"
it "x.file.acpt.inv" $
"{\"event\":\"x.file.acpt.inv\",\"params\":{\"msgId\":\"AQIDBA==\",\"fileName\":\"photo.jpg\"}}"
#==# XFileAcptInv (SharedMsgId "\1\2\3\4") Nothing "photo.jpg"
it "x.file.cancel" $
"{\"event\":\"x.file.cancel\",\"params\":{\"msgId\":\"AQIDBA==\"}}"
#==# XFileCancel (SharedMsgId "\1\2\3\4")

BIN
tests/fixtures/test.pdf vendored Normal file
View file

Binary file not shown.