dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-05-24 15:15:35 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: new files protocol (#492)

Browse Source
This commit is contained in:
JRoberts
2022-04-05 10:01:08 +04:00
committed by GitHub
parent a17ddede53
commit a5ca2c2163
12 changed files with 551 additions and 70 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat/Controller.hs
+3 -1
View File
@@ -138,7 +138,9 @@ data ChatCommand
| DeleteGroupMessage GroupName ByteString
| EditGroupMessage {groupName :: ContactName, editedMsg :: ByteString, message :: ByteString}
| SendFile ContactName FilePath
| SendFileInv ContactName FilePath
| SendGroupFile GroupName FilePath
| SendGroupFileInv GroupName FilePath
| ReceiveFile FileTransferId (Maybe FilePath)
| CancelFile FileTransferId
| FileStatus FileTransferId
@@ -205,7 +207,7 @@ data ChatResponse
| CRSndFileComplete {sndFileTransfer :: SndFileTransfer}
| CRSndFileCancelled {sndFileTransfer :: SndFileTransfer}
| CRSndFileRcvCancelled {sndFileTransfer :: SndFileTransfer}
| CRSndGroupFileCancelled {sndFileTransfers :: [SndFileTransfer]}
| CRSndGroupFileCancelled {fileTransferMeta :: FileTransferMeta, sndFileTransfers :: [SndFileTransfer]}
| CRUserProfileUpdated {fromProfile :: Profile, toProfile :: Profile}
| CRContactConnecting {contact :: Contact}
| CRContactConnected {contact :: Contact}
src/Simplex/Chat/Migrations/M20220404_files_cancelled.hs
+12
View File
@@ -0,0 +1,12 @@
{-# LANGUAGE QuasiQuotes #-}
module Simplex.Chat.Migrations.M20220404_files_cancelled where
import Database.SQLite.Simple (Query)
import Database.SQLite.Simple.QQ (sql)
m20220404_files_cancelled :: Query
m20220404_files_cancelled =
[sql|
ALTER TABLE files ADD COLUMN cancelled INTEGER; -- 1 for cancelled
|]
src/Simplex/Chat/Protocol.hs
+14 -2
View File
@@ -113,7 +113,8 @@ data ChatMsgEvent
| XMsgDel SharedMsgId
| XMsgDeleted
| XFile FileInvitation
| XFileAcpt String
| XFileAcpt String -- old file protocol
| XFileAcptInv SharedMsgId ConnReqInvitation String -- new file protocol
| XInfo Profile
| XContact Profile (Maybe XContactId)
| XGrpInv GroupInvitation
@@ -261,6 +262,7 @@ data CMEventTag
| XMsgDeleted_
| XFile_
| XFileAcpt_
| XFileAcptInv_
| XInfo_
| XContact_
| XGrpInv_
@@ -290,6 +292,7 @@ instance StrEncoding CMEventTag where
XMsgDeleted_ -> "x.msg.deleted"
XFile_ -> "x.file"
XFileAcpt_ -> "x.file.acpt"
XFileAcptInv_ -> "x.file.acpt.inv"
XInfo_ -> "x.info"
XContact_ -> "x.contact"
XGrpInv_ -> "x.grp.inv"
@@ -316,6 +319,7 @@ instance StrEncoding CMEventTag where
"x.msg.deleted" -> Right XMsgDeleted_
"x.file" -> Right XFile_
"x.file.acpt" -> Right XFileAcpt_
"x.file.acpt.inv" -> Right XFileAcptInv_
"x.info" -> Right XInfo_
"x.contact" -> Right XContact_
"x.grp.inv" -> Right XGrpInv_
@@ -345,6 +349,7 @@ toCMEventTag = \case
XMsgDeleted -> XMsgDeleted_
XFile _ -> XFile_
XFileAcpt _ -> XFileAcpt_
XFileAcptInv {} -> XFileAcptInv_
XInfo _ -> XInfo_
XContact _ _ -> XContact_
XGrpInv _ -> XGrpInv_
@@ -392,6 +397,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"
XInfo_ -> XInfo <$> p "profile"
XContact_ -> XContact <$> p "profile" <*> opt "contactReqId"
XGrpInv_ -> XGrpInv <$> p "groupInvitation"
@@ -424,8 +430,9 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
XMsgUpdate msgId' content -> o ["msgId" .= msgId', "content" .= content]
XMsgDel msgId' -> o ["msgId" .= msgId']
XMsgDeleted -> JM.empty
XFile fileInv -> o ["file" .= fileInv]
XFile fileInv -> o ["file" .= fileInvitationJSON fileInv]
XFileAcpt fileName -> o ["fileName" .= fileName]
XFileAcptInv sharedMsgId fileConnReq fileName -> o ["msgId" .= sharedMsgId, "fileConnReq" .= fileConnReq, "fileName" .= fileName]
XInfo profile -> o ["profile" .= profile]
XContact profile xContactId -> o $ ("contactReqId" .=? xContactId) ["profile" .= profile]
XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
@@ -445,3 +452,8 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
XInfoProbeOk probe -> o ["probe" .= probe]
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]
src/Simplex/Chat/Store.hs
+180 -14
View File
@@ -52,6 +52,7 @@ module Simplex.Chat.Store
getPendingConnections,
getContactConnections,
getConnectionEntity,
getGroupAndMember,
updateConnectionStatus,
createNewGroup,
createGroupInvitation,
@@ -87,8 +88,16 @@ module Simplex.Chat.Store
matchReceivedProbeHash,
matchSentProbe,
mergeContactRecords,
createSndFileTransfer,
createSndGroupFileTransfer,
createSndFileTransfer, -- old file protocol
createSndFileTransferV2,
createSndFileTransferV2Connection,
createSndGroupFileTransfer, -- old file protocol
createSndGroupFileTransferV2,
createSndGroupFileTransferV2Connection,
updateFileCancelled,
getSharedMsgIdByFileId,
getFileIdBySharedMsgId,
getGroupFileIdBySharedMsgId,
updateSndFileStatus,
createSndFileChunk,
updateSndFileChunkMsg,
@@ -179,10 +188,11 @@ import Simplex.Chat.Migrations.M20220301_smp_servers
import Simplex.Chat.Migrations.M20220302_profile_images
import Simplex.Chat.Migrations.M20220304_msg_quotes
import Simplex.Chat.Migrations.M20220321_chat_item_edited
import Simplex.Chat.Migrations.M20220404_files_cancelled
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Chat.Util (eitherToMaybe)
import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri, AgentMsgId, ConnId, InvitationId, MsgMeta (..), SMPServer (..))
import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, InvitationId, MsgMeta (..), SMPServer (..))
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, firstRow, withTransaction)
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
import qualified Simplex.Messaging.Crypto as C
@@ -202,7 +212,8 @@ schemaMigrations =
("20220301_smp_servers", m20220301_smp_servers),
("20220302_profile_images", m20220302_profile_images),
("20220304_msg_quotes", m20220304_msg_quotes),
("20220321_chat_item_edited", m20220321_chat_item_edited)
("20220321_chat_item_edited", m20220321_chat_item_edited),
("20220404_files_cancelled", m20220404_files_cancelled)
]
-- | The list of migrations in ascending order by date
@@ -1139,7 +1150,7 @@ getConnectionEntity st User {userId, userContactId} agentConnId =
FROM snd_files s
JOIN files f USING (file_id)
LEFT JOIN contacts cs USING (contact_id)
LEFT JOIN group_members m USING (group_member_id)
LEFT JOIN group_members m USING (group_member_id)
WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ?
|]
(userId, fileId, connId)
@@ -1165,6 +1176,47 @@ getConnectionEntity st User {userId, userContactId} agentConnId =
userContact_ [Only cReq] = Right UserContact {userContactLinkId, connReqContact = cReq}
userContact_ _ = Left SEUserContactLinkNotFound
getGroupAndMember :: StoreMonad m => SQLiteStore -> User -> Int64 -> m (GroupInfo, GroupMember)
getGroupAndMember st User {userId, userContactId} groupMemberId =
liftIOEither . withTransaction st $ \db ->
firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
DB.query
db
[sql|
SELECT
-- GroupInfo
g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.created_at,
-- GroupInfo {membership}
mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category,
mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id,
-- GroupInfo {membership = GroupMember {memberProfile}}
pu.display_name, pu.full_name, pu.image,
-- from GroupMember
m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status,
m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, p.image,
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact,
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
FROM group_members m
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
JOIN groups g ON g.group_id = m.group_id
JOIN group_profiles gp USING (group_profile_id)
JOIN group_members mu ON g.group_id = mu.group_id
JOIN contact_profiles pu ON pu.contact_profile_id = mu.contact_profile_id
LEFT JOIN connections c ON c.connection_id = (
SELECT max(cc.connection_id)
FROM connections cc
where cc.group_member_id = m.group_member_id
)
WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ?
|]
(groupMemberId, userId, userContactId)
where
toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
let groupInfo = toGroupInfo userContactId groupInfoRow
member = toGroupMember userContactId memberRow
in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection connRow})
updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m ()
updateConnectionStatus st Connection {connId} connStatus =
liftIO . withTransaction st $ \db -> do
@@ -1748,6 +1800,26 @@ createSndFileTransfer st userId Contact {contactId, localDisplayName = recipient
(fileId, fileStatus, connId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName, connId, fileStatus, agentConnId = AgentConnId acId}
createSndFileTransferV2 :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FilePath -> FileInvitation -> Integer -> m Int64
createSndFileTransferV2 st userId Contact {contactId} filePath FileInvitation {fileName, fileSize} chunkSize =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(userId, contactId, fileName, filePath, fileSize, chunkSize, currentTs, currentTs)
insertedRowId db
createSndFileTransferV2Connection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> m ()
createSndFileTransferV2Connection st userId fileId acId =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
Connection {connId} <- createSndFileConnection_ db userId fileId acId
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, connection_id, created_at, updated_at) VALUES (?,?,?,?,?)"
(fileId, FSAccepted, connId, currentTs, currentTs)
createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> [(GroupMember, ConnId, FileInvitation)] -> FilePath -> Integer -> Integer -> m Int64
createSndGroupFileTransfer st userId GroupInfo {groupId} ms filePath fileSize chunkSize =
liftIO . withTransaction st $ \db -> do
@@ -1766,6 +1838,74 @@ createSndGroupFileTransfer st userId GroupInfo {groupId} ms filePath fileSize ch
(fileId, FSNew, connId, groupMemberId, currentTs, currentTs)
pure fileId
createSndGroupFileTransferV2 :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupInfo -> FilePath -> FileInvitation -> Integer -> m Int64
createSndGroupFileTransferV2 st userId GroupInfo {groupId} filePath FileInvitation {fileName, fileSize} chunkSize =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
DB.execute
db
"INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)"
(userId, groupId, fileName, filePath, fileSize, chunkSize, currentTs, currentTs)
insertedRowId db
createSndGroupFileTransferV2Connection :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> ConnId -> GroupMember -> m ()
createSndGroupFileTransferV2Connection st userId fileId acId GroupMember {groupMemberId} =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
Connection {connId} <- createSndFileConnection_ db userId fileId acId
DB.execute
db
"INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs)
updateFileCancelled :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m ()
updateFileCancelled st userId fileId =
liftIO . withTransaction st $ \db -> do
currentTs <- getCurrentTime
DB.execute db "UPDATE files SET cancelled = 1, updated_at = ? WHERE user_id = ? AND file_id = ?" (currentTs, userId, fileId)
getSharedMsgIdByFileId :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m SharedMsgId
getSharedMsgIdByFileId st userId fileId =
liftIOEither . withTransaction st $ \db ->
firstRow fromOnly (SESharedMsgIdNotFoundByFileId fileId) $
DB.query
db
[sql|
SELECT i.shared_msg_id
FROM chat_items i
JOIN files f ON f.chat_item_id = i.chat_item_id
WHERE f.user_id = ? AND f.file_id = ?
|]
(userId, fileId)
getFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> Int64 -> UserId -> SharedMsgId -> m Int64
getFileIdBySharedMsgId st userId contactId sharedMsgId =
liftIOEither . withTransaction st $ \db ->
firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
DB.query
db
[sql|
SELECT f.file_id
FROM files f
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
WHERE i.user_id = ? AND i.contact_id = ? AND i.shared_msg_id = ?
|]
(userId, contactId, sharedMsgId)
getGroupFileIdBySharedMsgId :: StoreMonad m => SQLiteStore -> Int64 -> UserId -> SharedMsgId -> m Int64
getGroupFileIdBySharedMsgId st userId groupId sharedMsgId =
liftIOEither . withTransaction st $ \db ->
firstRow fromOnly (SEFileIdNotFoundBySharedMsgId sharedMsgId) $
DB.query
db
[sql|
SELECT f.file_id
FROM files f
JOIN chat_items i ON i.chat_item_id = f.chat_item_id
WHERE i.user_id = ? AND i.group_id = ? AND i.shared_msg_id = ?
|]
(userId, groupId, sharedMsgId)
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
createSndFileConnection_ db userId fileId agentConnId = do
currentTs <- getCurrentTime
@@ -1842,7 +1982,7 @@ createRcvFileTransfer st userId Contact {contactId, localDisplayName = c} f@File
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}
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Nothing}
createRcvGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> FileInvitation -> Integer -> m RcvFileTransfer
createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileConnReq} chunkSize =
@@ -1857,7 +1997,7 @@ createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localD
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}
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize, cancelled = False, grpMemberId = Just groupMemberId}
getRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m RcvFileTransfer
getRcvFileTransfer st userId fileId =
@@ -1870,8 +2010,8 @@ getRcvFileTransfer_ db userId fileId =
<$> DB.query
db
[sql|
SELECT r.file_status, r.file_queue_info, f.file_name,
f.file_size, f.chunk_size, cs.local_display_name, m.local_display_name,
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
FROM rcv_files r
JOIN files f USING (file_id)
@@ -1883,16 +2023,16 @@ getRcvFileTransfer_ db userId fileId =
(userId, fileId)
where
rcvFileTransfer ::
[(FileStatus, AConnectionRequestUri, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe AgentConnId)] ->
[(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, fileName, fileSize, chunkSize, contactName_, memberName_, filePath_, connId_, agentConnId_)] =
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 ->
case fileStatus' of
FSNew -> Right RcvFileTransfer {fileId, fileInvitation = fileInv, fileStatus = RFSNew, senderDisplayName = name, chunkSize}
FSNew -> Right RcvFileTransfer {fileId, fileInvitation = fileInv, fileStatus = RFSNew, senderDisplayName = name, chunkSize, cancelled, grpMemberId}
FSAccepted -> ft name fileInv RFSAccepted fileInfo
FSConnected -> ft name fileInv RFSConnected fileInfo
FSComplete -> ft name fileInv RFSComplete fileInfo
@@ -1903,6 +2043,7 @@ getRcvFileTransfer_ db userId fileId =
let fileStatus = rfs RcvFileInfo {filePath, connId, agentConnId}
in Right RcvFileTransfer {..}
_ -> Left $ SERcvFileInvalid fileId
cancelled = fromMaybe False cancelled_
rcvFileTransfer _ = Left $ SERcvFileNotFound fileId
acceptRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ConnId -> FilePath -> m ()
@@ -1996,7 +2137,8 @@ getFileTransferProgress st userId fileId =
ft <- ExceptT $ getFileTransfer_ db userId fileId
liftIO $
(ft,) . map fromOnly <$> case ft of
FTSnd _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId)
FTSnd _ [] -> pure [Only 0]
FTSnd _ _ -> DB.query db "SELECT COUNT(*) FROM snd_file_chunks WHERE file_id = ? and chunk_sent = 1 GROUP BY connection_id" (Only fileId)
FTRcv _ -> DB.query db "SELECT COUNT(*) FROM rcv_file_chunks WHERE file_id = ? AND chunk_stored = 1" (Only fileId)
getFileTransfer_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError FileTransfer)
@@ -2014,7 +2156,13 @@ getFileTransfer_ db userId fileId =
(userId, fileId)
where
fileTransfer :: [(Maybe Int64, Maybe Int64)] -> IO (Either StoreError FileTransfer)
fileTransfer ((Just _, Nothing) : _) = FTSnd <$$> getSndFileTransfers_ db userId fileId
fileTransfer [(Nothing, Nothing)] = runExceptT $ do
fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId
pure FTSnd {fileTransferMeta, sndFileTransfers = []}
fileTransfer ((Just _, Nothing) : _) = runExceptT $ do
fileTransferMeta <- ExceptT $ getFileTransferMeta_ db userId fileId
sndFileTransfers <- ExceptT $ getSndFileTransfers_ db userId fileId
pure FTSnd {fileTransferMeta, sndFileTransfers}
fileTransfer [(Nothing, Just _)] = FTRcv <$$> getRcvFileTransfer_ db userId fileId
fileTransfer _ = pure . Left $ SEFileNotFound fileId
@@ -2043,6 +2191,22 @@ getSndFileTransfers_ db userId fileId =
Just recipientDisplayName -> Right SndFileTransfer {fileId, fileStatus, fileName, fileSize, chunkSize, filePath, recipientDisplayName, connId, agentConnId}
Nothing -> Left $ SESndFileInvalid fileId
getFileTransferMeta_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError FileTransferMeta)
getFileTransferMeta_ db userId fileId =
firstRow fileTransferMeta (SEFileNotFound fileId) $
DB.query
db
[sql|
SELECT f.file_name, f.file_size, f.chunk_size, f.file_path, 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_}
createNewSndMessage :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> ConnOrGroupId -> (SharedMsgId -> NewMessage) -> m SndMessage
createNewSndMessage st gVar connOrGroupId mkMessage =
liftIOEither . withTransaction st $ \db ->
@@ -3380,6 +3544,8 @@ data StoreError
| SERcvFileNotFound {fileId :: FileTransferId}
| SEFileNotFound {fileId :: FileTransferId}
| SERcvFileInvalid {fileId :: FileTransferId}
| SESharedMsgIdNotFoundByFileId {fileId :: FileTransferId}
| SEFileIdNotFoundBySharedMsgId {sharedMsgId :: SharedMsgId}
| SEConnectionNotFound {agentConnId :: AgentConnId}
| SEIntroNotFound
| SEUniqueID
src/Simplex/Chat/Terminal/Input.hs
+2
View File
@@ -47,7 +47,9 @@ runInputLoop ct cc = forever $ do
Right SendMessage {} -> True
Right SendGroupMessage {} -> True
Right SendFile {} -> True
Right SendFileInv {} -> True
Right SendGroupFile {} -> True
Right SendGroupFileInv {} -> True
Right SendMessageQuote {} -> True
Right SendGroupMessageQuote {} -> True
Right SendMessageBroadcast {} -> True
src/Simplex/Chat/Types.hs
+27 -4
View File
@@ -31,7 +31,7 @@ import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri, ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId)
import Simplex.Messaging.Agent.Store.SQLite (fromTextField_)
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, sumTypeJSON)
@@ -522,7 +522,7 @@ type FileTransferId = Int64
data FileInvitation = FileInvitation
{ fileName :: String,
fileSize :: Integer,
fileConnReq :: AConnectionRequestUri
fileConnReq :: Maybe ConnReqInvitation
}
deriving (Eq, Show, Generic, FromJSON)
@@ -533,7 +533,9 @@ data RcvFileTransfer = RcvFileTransfer
fileInvitation :: FileInvitation,
fileStatus :: RcvFileStatus,
senderDisplayName :: ContactName,
chunkSize :: Integer
chunkSize :: Integer,
cancelled :: Bool,
grpMemberId :: Maybe Int64
}
deriving (Eq, Show, Generic, FromJSON)
@@ -601,13 +603,34 @@ instance FromField AgentInvId where fromField f = AgentInvId <$> fromField f
instance ToField AgentInvId where toField (AgentInvId m) = toField m
data FileTransfer = FTSnd {sndFileTransfers :: [SndFileTransfer]} | FTRcv RcvFileTransfer
data FileTransfer
= FTSnd
{ fileTransferMeta :: FileTransferMeta,
sndFileTransfers :: [SndFileTransfer]
}
| FTRcv {rcvFileTransfer :: RcvFileTransfer}
deriving (Show, Generic)
instance ToJSON FileTransfer where
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "FT"
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "FT"
data FileTransferMeta = FileTransferMeta
{ fileId :: FileTransferId,
fileName :: String,
filePath :: String,
fileSize :: Integer,
chunkSize :: Integer,
cancelled :: Bool
}
deriving (Eq, Show, Generic)
instance ToJSON FileTransferMeta where toEncoding = J.genericToEncoding J.defaultOptions
fileTransferCancelled :: FileTransfer -> Bool
fileTransferCancelled (FTSnd FileTransferMeta {cancelled} _) = cancelled
fileTransferCancelled (FTRcv RcvFileTransfer {cancelled}) = cancelled
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show)
instance FromField FileStatus where fromField = fromTextField_ decodeText
src/Simplex/Chat/View.hs
+20 -23
View File
@@ -93,7 +93,7 @@ responseToView testView = \case
CRRcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath ->
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
CRRcvFileAcceptedSndCancelled ft -> viewRcvFileSndCancelled ft
CRSndGroupFileCancelled fts -> viewSndGroupFileCancelled fts
CRSndGroupFileCancelled ftm fts -> viewSndGroupFileCancelled ftm fts
CRRcvFileCancelled ft -> receivingFile_ "cancelled" ft
CRUserProfileUpdated p p' -> viewUserProfileUpdated p p'
CRContactUpdated c c' -> viewContactUpdated c c'
@@ -488,11 +488,11 @@ viewRcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
viewRcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
[ttyContact c <> " cancelled sending " <> rcvFile ft]
viewSndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
viewSndGroupFileCancelled fts =
viewSndGroupFileCancelled :: FileTransferMeta -> [SndFileTransfer] -> [StyledString]
viewSndGroupFileCancelled FileTransferMeta {fileId, fileName} fts =
case filter (\SndFileTransfer {fileStatus = s} -> s /= FSCancelled && s /= FSComplete) fts of
[] -> ["sending file can't be cancelled"]
ts@(ft : _) -> ["cancelled sending " <> sndFile ft <> " to " <> listMembers ts]
[] -> ["cancelled sending " <> fileTransferStr fileId fileName]
ts -> ["cancelled sending " <> fileTransferStr fileId fileName <> " to " <> listRecipients ts]
sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
@@ -533,24 +533,20 @@ fileTransferStr :: Int64 -> String -> StyledString
fileTransferStr fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")"
viewFileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
viewFileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
["sending " <> sndFile ft <> " " <> sndStatus]
where
sndStatus = case fileStatus of
FSNew -> "not accepted yet"
FSAccepted -> "just started"
FSConnected -> "progress " <> fileProgress chunksNum chunkSize fileSize
FSComplete -> "complete"
FSCancelled -> "cancelled"
viewFileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"]
viewFileTransferStatus (FTSnd fts@(ft : _), chunksNum) =
case concatMap membersTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
[membersStatus] -> ["sending " <> sndFile ft <> " " <> membersStatus]
membersStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) membersStatuses
viewFileTransferStatus (FTSnd FileTransferMeta {fileId, fileName, cancelled} [], _) =
[ "sending " <> fileTransferStr fileId fileName <> ": no file transfers"
<> if cancelled then ", file transfer cancelled" else ""
]
viewFileTransferStatus (FTSnd FileTransferMeta {cancelled} fts@(ft : _), chunksNum) =
recipientStatuses <> ["file transfer cancelled" | cancelled]
where
recipientStatuses =
case concatMap recipientsTransferStatus $ groupBy ((==) `on` fs) $ sortOn fs fts of
[recipientsStatus] -> ["sending " <> sndFile ft <> " " <> recipientsStatus]
recipientsStatuses -> ("sending " <> sndFile ft <> ": ") : map (" " <>) recipientsStatuses
fs = fileStatus :: SndFileTransfer -> FileStatus
membersTransferStatus [] = []
membersTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listMembers ts]
recipientsTransferStatus [] = []
recipientsTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listRecipients ts]
where
sndStatus = case fileStatus of
FSNew -> "not accepted"
@@ -568,8 +564,8 @@ viewFileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileI
RFSComplete RcvFileInfo {filePath} -> "complete, path: " <> plain filePath
RFSCancelled RcvFileInfo {filePath} -> "cancelled, received part path: " <> plain filePath
listMembers :: [SndFileTransfer] -> StyledString
listMembers = mconcat . intersperse ", " . map (ttyContact . recipientDisplayName)
listRecipients :: [SndFileTransfer] -> StyledString
listRecipients = mconcat . intersperse ", " . map (ttyContact . recipientDisplayName)
fileProgress :: [Integer] -> Integer -> Integer -> StyledString
fileProgress chunksNum chunkSize fileSize =
@@ -622,6 +618,7 @@ viewChatError = \case
SEDuplicateContactLink -> ["you already have chat address, to show: " <> highlight' "/sa"]
SEUserContactLinkNotFound -> ["no chat address, to create: " <> highlight' "/ad"]
SEContactRequestNotFoundByName c -> ["no contact request from " <> ttyContact c]
SEFileIdNotFoundBySharedMsgId _ -> [] -- recipient tried to accept cancelled file
SEConnectionNotFound _ -> [] -- TODO mutes delete group error, but also mutes any error from getConnectionEntity
SEQuotedChatItemNotFound -> ["message not found - reply is not sent"]
e -> ["chat db error: " <> sShow e]