send files to groups (#97)
* add sender/recipient info to file types * send file to group (WIP) * send file to group, test * show file status when sending file to group * notification when cancelled sending to group, remove chunks when file complete or canceleld
This commit is contained in:
Evgeny Poberezkin
GitHub
parent
4bbdcc1d06
commit
28103825fa
@ -51,7 +51,7 @@ import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Util (bshow, raceAny_)
|
||||
import Simplex.Messaging.Util (bshow, raceAny_, tryError)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import System.FilePath (combine, splitExtensions, takeFileName)
|
||||
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout)
|
||||
@ -163,6 +163,8 @@ inputSubscriber = do
|
||||
case cmd of
|
||||
SendMessage c msg -> showSentMessage c msg
|
||||
SendGroupMessage g msg -> showSentGroupMessage g msg
|
||||
SendFile c f -> showSentFileInvitation c f
|
||||
SendGroupFile g f -> showSentGroupFileInvitation g f
|
||||
_ -> printToView [plain s]
|
||||
user <- readTVarIO =<< asks currentUser
|
||||
withAgentLock a . withLock l . void . runExceptT $
|
||||
@ -264,33 +266,47 @@ processChatCommand user@User {userId, profile} = \case
|
||||
sendGroupMessage members msgEvent
|
||||
setActive $ ActiveG gName
|
||||
SendFile cName f -> do
|
||||
unlessM (doesFileExist f) . chatError $ CEFileNotFound f
|
||||
contact@Contact {contactId} <- withStore $ \st -> getContact st userId cName
|
||||
(fileSize, chSize) <- checkSndFile f
|
||||
contact <- withStore $ \st -> getContact st userId cName
|
||||
(agentConnId, fileQInfo) <- withAgent createConnection
|
||||
fileSize <- getFileSize f
|
||||
let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileQInfo}
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
ft <- withStore $ \st -> createSndFileTransfer st userId contactId f fileInv agentConnId chSize
|
||||
SndFileTransfer {fileId} <- withStore $ \st ->
|
||||
createSndFileTransfer st userId contact f fileInv agentConnId chSize
|
||||
sendDirectMessage (contactConnId contact) $ XFile fileInv
|
||||
showSentFileInvitation cName ft
|
||||
showSentFileInfo fileId
|
||||
setActive $ ActiveC cName
|
||||
SendGroupFile _gName _file -> pure ()
|
||||
SendGroupFile gName f -> do
|
||||
(fileSize, chSize) <- checkSndFile f
|
||||
group@Group {members, membership} <- withStore $ \st -> getGroup st user gName
|
||||
unless (memberActive membership) $ chatError CEGroupMemberUserRemoved
|
||||
let fileName = takeFileName f
|
||||
ms <- forM (filter memberActive members) $ \m -> do
|
||||
(connId, fileQInfo) <- withAgent createConnection
|
||||
pure (m, connId, FileInvitation {fileName, fileSize, fileQInfo})
|
||||
fileId <- withStore $ \st -> createSndGroupFileTransfer st userId group ms f fileSize chSize
|
||||
forM_ ms $ \(m, _, fileInv) ->
|
||||
traverse (`sendDirectMessage` XFile fileInv) $ memberConnId m
|
||||
showSentFileInfo fileId
|
||||
setActive $ ActiveG gName
|
||||
ReceiveFile fileId filePath_ -> do
|
||||
RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileQInfo}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
|
||||
ft@RcvFileTransfer {fileInvitation = FileInvitation {fileName, fileQInfo}, fileStatus} <- withStore $ \st -> getRcvFileTransfer st userId fileId
|
||||
unless (fileStatus == RFSNew) . chatError $ CEFileAlreadyReceiving fileName
|
||||
agentConnId <- withAgent $ \a -> joinConnection a fileQInfo . directMessage $ XFileAcpt fileName
|
||||
filePath <- getRcvFilePath fileId filePath_ fileName
|
||||
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
|
||||
-- TODO include file sender in the message
|
||||
showRcvFileAccepted fileId filePath
|
||||
tryError (withAgent $ \a -> joinConnection a fileQInfo . directMessage $ XFileAcpt fileName) >>= \case
|
||||
Right agentConnId -> do
|
||||
filePath <- getRcvFilePath fileId filePath_ fileName
|
||||
withStore $ \st -> acceptRcvFileTransfer st userId fileId agentConnId filePath
|
||||
showRcvFileAccepted ft filePath
|
||||
Left (ChatErrorAgent (SMP SMP.AUTH)) -> showRcvFileSndCancelled ft
|
||||
Left (ChatErrorAgent (CONN DUPLICATE)) -> showRcvFileSndCancelled ft
|
||||
Left e -> throwError e
|
||||
CancelFile fileId ->
|
||||
withStore (\st -> getFileTransfer st userId fileId) >>= \case
|
||||
FTSnd fts -> do
|
||||
mapM_ cancelSndFileTransfer fts
|
||||
showSndFileCancelled fileId
|
||||
forM_ fts $ \ft -> cancelSndFileTransfer ft
|
||||
showSndGroupFileCancelled fts
|
||||
FTRcv ft -> do
|
||||
cancelRcvFileTransfer ft
|
||||
showRcvFileCancelled fileId
|
||||
showRcvFileCancelled ft
|
||||
FileStatus fileId ->
|
||||
withStore (\st -> getFileTransferProgress st userId fileId) >>= showFileTransferStatus
|
||||
UpdateProfile p -> unless (p == profile) $ do
|
||||
@ -306,6 +322,10 @@ processChatCommand user@User {userId, profile} = \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
|
||||
unlessM (doesFileExist f) . chatError $ CEFileNotFound f
|
||||
(,) <$> getFileSize f <*> asks (fileChunkSize . config)
|
||||
getRcvFilePath :: Int64 -> Maybe FilePath -> String -> m FilePath
|
||||
getRcvFilePath fileId filePath fileName = case filePath of
|
||||
Nothing -> do
|
||||
@ -449,7 +469,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
|
||||
case chatMsgEvent of
|
||||
XMsgNew (MsgContent MTText [] body) -> newTextMessage c meta $ find (isSimplexContentType XCText) body
|
||||
XFile fInv -> processFileInvitation ct fInv
|
||||
XFile fInv -> processFileInvitation ct meta fInv
|
||||
XInfo p -> xInfo ct p
|
||||
XGrpInv gInv -> processGroupInvitation ct gInv
|
||||
XInfoProbe probe -> xInfoProbe ct probe
|
||||
@ -567,6 +587,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
case chatMsgEvent of
|
||||
XMsgNew (MsgContent MTText [] body) ->
|
||||
newGroupTextMessage gName m meta $ find (isSimplexContentType XCText) body
|
||||
XFile fInv -> processGroupFileInvitation gName m meta fInv
|
||||
XGrpMemNew memInfo -> xGrpMemNew gName m memInfo
|
||||
XGrpMemIntro memInfo -> xGrpMemIntro gName m memInfo
|
||||
XGrpMemInv memId introInv -> xGrpMemInv gName m memId introInv
|
||||
@ -591,7 +612,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
_ -> messageError "REQ from file connection must have x.file.acpt"
|
||||
CON -> do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSConnected
|
||||
showSndFileStart fileId
|
||||
showSndFileStart ft
|
||||
sendFileChunk ft
|
||||
SENT msgId -> do
|
||||
withStore $ \st -> updateSndFileChunkSent st ft msgId
|
||||
@ -599,7 +620,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
MERR _ err -> do
|
||||
cancelSndFileTransfer ft
|
||||
case err of
|
||||
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ showSndFileRcvCancelled fileId
|
||||
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ showSndFileRcvCancelled ft
|
||||
_ -> chatError $ CEFileSend fileId err
|
||||
MSG meta _ ->
|
||||
withAckMessage agentConnId meta $ pure ()
|
||||
@ -610,12 +631,12 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
case agentMsg of
|
||||
CON -> do
|
||||
withStore $ \st -> updateRcvFileStatus st ft FSConnected
|
||||
showRcvFileStart fileId
|
||||
showRcvFileStart ft
|
||||
MSG meta@MsgMeta {recipient = (msgId, _), integrity} msgBody -> withAckMessage agentConnId meta $ do
|
||||
parseFileChunk msgBody >>= \case
|
||||
(0, _) -> do
|
||||
cancelRcvFileTransfer ft
|
||||
showRcvFileSndCancelled fileId
|
||||
showRcvFileSndCancelled ft
|
||||
(chunkNo, chunk) -> do
|
||||
case integrity of
|
||||
MsgOk -> pure ()
|
||||
@ -632,8 +653,10 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
then badRcvFileChunk ft "incorrect chunk size"
|
||||
else do
|
||||
appendFileChunk ft chunkNo chunk
|
||||
withStore $ \st -> updateRcvFileStatus st ft FSComplete
|
||||
showRcvFileComplete fileId
|
||||
withStore $ \st -> do
|
||||
updateRcvFileStatus st ft FSComplete
|
||||
deleteRcvFileChunks st ft
|
||||
showRcvFileComplete ft
|
||||
closeFileHandle fileId rcvFiles
|
||||
withAgent (`deleteConnection` agentConnId)
|
||||
RcvChunkDuplicate -> pure ()
|
||||
@ -681,7 +704,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
newTextMessage c meta = \case
|
||||
Just MsgContentBody {contentData = bs} -> do
|
||||
let text = safeDecodeUtf8 bs
|
||||
showReceivedMessage c (snd $ broker meta) text (integrity meta)
|
||||
showReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity meta)
|
||||
showToast (c <> "> ") text
|
||||
setActive $ ActiveC c
|
||||
_ -> messageError "x.msg.new: no expected message body"
|
||||
@ -690,19 +713,26 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
newGroupTextMessage gName GroupMember {localDisplayName = c} meta = \case
|
||||
Just MsgContentBody {contentData = bs} -> do
|
||||
let text = safeDecodeUtf8 bs
|
||||
showReceivedGroupMessage gName c (snd $ broker meta) text (integrity meta)
|
||||
showReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity meta)
|
||||
showToast ("#" <> gName <> " " <> c <> "> ") text
|
||||
setActive $ ActiveG gName
|
||||
_ -> messageError "x.msg.new: no expected message body"
|
||||
|
||||
processFileInvitation :: Contact -> FileInvitation -> m ()
|
||||
processFileInvitation Contact {contactId, localDisplayName = c} fInv = do
|
||||
processFileInvitation :: Contact -> MsgMeta -> FileInvitation -> m ()
|
||||
processFileInvitation contact@Contact {localDisplayName = c} meta fInv = do
|
||||
-- TODO chunk size has to be sent as part of invitation
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
ft <- withStore $ \st -> createRcvFileTransfer st userId contactId fInv chSize
|
||||
showReceivedFileInvitation c ft
|
||||
ft <- withStore $ \st -> createRcvFileTransfer st userId contact fInv chSize
|
||||
showReceivedMessage c (snd $ broker meta) (receivedFileInvitation ft) (integrity meta)
|
||||
setActive $ ActiveC c
|
||||
|
||||
processGroupFileInvitation :: GroupName -> GroupMember -> MsgMeta -> FileInvitation -> m ()
|
||||
processGroupFileInvitation gName m@GroupMember {localDisplayName = c} meta fInv = do
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
ft <- withStore $ \st -> createRcvGroupFileTransfer st userId m fInv chSize
|
||||
showReceivedGroupMessage gName c (snd $ broker meta) (receivedFileInvitation ft) (integrity meta)
|
||||
setActive $ ActiveG gName
|
||||
|
||||
processGroupInvitation :: Contact -> GroupInvitation -> m ()
|
||||
processGroupInvitation ct@Contact {localDisplayName} inv@(GroupInvitation (fromMemId, fromRole) (memId, memRole) _ _) = do
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole localDisplayName)
|
||||
@ -852,8 +882,10 @@ sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
|
||||
withStore (`createSndFileChunk` ft) >>= \case
|
||||
Just chunkNo -> sendFileChunkNo ft chunkNo
|
||||
Nothing -> do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSComplete
|
||||
showSndFileComplete fileId
|
||||
withStore $ \st -> do
|
||||
updateSndFileStatus st ft FSComplete
|
||||
deleteSndFileChunks st ft
|
||||
showSndFileComplete ft
|
||||
closeFileHandle fileId sndFiles
|
||||
withAgent (`deleteConnection` agentConnId)
|
||||
|
||||
@ -915,7 +947,9 @@ isFileActive fileId files = do
|
||||
cancelRcvFileTransfer :: ChatMonad m => RcvFileTransfer -> m ()
|
||||
cancelRcvFileTransfer ft@RcvFileTransfer {fileId, fileStatus} = do
|
||||
closeFileHandle fileId rcvFiles
|
||||
withStore $ \st -> updateRcvFileStatus st ft FSCancelled
|
||||
withStore $ \st -> do
|
||||
updateRcvFileStatus st ft FSCancelled
|
||||
deleteRcvFileChunks st ft
|
||||
case fileStatus of
|
||||
RFSAccepted RcvFileInfo {agentConnId} -> withAgent (`suspendConnection` agentConnId)
|
||||
RFSConnected RcvFileInfo {agentConnId} -> withAgent (`suspendConnection` agentConnId)
|
||||
@ -924,9 +958,11 @@ cancelRcvFileTransfer ft@RcvFileTransfer {fileId, fileStatus} = do
|
||||
cancelSndFileTransfer :: ChatMonad m => SndFileTransfer -> m ()
|
||||
cancelSndFileTransfer ft@SndFileTransfer {agentConnId, fileStatus} =
|
||||
unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSCancelled
|
||||
withStore $ \st -> do
|
||||
updateSndFileStatus st ft FSCancelled
|
||||
deleteSndFileChunks st ft
|
||||
withAgent $ \a -> do
|
||||
void $ sendMessage a agentConnId "0 "
|
||||
void (sendMessage a agentConnId "0 ") `catchError` \_ -> pure ()
|
||||
suspendConnection a agentConnId
|
||||
|
||||
closeFileHandle :: ChatMonad m => Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> m ()
|
||||
|
||||
@ -63,21 +63,26 @@ module Simplex.Chat.Store
|
||||
matchSentProbe,
|
||||
mergeContactRecords,
|
||||
createSndFileTransfer,
|
||||
createSndGroupFileTransfer,
|
||||
updateSndFileStatus,
|
||||
createSndFileChunk,
|
||||
updateSndFileChunkMsg,
|
||||
updateSndFileChunkSent,
|
||||
deleteSndFileChunks,
|
||||
createRcvFileTransfer,
|
||||
createRcvGroupFileTransfer,
|
||||
getRcvFileTransfer,
|
||||
acceptRcvFileTransfer,
|
||||
updateRcvFileStatus,
|
||||
createRcvFileChunk,
|
||||
updatedRcvFileChunkStored,
|
||||
deleteRcvFileChunks,
|
||||
getFileTransfer,
|
||||
getFileTransferProgress,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Concurrent.STM (stateTVar)
|
||||
import Control.Exception (Exception)
|
||||
import qualified Control.Exception as E
|
||||
@ -107,7 +112,7 @@ import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>))
|
||||
import System.FilePath (takeBaseName, takeExtension)
|
||||
import System.FilePath (takeBaseName, takeExtension, takeFileName)
|
||||
import UnliftIO.STM
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@ -635,7 +640,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
|
||||
[sql|
|
||||
SELECT
|
||||
g.local_display_name,
|
||||
m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
||||
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
|
||||
FROM group_members m
|
||||
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
||||
@ -655,14 +660,19 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path
|
||||
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path, 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)
|
||||
LEFT JOIN group_members m USING (group_member_id)
|
||||
WHERE f.user_id = ? AND f.file_id = ? AND s.connection_id = ?
|
||||
|]
|
||||
(userId, fileId, connId)
|
||||
sndFileTransfer_ :: Int64 -> Int64 -> [(FileStatus, String, Integer, Integer, FilePath)] -> Either StoreError SndFileTransfer
|
||||
sndFileTransfer_ fileId connId [(fileStatus, fileName, fileSize, chunkSize, filePath)] = Right SndFileTransfer {..}
|
||||
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_)] =
|
||||
case contactName_ <|> memberName_ of
|
||||
Just recipientDisplayName -> Right SndFileTransfer {..}
|
||||
Nothing -> Left $ SESndFileInvalid fileId
|
||||
sndFileTransfer_ fileId _ _ = Left $ SESndFileNotFound fileId
|
||||
|
||||
updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m ()
|
||||
@ -738,7 +748,7 @@ getGroup_ db User {userId, userContactId} localDisplayName = do
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
||||
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,
|
||||
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.created_at
|
||||
@ -790,13 +800,14 @@ getGroupInvitation st user localDisplayName =
|
||||
findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId)
|
||||
findFromContact _ = const Nothing
|
||||
|
||||
type GroupMemberRow = (Int64, ByteString, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text)
|
||||
type GroupMemberRow = (Int64, Int64, ByteString, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text)
|
||||
|
||||
toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
|
||||
toGroupMember userContactId (groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName) =
|
||||
toGroupMember userContactId (groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName) =
|
||||
let memberProfile = Profile {displayName, fullName}
|
||||
invitedBy = toInvitedBy userContactId invitedById
|
||||
in GroupMember {groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile, memberContactId, activeConn = Nothing}
|
||||
activeConn = Nothing
|
||||
in GroupMember {..}
|
||||
|
||||
createContactGroupMember :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> Int64 -> Contact -> GroupMemberRole -> ConnId -> m GroupMember
|
||||
createContactGroupMember st gVar user groupId contact memberRole agentConnId =
|
||||
@ -861,6 +872,7 @@ createNewMember_
|
||||
memProfileId
|
||||
} = do
|
||||
let invitedById = fromInvitedBy userContactId invitedBy
|
||||
activeConn = Nothing
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@ -870,19 +882,7 @@ createNewMember_
|
||||
|]
|
||||
(groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, userId, localDisplayName, memProfileId, memberContactId)
|
||||
groupMemberId <- insertedRowId db
|
||||
pure $
|
||||
GroupMember
|
||||
{ groupMemberId,
|
||||
memberId,
|
||||
memberRole,
|
||||
memberStatus,
|
||||
memberCategory,
|
||||
invitedBy,
|
||||
memberProfile,
|
||||
localDisplayName,
|
||||
memberContactId,
|
||||
activeConn = Nothing
|
||||
}
|
||||
pure GroupMember {..}
|
||||
|
||||
deleteGroupMemberConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> m ()
|
||||
deleteGroupMemberConnection st userId m =
|
||||
@ -982,11 +982,11 @@ getIntroduction_ db reMember toMember = ExceptT $ do
|
||||
toIntro _ = Left SEIntroNotFound
|
||||
|
||||
createIntroReMember :: StoreMonad m => SQLiteStore -> User -> Group -> GroupMember -> MemberInfo -> ConnId -> ConnId -> m GroupMember
|
||||
createIntroReMember st user@User {userId} group _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId =
|
||||
createIntroReMember st user@User {userId} group@Group {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn
|
||||
Connection {connId = directConnId} <- liftIO $ createConnection_ db userId directAgentConnId memberContactId cLevel
|
||||
(localDisplayName, contactId, memProfileId) <- ExceptT $ createContact_ db userId directConnId memberProfile (Just $ groupId group)
|
||||
(localDisplayName, contactId, memProfileId) <- ExceptT $ createContact_ db userId directConnId memberProfile (Just groupId)
|
||||
liftIO $ do
|
||||
let newMember =
|
||||
NewGroupMember
|
||||
@ -1059,7 +1059,8 @@ createContactMember_ db User {userId, userContactId} groupId userOrContact (memb
|
||||
let memberProfile = profile' userOrContact
|
||||
memberContactId = Just $ contactId' userOrContact
|
||||
localDisplayName = localDisplayName' userOrContact
|
||||
pure GroupMember {groupMemberId, memberId, memberRole, memberCategory, memberStatus, invitedBy, localDisplayName, memberProfile, memberContactId, activeConn = Nothing}
|
||||
activeConn = Nothing
|
||||
pure GroupMember {..}
|
||||
where
|
||||
insertMember_ =
|
||||
DB.executeNamed
|
||||
@ -1094,7 +1095,7 @@ getViaGroupMember st User {userId, userContactId} Contact {contactId} =
|
||||
[sql|
|
||||
SELECT
|
||||
g.local_display_name,
|
||||
m.group_member_id, m.member_id, m.member_role, m.member_category, m.member_status,
|
||||
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,
|
||||
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.created_at
|
||||
@ -1148,8 +1149,8 @@ getViaGroupContact st User {userId} GroupMember {groupMemberId} =
|
||||
in Just Contact {contactId, localDisplayName, profile, activeConn, viaGroup}
|
||||
toContact _ = Nothing
|
||||
|
||||
createSndFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> FilePath -> FileInvitation -> ConnId -> Integer -> m SndFileTransfer
|
||||
createSndFileTransfer st userId contactId filePath FileInvitation {fileName, fileSize} agentConnId chunkSize =
|
||||
createSndFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FilePath -> FileInvitation -> ConnId -> Integer -> m SndFileTransfer
|
||||
createSndFileTransfer st userId Contact {contactId, localDisplayName = recipientDisplayName} filePath FileInvitation {fileName, fileSize} agentConnId chunkSize =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO files (user_id, contact_id, file_name, file_path, file_size, chunk_size) VALUES (?, ?, ?, ?, ?, ?)" (userId, contactId, fileName, filePath, fileSize, chunkSize)
|
||||
fileId <- insertedRowId db
|
||||
@ -1158,6 +1159,17 @@ createSndFileTransfer st userId contactId filePath FileInvitation {fileName, fil
|
||||
DB.execute db "INSERT INTO snd_files (file_id, file_status, connection_id) VALUES (?, ?, ?)" (fileId, fileStatus, connId)
|
||||
pure SndFileTransfer {..}
|
||||
|
||||
createSndGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Group -> [(GroupMember, ConnId, FileInvitation)] -> FilePath -> Integer -> Integer -> m Int64
|
||||
createSndGroupFileTransfer st userId Group {groupId} ms filePath fileSize chunkSize =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
let fileName = takeFileName filePath
|
||||
DB.execute db "INSERT INTO files (user_id, group_id, file_name, file_path, file_size, chunk_size) VALUES (?, ?, ?, ?, ?, ?)" (userId, groupId, fileName, filePath, fileSize, chunkSize)
|
||||
fileId <- insertedRowId db
|
||||
forM_ ms $ \(GroupMember {groupMemberId}, agentConnId, _) -> do
|
||||
Connection {connId} <- createSndFileConnection_ db userId fileId agentConnId
|
||||
DB.execute db "INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id) VALUES (?, ?, ?, ?)" (fileId, FSNew, connId, groupMemberId)
|
||||
pure fileId
|
||||
|
||||
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
|
||||
createSndFileConnection_ db userId fileId agentConnId = do
|
||||
createdAt <- getCurrentTime
|
||||
@ -1218,13 +1230,26 @@ updateSndFileChunkSent st SndFileTransfer {fileId, connId} msgId =
|
||||
|]
|
||||
(fileId, connId, msgId)
|
||||
|
||||
createRcvFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> FileInvitation -> Integer -> m RcvFileTransfer
|
||||
createRcvFileTransfer st userId contactId f@FileInvitation {fileName, fileSize, fileQInfo} chunkSize =
|
||||
deleteSndFileChunks :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> m ()
|
||||
deleteSndFileChunks st SndFileTransfer {fileId, connId} =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute db "DELETE FROM snd_file_chunks WHERE file_id = ? AND connection_id = ?" (fileId, connId)
|
||||
|
||||
createRcvFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> FileInvitation -> Integer -> m RcvFileTransfer
|
||||
createRcvFileTransfer st userId Contact {contactId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileQInfo} chunkSize =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO files (user_id, contact_id, file_name, file_size, chunk_size) VALUES (?, ?, ?, ?, ?)" (userId, contactId, fileName, fileSize, chunkSize)
|
||||
fileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info) VALUES (?, ?, ?)" (fileId, FSNew, fileQInfo)
|
||||
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, chunkSize}
|
||||
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize}
|
||||
|
||||
createRcvGroupFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> GroupMember -> FileInvitation -> Integer -> m RcvFileTransfer
|
||||
createRcvGroupFileTransfer st userId GroupMember {groupId, groupMemberId, localDisplayName = c} f@FileInvitation {fileName, fileSize, fileQInfo} chunkSize =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "INSERT INTO files (user_id, group_id, file_name, file_size, chunk_size) VALUES (?, ?, ?, ?, ?)" (userId, groupId, fileName, fileSize, chunkSize)
|
||||
fileId <- insertedRowId db
|
||||
DB.execute db "INSERT INTO rcv_files (file_id, file_status, file_queue_info, group_member_id) VALUES (?, ?, ?, ?)" (fileId, FSNew, fileQInfo, groupMemberId)
|
||||
pure RcvFileTransfer {fileId, fileInvitation = f, fileStatus = RFSNew, senderDisplayName = c, chunkSize}
|
||||
|
||||
getRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m RcvFileTransfer
|
||||
getRcvFileTransfer st userId fileId =
|
||||
@ -1238,28 +1263,34 @@ getRcvFileTransfer_ db userId fileId =
|
||||
db
|
||||
[sql|
|
||||
SELECT r.file_status, r.file_queue_info, f.file_name,
|
||||
f.file_size, f.chunk_size, f.file_path, c.connection_id, c.agent_conn_id
|
||||
f.file_size, f.chunk_size, 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)
|
||||
LEFT JOIN connections c ON r.file_id = c.rcv_file_id
|
||||
LEFT JOIN contacts cs USING (contact_id)
|
||||
LEFT JOIN group_members m USING (group_member_id)
|
||||
WHERE f.user_id = ? AND f.file_id = ?
|
||||
|]
|
||||
(userId, fileId)
|
||||
where
|
||||
rcvFileTransfer ::
|
||||
[(FileStatus, SMPQueueInfo, String, Integer, Integer, Maybe FilePath, Maybe Int64, Maybe ConnId)] ->
|
||||
[(FileStatus, SMPQueueInfo, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe ConnId)] ->
|
||||
Either StoreError RcvFileTransfer
|
||||
rcvFileTransfer [(fileStatus', fileQInfo, fileName, fileSize, chunkSize, filePath_, connId_, agentConnId_)] =
|
||||
rcvFileTransfer [(fileStatus', fileQInfo, fileName, fileSize, chunkSize, contactName_, memberName_, filePath_, connId_, agentConnId_)] =
|
||||
let fileInv = FileInvitation {fileName, fileSize, fileQInfo}
|
||||
fileInfo = (filePath_, connId_, agentConnId_)
|
||||
in case fileStatus' of
|
||||
FSNew -> Right RcvFileTransfer {fileId, fileInvitation = fileInv, fileStatus = RFSNew, chunkSize}
|
||||
FSAccepted -> ft fileInv RFSAccepted fileInfo
|
||||
FSConnected -> ft fileInv RFSConnected fileInfo
|
||||
FSComplete -> ft fileInv RFSComplete fileInfo
|
||||
FSCancelled -> ft fileInv RFSCancelled fileInfo
|
||||
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}
|
||||
FSAccepted -> ft name fileInv RFSAccepted fileInfo
|
||||
FSConnected -> ft name fileInv RFSConnected fileInfo
|
||||
FSComplete -> ft name fileInv RFSComplete fileInfo
|
||||
FSCancelled -> ft name fileInv RFSCancelled fileInfo
|
||||
where
|
||||
ft fileInvitation rfs = \case
|
||||
ft senderDisplayName fileInvitation rfs = \case
|
||||
(Just filePath, Just connId, Just agentConnId) ->
|
||||
let fileStatus = rfs RcvFileInfo {filePath, connId, agentConnId}
|
||||
in Right RcvFileTransfer {..}
|
||||
@ -1315,6 +1346,11 @@ updatedRcvFileChunkStored st RcvFileTransfer {fileId} chunkNo =
|
||||
|]
|
||||
(fileId, chunkNo)
|
||||
|
||||
deleteRcvFileChunks :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> m ()
|
||||
deleteRcvFileChunks st RcvFileTransfer {fileId} =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute db "DELETE FROM rcv_file_chunks WHERE file_id = ?" (Only fileId)
|
||||
|
||||
getFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m FileTransfer
|
||||
getFileTransfer st userId fileId =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
@ -1354,18 +1390,24 @@ getSndFileTransfers_ db userId fileId =
|
||||
<$> 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.connection_id, c.agent_conn_id,
|
||||
cs.local_display_name, m.local_display_name
|
||||
FROM snd_files s
|
||||
JOIN files f USING (file_id)
|
||||
JOIN connections c USING (connection_id)
|
||||
LEFT JOIN contacts cs USING (contact_id)
|
||||
LEFT JOIN group_members m USING (group_member_id)
|
||||
WHERE f.user_id = ? AND f.file_id = ?
|
||||
|]
|
||||
(userId, fileId)
|
||||
where
|
||||
sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, ConnId)] -> Either StoreError [SndFileTransfer]
|
||||
sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, ConnId, Maybe ContactName, Maybe ContactName)] -> Either StoreError [SndFileTransfer]
|
||||
sndFileTransfers [] = Left $ SESndFileNotFound fileId
|
||||
sndFileTransfers fts = Right $ map sndFileTransfer fts
|
||||
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId) = SndFileTransfer {..}
|
||||
sndFileTransfers fts = mapM sndFileTransfer fts
|
||||
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId, contactName_, memberName_) =
|
||||
case contactName_ <|> memberName_ of
|
||||
Just recipientDisplayName -> Right SndFileTransfer {..}
|
||||
Nothing -> Left $ SESndFileInvalid fileId
|
||||
|
||||
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
|
||||
-- This function should be called inside transaction.
|
||||
@ -1432,6 +1474,7 @@ data StoreError
|
||||
| SEGroupAlreadyJoined
|
||||
| SEGroupInvitationNotFound
|
||||
| SESndFileNotFound Int64
|
||||
| SESndFileInvalid Int64
|
||||
| SERcvFileNotFound Int64
|
||||
| SEFileNotFound Int64
|
||||
| SERcvFileInvalid Int64
|
||||
|
||||
@ -123,6 +123,7 @@ data ReceivedGroupInvitation = ReceivedGroupInvitation
|
||||
|
||||
data GroupMember = GroupMember
|
||||
{ groupMemberId :: Int64,
|
||||
groupId :: Int64,
|
||||
memberId :: MemberId,
|
||||
memberRole :: GroupMemberRole,
|
||||
memberCategory :: GroupMemberCategory,
|
||||
@ -305,6 +306,7 @@ data SndFileTransfer = SndFileTransfer
|
||||
filePath :: String,
|
||||
fileSize :: Integer,
|
||||
chunkSize :: Integer,
|
||||
recipientDisplayName :: ContactName,
|
||||
connId :: Int64,
|
||||
agentConnId :: ConnId,
|
||||
fileStatus :: FileStatus
|
||||
@ -322,6 +324,7 @@ data RcvFileTransfer = RcvFileTransfer
|
||||
{ fileId :: Int64,
|
||||
fileInvitation :: FileInvitation,
|
||||
fileStatus :: RcvFileStatus,
|
||||
senderDisplayName :: ContactName,
|
||||
chunkSize :: Integer
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@ -343,7 +346,7 @@ data RcvFileInfo = RcvFileInfo
|
||||
|
||||
data FileTransfer = FTSnd [SndFileTransfer] | FTRcv RcvFileTransfer
|
||||
|
||||
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Show)
|
||||
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Ord, Show)
|
||||
|
||||
instance FromField FileStatus where fromField = fromTextField_ fileStatusT
|
||||
|
||||
|
||||
@ -25,11 +25,14 @@ module Simplex.Chat.View
|
||||
showSentMessage,
|
||||
showSentGroupMessage,
|
||||
showSentFileInvitation,
|
||||
showSentGroupFileInvitation,
|
||||
showSentFileInfo,
|
||||
showSndFileStart,
|
||||
showSndFileComplete,
|
||||
showSndFileCancelled,
|
||||
showSndGroupFileCancelled,
|
||||
showSndFileRcvCancelled,
|
||||
showReceivedFileInvitation,
|
||||
receivedFileInvitation,
|
||||
showRcvFileAccepted,
|
||||
showRcvFileStart,
|
||||
showRcvFileComplete,
|
||||
@ -58,6 +61,7 @@ module Simplex.Chat.View
|
||||
showContactUpdated,
|
||||
showMessageError,
|
||||
safeDecodeUtf8,
|
||||
msgPlain,
|
||||
)
|
||||
where
|
||||
|
||||
@ -65,7 +69,9 @@ import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Composition ((.:), (.:.))
|
||||
import Data.Function (on)
|
||||
import Data.Int (Int64)
|
||||
import Data.List (groupBy, intersperse, sortOn)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (DiffTime, UTCTime)
|
||||
@ -123,13 +129,13 @@ showGroupRemoved = printToView . groupRemoved
|
||||
showMemberSubError :: ChatReader m => GroupName -> ContactName -> ChatError -> m ()
|
||||
showMemberSubError = printToView .:. memberSubError
|
||||
|
||||
showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> Text -> MsgIntegrity -> m ()
|
||||
showReceivedMessage :: ChatReader m => ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
|
||||
showReceivedMessage = showReceivedMessage_ . ttyFromContact
|
||||
|
||||
showReceivedGroupMessage :: ChatReader m => GroupName -> ContactName -> UTCTime -> Text -> MsgIntegrity -> m ()
|
||||
showReceivedGroupMessage :: ChatReader m => GroupName -> ContactName -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
|
||||
showReceivedGroupMessage = showReceivedMessage_ .: ttyFromGroup
|
||||
|
||||
showReceivedMessage_ :: ChatReader m => StyledString -> UTCTime -> Text -> MsgIntegrity -> m ()
|
||||
showReceivedMessage_ :: ChatReader m => StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> m ()
|
||||
showReceivedMessage_ from utcTime msg mOk = printToView =<< liftIO (receivedMessage from utcTime msg mOk)
|
||||
|
||||
showSentMessage :: ChatReader m => ContactName -> ByteString -> m ()
|
||||
@ -141,37 +147,46 @@ showSentGroupMessage = showSentMessage_ . ttyToGroup
|
||||
showSentMessage_ :: ChatReader m => StyledString -> ByteString -> m ()
|
||||
showSentMessage_ to msg = printToView =<< liftIO (sentMessage to msg)
|
||||
|
||||
showSentFileInvitation :: ChatReader m => ContactName -> SndFileTransfer -> m ()
|
||||
showSentFileInvitation = printToView .: sentFileInvitation
|
||||
showSentFileInvitation :: ChatReader m => ContactName -> FilePath -> m ()
|
||||
showSentFileInvitation = showSentFileInvitation_ . ttyToContact
|
||||
|
||||
showSndFileStart :: ChatReader m => Int64 -> m ()
|
||||
showSentGroupFileInvitation :: ChatReader m => GroupName -> FilePath -> m ()
|
||||
showSentGroupFileInvitation = showSentFileInvitation_ . ttyToGroup
|
||||
|
||||
showSentFileInvitation_ :: ChatReader m => StyledString -> FilePath -> m ()
|
||||
showSentFileInvitation_ to filePath = printToView =<< liftIO (sentFileInvitation to filePath)
|
||||
|
||||
showSentFileInfo :: ChatReader m => Int64 -> m ()
|
||||
showSentFileInfo = printToView . sentFileInfo
|
||||
|
||||
showSndFileStart :: ChatReader m => SndFileTransfer -> m ()
|
||||
showSndFileStart = printToView . sndFileStart
|
||||
|
||||
showSndFileComplete :: ChatReader m => Int64 -> m ()
|
||||
showSndFileComplete :: ChatReader m => SndFileTransfer -> m ()
|
||||
showSndFileComplete = printToView . sndFileComplete
|
||||
|
||||
showSndFileCancelled :: ChatReader m => Int64 -> m ()
|
||||
showSndFileCancelled :: ChatReader m => SndFileTransfer -> m ()
|
||||
showSndFileCancelled = printToView . sndFileCancelled
|
||||
|
||||
showSndFileRcvCancelled :: ChatReader m => Int64 -> m ()
|
||||
showSndGroupFileCancelled :: ChatReader m => [SndFileTransfer] -> m ()
|
||||
showSndGroupFileCancelled = printToView . sndGroupFileCancelled
|
||||
|
||||
showSndFileRcvCancelled :: ChatReader m => SndFileTransfer -> m ()
|
||||
showSndFileRcvCancelled = printToView . sndFileRcvCancelled
|
||||
|
||||
showReceivedFileInvitation :: ChatReader m => ContactName -> RcvFileTransfer -> m ()
|
||||
showReceivedFileInvitation = printToView .: receivedFileInvitation
|
||||
|
||||
showRcvFileAccepted :: ChatReader m => Int64 -> FilePath -> m ()
|
||||
showRcvFileAccepted :: ChatReader m => RcvFileTransfer -> FilePath -> m ()
|
||||
showRcvFileAccepted = printToView .: rcvFileAccepted
|
||||
|
||||
showRcvFileStart :: ChatReader m => Int64 -> m ()
|
||||
showRcvFileStart :: ChatReader m => RcvFileTransfer -> m ()
|
||||
showRcvFileStart = printToView . rcvFileStart
|
||||
|
||||
showRcvFileComplete :: ChatReader m => Int64 -> m ()
|
||||
showRcvFileComplete :: ChatReader m => RcvFileTransfer -> m ()
|
||||
showRcvFileComplete = printToView . rcvFileComplete
|
||||
|
||||
showRcvFileCancelled :: ChatReader m => Int64 -> m ()
|
||||
showRcvFileCancelled :: ChatReader m => RcvFileTransfer -> m ()
|
||||
showRcvFileCancelled = printToView . rcvFileCancelled
|
||||
|
||||
showRcvFileSndCancelled :: ChatReader m => Int64 -> m ()
|
||||
showRcvFileSndCancelled :: ChatReader m => RcvFileTransfer -> m ()
|
||||
showRcvFileSndCancelled = printToView . rcvFileSndCancelled
|
||||
|
||||
showFileTransferStatus :: ChatReader m => (FileTransfer, [Integer]) -> m ()
|
||||
@ -409,10 +424,10 @@ contactUpdated
|
||||
messageError :: Text -> Text -> [StyledString]
|
||||
messageError prefix err = [plain prefix <> ": " <> plain err]
|
||||
|
||||
receivedMessage :: StyledString -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage :: StyledString -> UTCTime -> [StyledString] -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage from utcTime msg mOk = do
|
||||
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
|
||||
pure $ prependFirst (t <> " " <> from) (msgPlain msg) ++ showIntegrity mOk
|
||||
pure $ prependFirst (t <> " " <> from) msg ++ showIntegrity mOk
|
||||
where
|
||||
formatUTCTime :: TimeZone -> ZonedTime -> StyledString
|
||||
formatUTCTime localTz currentTime =
|
||||
@ -436,9 +451,15 @@ receivedMessage from utcTime msg mOk = do
|
||||
msgError s = [styled (Colored Red) s]
|
||||
|
||||
sentMessage :: StyledString -> ByteString -> IO [StyledString]
|
||||
sentMessage to msg = do
|
||||
sentMessage to msg = sendWithTime_ to . msgPlain $ safeDecodeUtf8 msg
|
||||
|
||||
sentFileInvitation :: StyledString -> FilePath -> IO [StyledString]
|
||||
sentFileInvitation to f = sendWithTime_ ("/f " <> to) [ttyFilePath f]
|
||||
|
||||
sendWithTime_ :: StyledString -> [StyledString] -> IO [StyledString]
|
||||
sendWithTime_ to styledMsg = do
|
||||
time <- formatTime defaultTimeLocale "%H:%M" <$> getZonedTime
|
||||
pure $ prependFirst (styleTime time <> " " <> to) (msgPlain $ safeDecodeUtf8 msg)
|
||||
pure $ prependFirst (styleTime time <> " " <> to) styledMsg
|
||||
|
||||
prependFirst :: StyledString -> [StyledString] -> [StyledString]
|
||||
prependFirst s [] = [s]
|
||||
@ -447,27 +468,39 @@ prependFirst s (s' : ss) = (s <> s') : ss
|
||||
msgPlain :: Text -> [StyledString]
|
||||
msgPlain = map styleMarkdownText . T.lines
|
||||
|
||||
sentFileInvitation :: ContactName -> SndFileTransfer -> [StyledString]
|
||||
sentFileInvitation cName SndFileTransfer {fileId, fileName} =
|
||||
[ "offered to send the file " <> plain fileName <> " to " <> ttyContact cName,
|
||||
"use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"
|
||||
]
|
||||
sentFileInfo :: Int64 -> [StyledString]
|
||||
sentFileInfo fileId =
|
||||
["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"]
|
||||
|
||||
sndFileStart :: Int64 -> [StyledString]
|
||||
sndFileStart fileId = ["started sending the file " <> sShow fileId]
|
||||
sndFileStart :: SndFileTransfer -> [StyledString]
|
||||
sndFileStart = sendingFile_ "started"
|
||||
|
||||
sndFileComplete :: Int64 -> [StyledString]
|
||||
sndFileComplete fileId = ["completed sending the file " <> sShow fileId]
|
||||
sndFileComplete :: SndFileTransfer -> [StyledString]
|
||||
sndFileComplete = sendingFile_ "completed"
|
||||
|
||||
sndFileCancelled :: Int64 -> [StyledString]
|
||||
sndFileCancelled fileId = ["cancelled sending the file " <> sShow fileId]
|
||||
sndFileCancelled :: SndFileTransfer -> [StyledString]
|
||||
sndFileCancelled = sendingFile_ "cancelled"
|
||||
|
||||
sndFileRcvCancelled :: Int64 -> [StyledString]
|
||||
sndFileRcvCancelled fileId = ["recipient cancelled receiving the file " <> sShow fileId]
|
||||
sndGroupFileCancelled :: [SndFileTransfer] -> [StyledString]
|
||||
sndGroupFileCancelled 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]
|
||||
|
||||
receivedFileInvitation :: ContactName -> RcvFileTransfer -> [StyledString]
|
||||
receivedFileInvitation c RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} =
|
||||
[ ttyContact c <> " wants to send you the file " <> plain fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)",
|
||||
sendingFile_ :: StyledString -> SndFileTransfer -> [StyledString]
|
||||
sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[status <> " sending " <> sndFile ft <> " to " <> ttyContact c]
|
||||
|
||||
sndFileRcvCancelled :: SndFileTransfer -> [StyledString]
|
||||
sndFileRcvCancelled ft@SndFileTransfer {recipientDisplayName = c} =
|
||||
[ttyContact c <> " cancelled receiving " <> sndFile ft]
|
||||
|
||||
sndFile :: SndFileTransfer -> StyledString
|
||||
sndFile SndFileTransfer {fileId, fileName} = fileTransfer fileId fileName
|
||||
|
||||
receivedFileInvitation :: RcvFileTransfer -> [StyledString]
|
||||
receivedFileInvitation RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName, fileSize}} =
|
||||
[ "sends file " <> ttyFilePath fileName <> " (" <> humanReadableSize fileSize <> " / " <> sShow fileSize <> " bytes)",
|
||||
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
|
||||
]
|
||||
|
||||
@ -483,41 +516,71 @@ humanReadableSize size
|
||||
mB = kB * 1024
|
||||
gB = mB * 1024
|
||||
|
||||
rcvFileAccepted :: Int64 -> FilePath -> [StyledString]
|
||||
rcvFileAccepted fileId filePath = ["saving file " <> sShow fileId <> " to " <> plain filePath]
|
||||
rcvFileAccepted :: RcvFileTransfer -> FilePath -> [StyledString]
|
||||
rcvFileAccepted RcvFileTransfer {fileId, senderDisplayName = c} filePath =
|
||||
["saving file " <> sShow fileId <> " from " <> ttyContact c <> " to " <> plain filePath]
|
||||
|
||||
rcvFileStart :: Int64 -> [StyledString]
|
||||
rcvFileStart fileId = ["started receiving the file " <> sShow fileId]
|
||||
rcvFileStart :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileStart = receivingFile_ "started"
|
||||
|
||||
rcvFileComplete :: Int64 -> [StyledString]
|
||||
rcvFileComplete fileId = ["completed receiving the file " <> sShow fileId]
|
||||
rcvFileComplete :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileComplete = receivingFile_ "completed"
|
||||
|
||||
rcvFileCancelled :: Int64 -> [StyledString]
|
||||
rcvFileCancelled fileId = ["cancelled receiving the file " <> sShow fileId]
|
||||
rcvFileCancelled :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileCancelled = receivingFile_ "cancelled"
|
||||
|
||||
rcvFileSndCancelled :: Int64 -> [StyledString]
|
||||
rcvFileSndCancelled fileId = ["sender cancelled sending the file " <> sShow fileId]
|
||||
receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
|
||||
receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[status <> " receiving " <> rcvFile ft <> " from " <> ttyContact c]
|
||||
|
||||
rcvFileSndCancelled :: RcvFileTransfer -> [StyledString]
|
||||
rcvFileSndCancelled ft@RcvFileTransfer {senderDisplayName = c} =
|
||||
[ttyContact c <> " cancelled sending " <> rcvFile ft]
|
||||
|
||||
rcvFile :: RcvFileTransfer -> StyledString
|
||||
rcvFile RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} = fileTransfer fileId fileName
|
||||
|
||||
fileTransfer :: Int64 -> String -> StyledString
|
||||
fileTransfer fileId fileName = "file " <> sShow fileId <> " (" <> ttyFilePath fileName <> ")"
|
||||
|
||||
fileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
|
||||
fileTransferStatus (FTSnd [SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
|
||||
["sent file transfer " <> sndStatus]
|
||||
fileTransferStatus (FTSnd [ft@SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
|
||||
["sending " <> sndFile ft <> " " <> sndStatus]
|
||||
where
|
||||
sndStatus = case fileStatus of
|
||||
FSNew -> "is not accepted yet"
|
||||
FSNew -> "not accepted yet"
|
||||
FSAccepted -> "just started"
|
||||
FSConnected -> "progress: " <> fileProgress chunksNum chunkSize fileSize
|
||||
FSComplete -> "is complete"
|
||||
FSCancelled -> "is cancelled"
|
||||
fileTransferStatus (FTSnd _fts, _chunks) = [] -- TODO group transfer
|
||||
fileTransferStatus (FTRcv RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, fileStatus, chunkSize}, chunksNum) =
|
||||
["received file transfer " <> rcvStatus]
|
||||
FSConnected -> "progress " <> fileProgress chunksNum chunkSize fileSize
|
||||
FSComplete -> "complete"
|
||||
FSCancelled -> "cancelled"
|
||||
fileTransferStatus (FTSnd [], _) = ["no file transfers (empty group)"]
|
||||
fileTransferStatus (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
|
||||
where
|
||||
fs = fileStatus :: SndFileTransfer -> FileStatus
|
||||
membersTransferStatus [] = []
|
||||
membersTransferStatus ts@(SndFileTransfer {fileStatus, fileSize, chunkSize} : _) = [sndStatus <> ": " <> listMembers ts]
|
||||
where
|
||||
sndStatus = case fileStatus of
|
||||
FSNew -> "not accepted"
|
||||
FSAccepted -> "just started"
|
||||
FSConnected -> "in progress (" <> sShow (sum chunksNum * chunkSize * 100 `div` (toInteger (length chunksNum) * fileSize)) <> "%)"
|
||||
FSComplete -> "complete"
|
||||
FSCancelled -> "cancelled"
|
||||
fileTransferStatus (FTRcv ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, fileStatus, chunkSize}, chunksNum) =
|
||||
["receiving " <> rcvFile ft <> " " <> rcvStatus]
|
||||
where
|
||||
rcvStatus = case fileStatus of
|
||||
RFSNew -> "is not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"
|
||||
RFSNew -> "not accepted yet, use " <> highlight ("/fr " <> show fileId) <> " to receive file"
|
||||
RFSAccepted _ -> "just started"
|
||||
RFSConnected _ -> "progress: " <> fileProgress chunksNum chunkSize fileSize
|
||||
RFSComplete RcvFileInfo {filePath} -> "is complete, path: " <> plain filePath
|
||||
RFSCancelled RcvFileInfo {filePath} -> "is cancelled, received part path: " <> plain filePath
|
||||
RFSConnected _ -> "progress " <> fileProgress chunksNum chunkSize fileSize
|
||||
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)
|
||||
|
||||
fileProgress :: [Integer] -> Integer -> Integer -> StyledString
|
||||
fileProgress chunksNum chunkSize fileSize =
|
||||
@ -606,6 +669,9 @@ ttyFromGroup g c = styled (Colored Yellow) $ "#" <> g <> " " <> c <> "> "
|
||||
ttyToGroup :: GroupName -> StyledString
|
||||
ttyToGroup g = styled (Colored Cyan) $ "#" <> g <> " "
|
||||
|
||||
ttyFilePath :: FilePath -> StyledString
|
||||
ttyFilePath = plain
|
||||
|
||||
optFullName :: ContactName -> Text -> StyledString
|
||||
optFullName localDisplayName fullName
|
||||
| T.null fullName || localDisplayName == fullName = ""
|
||||
|
||||
@ -43,7 +43,7 @@ extra-deps:
|
||||
# - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688
|
||||
# - ../simplexmq
|
||||
- github: simplex-chat/simplexmq
|
||||
commit: 2ac903a2dd37c11a8612b19cd132cf43fe771fe4
|
||||
commit: e07bedac0e59346f076d71635ce6cd25de67ca7e
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
|
||||
@ -44,6 +44,7 @@ chatTests = do
|
||||
it "send and receive file" testFileTransfer
|
||||
it "sender cancelled file transfer" testFileSndCancel
|
||||
it "recipient cancelled file transfer" testFileRcvCancel
|
||||
it "send and receive file to group" testGroupFileTransfer
|
||||
|
||||
testAddContact :: IO ()
|
||||
testAddContact =
|
||||
@ -410,10 +411,10 @@ testFileTransfer =
|
||||
concurrentlyN_
|
||||
[ do
|
||||
bob #> "@alice receiving here..."
|
||||
bob <## "completed receiving the file 1",
|
||||
bob <## "completed receiving file 1 (test.jpg) from alice",
|
||||
do
|
||||
alice <# "bob> receiving here..."
|
||||
alice <## "completed sending the file 1"
|
||||
alice <## "completed sending file 1 (test.jpg) to bob"
|
||||
]
|
||||
src <- B.readFile "./tests/fixtures/test.jpg"
|
||||
dest <- B.readFile "./tests/tmp/test.jpg"
|
||||
@ -428,13 +429,13 @@ testFileSndCancel =
|
||||
alice ##> "/fc 1"
|
||||
concurrentlyN_
|
||||
[ do
|
||||
alice <## "cancelled sending the file 1"
|
||||
alice <## "cancelled sending file 1 (test.jpg) to bob"
|
||||
alice ##> "/fs 1"
|
||||
alice <## "sent file transfer is cancelled",
|
||||
alice <## "sending file 1 (test.jpg) cancelled",
|
||||
do
|
||||
bob <## "sender cancelled sending the file 1"
|
||||
bob <## "alice cancelled sending file 1 (test.jpg)"
|
||||
bob ##> "/fs 1"
|
||||
bob <## "received file transfer is cancelled, received part path: ./tests/tmp/test.jpg"
|
||||
bob <## "receiving file 1 (test.jpg) cancelled, received part path: ./tests/tmp/test.jpg"
|
||||
]
|
||||
checkPartialTransfer
|
||||
|
||||
@ -445,35 +446,77 @@ testFileRcvCancel =
|
||||
connectUsers alice bob
|
||||
startFileTransfer alice bob
|
||||
bob ##> "/fs 1"
|
||||
getTermLine bob >>= (`shouldStartWith` "received file transfer progress:")
|
||||
getTermLine bob >>= (`shouldStartWith` "receiving file 1 (test.jpg) progress")
|
||||
waitFileExists "./tests/tmp/test.jpg"
|
||||
bob ##> "/fc 1"
|
||||
concurrentlyN_
|
||||
[ do
|
||||
bob <## "cancelled receiving the file 1"
|
||||
bob <## "cancelled receiving file 1 (test.jpg) from alice"
|
||||
bob ##> "/fs 1"
|
||||
bob <## "received file transfer is cancelled, received part path: ./tests/tmp/test.jpg",
|
||||
bob <## "receiving file 1 (test.jpg) cancelled, received part path: ./tests/tmp/test.jpg",
|
||||
do
|
||||
alice <## "recipient cancelled receiving the file 1"
|
||||
alice <## "bob cancelled receiving file 1 (test.jpg)"
|
||||
alice ##> "/fs 1"
|
||||
alice <## "sent file transfer is cancelled"
|
||||
alice <## "sending file 1 (test.jpg) cancelled"
|
||||
]
|
||||
checkPartialTransfer
|
||||
where
|
||||
waitFileExists f = unlessM (doesFileExist f) $ waitFileExists f
|
||||
|
||||
testGroupFileTransfer :: IO ()
|
||||
testGroupFileTransfer =
|
||||
testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
createGroup3 "team" alice bob cath
|
||||
alice #> "/f #team ./tests/fixtures/test.jpg"
|
||||
alice <## "use /fc 1 to cancel sending"
|
||||
concurrentlyN_
|
||||
[ do
|
||||
bob <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
|
||||
bob <## "use /fr 1 [<dir>/ | <path>] to receive it",
|
||||
do
|
||||
cath <# "#team alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
|
||||
cath <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
]
|
||||
alice ##> "/fs 1"
|
||||
getTermLine alice >>= (`shouldStartWith` "sending file 1 (test.jpg) not accepted")
|
||||
bob ##> "/fr 1 ./tests/tmp/"
|
||||
bob <## "saving file 1 from alice to ./tests/tmp/test.jpg"
|
||||
concurrentlyN_
|
||||
[ do
|
||||
alice <## "started sending file 1 (test.jpg) to bob"
|
||||
alice <## "completed sending file 1 (test.jpg) to bob"
|
||||
alice ##> "/fs 1"
|
||||
alice <## "sending file 1 (test.jpg):"
|
||||
alice <### [" complete: bob", " not accepted: cath"],
|
||||
do
|
||||
bob <## "started receiving file 1 (test.jpg) from alice"
|
||||
bob <## "completed receiving file 1 (test.jpg) from alice"
|
||||
]
|
||||
cath ##> "/fr 1 ./tests/tmp/"
|
||||
cath <## "saving file 1 from alice to ./tests/tmp/test_1.jpg"
|
||||
concurrentlyN_
|
||||
[ do
|
||||
alice <## "started sending file 1 (test.jpg) to cath"
|
||||
alice <## "completed sending file 1 (test.jpg) to cath"
|
||||
alice ##> "/fs 1"
|
||||
getTermLine alice >>= (`shouldStartWith` "sending file 1 (test.jpg) complete"),
|
||||
do
|
||||
cath <## "started receiving file 1 (test.jpg) from alice"
|
||||
cath <## "completed receiving file 1 (test.jpg) from alice"
|
||||
]
|
||||
|
||||
startFileTransfer :: TestCC -> TestCC -> IO ()
|
||||
startFileTransfer alice bob = do
|
||||
alice ##> "/f bob ./tests/fixtures/test.jpg"
|
||||
alice <## "offered to send the file test.jpg to bob"
|
||||
alice #> "/f @bob ./tests/fixtures/test.jpg"
|
||||
alice <## "use /fc 1 to cancel sending"
|
||||
bob <## "alice wants to send you the file test.jpg (136.5 KiB / 139737 bytes)"
|
||||
bob <# "alice> sends file test.jpg (136.5 KiB / 139737 bytes)"
|
||||
bob <## "use /fr 1 [<dir>/ | <path>] to receive it"
|
||||
bob ##> "/fr 1 ./tests/tmp"
|
||||
bob <## "saving file 1 to ./tests/tmp/test.jpg"
|
||||
bob <## "saving file 1 from alice to ./tests/tmp/test.jpg"
|
||||
concurrently_
|
||||
(bob <## "started receiving the file 1")
|
||||
(alice <## "started sending the file 1")
|
||||
(bob <## "started receiving file 1 (test.jpg) from alice")
|
||||
(alice <## "started sending file 1 (test.jpg) to bob")
|
||||
|
||||
checkPartialTransfer :: IO ()
|
||||
checkPartialTransfer = do
|
||||
|
||||
Loading…
Reference in New Issue
Block a user