send files to contacts (#94)
* schema for sending files * send file "invitation" * receive file "invitation" * send/receive file flow (with stubs) * update simplexmq * send and receive the file (WIP - only the first chunk) * sending and receiving file works (but it is slow) * use correct terminal output for file sending/receiving * improve file transfer, support cancellation * command to show file transfer status and progress * file transfer tests * resume file transfer on restart (WIP) * stabilize test of recipient cancelling file transfer * trying to improve file transfer on restart * update SMP block size and file chunk size * acquire agent lock before chat lock to test whether it avoids deadlock * fix resuming sending file on client restart * manual message ACK (prevents losing messages between agent and chat client and stabilizes resuming file reception after restart) * do NOT send file chunk after receiving it before it is appended to the file * update file chunk size for SMP block size 8192 (set in smpDefaultConfig) * save received files to ~/Downloads folder by default; create empty file when file is accepted * keep file handle used to create empty file * check message integrity * fix trying to resume sending file when it was not yet accepted * fix subscribing to pending connections on start * update simplexmq (fixes smp-server syntax parser)
This commit is contained in:
parent
97fde7ecd0
commit
c51493e016
@ -130,17 +130,68 @@ CREATE TABLE group_member_intros (
|
||||
UNIQUE (re_group_member_id, to_group_member_id)
|
||||
);
|
||||
|
||||
CREATE TABLE files (
|
||||
file_id INTEGER PRIMARY KEY,
|
||||
contact_id INTEGER REFERENCES contacts ON DELETE RESTRICT,
|
||||
group_id INTEGER REFERENCES groups ON DELETE RESTRICT,
|
||||
file_name TEXT NOT NULL,
|
||||
file_path TEXT,
|
||||
file_size INTEGER NOT NULL,
|
||||
chunk_size INTEGER NOT NULL,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
user_id INTEGER NOT NULL REFERENCES users
|
||||
);
|
||||
|
||||
CREATE TABLE snd_files (
|
||||
file_id INTEGER NOT NULL REFERENCES files ON DELETE RESTRICT,
|
||||
connection_id INTEGER NOT NULL REFERENCES connections ON DELETE RESTRICT,
|
||||
file_status TEXT NOT NULL, -- new, accepted, connected, completed
|
||||
group_member_id INTEGER REFERENCES group_members ON DELETE RESTRICT,
|
||||
PRIMARY KEY (file_id, connection_id)
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE rcv_files (
|
||||
file_id INTEGER PRIMARY KEY REFERENCES files ON DELETE RESTRICT,
|
||||
file_status TEXT NOT NULL, -- new, accepted, connected, completed
|
||||
group_member_id INTEGER REFERENCES group_members ON DELETE RESTRICT,
|
||||
file_queue_info BLOB
|
||||
);
|
||||
|
||||
CREATE TABLE snd_file_chunks (
|
||||
file_id INTEGER NOT NULL,
|
||||
connection_id INTEGER NOT NULL,
|
||||
chunk_number INTEGER NOT NULL,
|
||||
chunk_agent_msg_id INTEGER,
|
||||
chunk_sent INTEGER NOT NULL DEFAULT 0, -- 0 (sent to agent), 1 (sent to server)
|
||||
FOREIGN KEY (file_id, connection_id) REFERENCES snd_files ON DELETE CASCADE,
|
||||
PRIMARY KEY (file_id, connection_id, chunk_number)
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE rcv_file_chunks (
|
||||
file_id INTEGER NOT NULL REFERENCES rcv_files,
|
||||
chunk_number INTEGER NOT NULL,
|
||||
chunk_agent_msg_id INTEGER NOT NULL,
|
||||
chunk_stored INTEGER NOT NULL DEFAULT 0, -- 0 (received), 1 (appended to file)
|
||||
PRIMARY KEY (file_id, chunk_number)
|
||||
) WITHOUT ROWID;
|
||||
|
||||
CREATE TABLE connections ( -- all SMP agent connections
|
||||
connection_id INTEGER PRIMARY KEY,
|
||||
agent_conn_id BLOB NOT NULL UNIQUE,
|
||||
conn_level INTEGER NOT NULL DEFAULT 0,
|
||||
via_contact INTEGER REFERENCES contacts (contact_id),
|
||||
conn_status TEXT NOT NULL,
|
||||
conn_type TEXT NOT NULL, -- contact, member, member_direct
|
||||
conn_type TEXT NOT NULL, -- contact, member, rcv_file, snd_file
|
||||
contact_id INTEGER REFERENCES contacts ON DELETE RESTRICT,
|
||||
group_member_id INTEGER REFERENCES group_members ON DELETE RESTRICT,
|
||||
snd_file_id INTEGER,
|
||||
rcv_file_id INTEGER REFERENCES rcv_files (file_id) ON DELETE RESTRICT,
|
||||
created_at TEXT NOT NULL DEFAULT (datetime('now')),
|
||||
user_id INTEGER NOT NULL REFERENCES users
|
||||
user_id INTEGER NOT NULL REFERENCES users,
|
||||
FOREIGN KEY (snd_file_id, connection_id)
|
||||
REFERENCES snd_files (file_id, connection_id)
|
||||
ON DELETE RESTRICT
|
||||
DEFERRABLE INITIALLY DEFERRED
|
||||
);
|
||||
|
||||
CREATE TABLE events ( -- messages received by the agent, append only
|
||||
|
@ -12,7 +12,8 @@
|
||||
|
||||
module Simplex.Chat where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Applicative (optional, (<|>))
|
||||
import Control.Concurrent.STM (stateTVar)
|
||||
import Control.Logger.Simple
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
@ -24,12 +25,14 @@ import Data.Bifunctor (first)
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (isJust, mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Numeric.Natural
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Help
|
||||
import Simplex.Chat.Input
|
||||
@ -40,18 +43,24 @@ import Simplex.Chat.Store
|
||||
import Simplex.Chat.Styled (plain)
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (ifM, unlessM)
|
||||
import Simplex.Chat.View
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (raceAny_)
|
||||
import qualified Simplex.Messaging.Protocol as SMP
|
||||
import Simplex.Messaging.Util (bshow, raceAny_)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import System.IO (hFlush, stdout)
|
||||
import System.FilePath (combine, splitExtensions, takeFileName)
|
||||
import System.IO (Handle, IOMode (..), SeekMode (..), hFlush, openFile, stdout)
|
||||
import Text.Read (readMaybe)
|
||||
import UnliftIO.Async (race_)
|
||||
import UnliftIO.Concurrent (forkIO, threadDelay)
|
||||
import UnliftIO.Directory (doesDirectoryExist, doesFileExist, getFileSize, getHomeDirectory, getTemporaryDirectory)
|
||||
import qualified UnliftIO.Exception as E
|
||||
import UnliftIO.IO (hClose, hSeek, hTell)
|
||||
import UnliftIO.STM
|
||||
|
||||
data ChatCommand
|
||||
@ -70,17 +79,16 @@ data ChatCommand
|
||||
| DeleteGroup GroupName
|
||||
| ListMembers GroupName
|
||||
| SendGroupMessage GroupName ByteString
|
||||
| SendFile ContactName FilePath
|
||||
| SendGroupFile GroupName FilePath
|
||||
| ReceiveFile Int64 (Maybe FilePath)
|
||||
| CancelFile Int64
|
||||
| FileStatus Int64
|
||||
| UpdateProfile Profile
|
||||
| ShowProfile
|
||||
| QuitChat
|
||||
deriving (Show)
|
||||
|
||||
data ChatConfig = ChatConfig
|
||||
{ agentConfig :: AgentConfig,
|
||||
dbPoolSize :: Int,
|
||||
tbqSize :: Natural
|
||||
}
|
||||
|
||||
defaultChatConfig :: ChatConfig
|
||||
defaultChatConfig =
|
||||
ChatConfig
|
||||
@ -92,7 +100,8 @@ defaultChatConfig =
|
||||
dbPoolSize = 1
|
||||
},
|
||||
dbPoolSize = 1,
|
||||
tbqSize = 16
|
||||
tbqSize = 16,
|
||||
fileChunkSize = 7050
|
||||
}
|
||||
|
||||
logCfg :: LogConfig
|
||||
@ -107,7 +116,7 @@ simplexChat cfg opts t =
|
||||
>>= runSimplexChat
|
||||
|
||||
newChatController :: WithTerminal t => ChatConfig -> ChatOpts -> t -> (Notification -> IO ()) -> IO ChatController
|
||||
newChatController ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {dbFile, smpServers} t sendNotification = do
|
||||
newChatController config@ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {dbFile, smpServers} t sendNotification = do
|
||||
chatStore <- createStore (dbFile <> ".chat.db") dbPoolSize
|
||||
currentUser <- newTVarIO =<< getCreateActiveUser chatStore
|
||||
chatTerminal <- newChatTerminal t
|
||||
@ -116,6 +125,8 @@ newChatController ChatConfig {agentConfig = cfg, dbPoolSize, tbqSize} ChatOpts {
|
||||
inputQ <- newTBQueueIO tbqSize
|
||||
notifyQ <- newTBQueueIO tbqSize
|
||||
chatLock <- newTMVarIO ()
|
||||
sndFiles <- newTVarIO M.empty
|
||||
rcvFiles <- newTVarIO M.empty
|
||||
pure ChatController {..}
|
||||
|
||||
runSimplexChat :: ChatController -> IO ()
|
||||
@ -139,6 +150,7 @@ inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
inputSubscriber = do
|
||||
q <- asks inputQ
|
||||
l <- asks chatLock
|
||||
a <- asks smpAgent
|
||||
forever $
|
||||
atomically (readTBQueue q) >>= \case
|
||||
InputControl _ -> pure ()
|
||||
@ -151,10 +163,10 @@ inputSubscriber = do
|
||||
SendGroupMessage g msg -> showSentGroupMessage g msg
|
||||
_ -> printToView [plain s]
|
||||
user <- readTVarIO =<< asks currentUser
|
||||
withLock l . void . runExceptT $
|
||||
withAgentLock a . withLock l . void . runExceptT $
|
||||
processChatCommand user cmd `catchError` showChatError
|
||||
|
||||
processChatCommand :: ChatMonad m => User -> ChatCommand -> m ()
|
||||
processChatCommand :: forall m. ChatMonad m => User -> ChatCommand -> m ()
|
||||
processChatCommand user@User {userId, profile} = \case
|
||||
ChatHelp -> printToView chatHelpInfo
|
||||
MarkdownHelp -> printToView markdownInfo
|
||||
@ -247,6 +259,36 @@ processChatCommand user@User {userId, profile} = \case
|
||||
let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}]
|
||||
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
|
||||
(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
|
||||
sendDirectMessage (contactConnId contact) $ XFile fileInv
|
||||
showSentFileInvitation cName ft
|
||||
setActive $ ActiveC cName
|
||||
SendGroupFile _gName _file -> pure ()
|
||||
ReceiveFile fileId filePath_ -> do
|
||||
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
|
||||
CancelFile fileId ->
|
||||
withStore (\st -> getFileTransfer st userId fileId) >>= \case
|
||||
FTSnd fts -> do
|
||||
mapM_ cancelSndFileTransfer fts
|
||||
showSndFileCancelled fileId
|
||||
FTRcv ft -> do
|
||||
cancelRcvFileTransfer ft
|
||||
showRcvFileCancelled fileId
|
||||
FileStatus fileId ->
|
||||
withStore (\st -> getFileTransferProgress st userId fileId) >>= showFileTransferStatus
|
||||
UpdateProfile p -> unless (p == profile) $ do
|
||||
user' <- withStore $ \st -> updateUserProfile st user p
|
||||
asks currentUser >>= atomically . (`writeTVar` user')
|
||||
@ -260,6 +302,37 @@ processChatCommand user@User {userId, profile} = \case
|
||||
contactMember Contact {contactId} =
|
||||
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
|
||||
cId == Just contactId && s /= GSMemRemoved && s /= GSMemLeft
|
||||
getRcvFilePath :: Int64 -> Maybe FilePath -> String -> m FilePath
|
||||
getRcvFilePath fileId filePath fileName = case filePath of
|
||||
Nothing -> do
|
||||
dir <- (`combine` "Downloads") <$> getHomeDirectory
|
||||
ifM (doesDirectoryExist dir) (pure dir) getTemporaryDirectory
|
||||
>>= (`uniqueCombine` fileName)
|
||||
>>= createEmptyFile
|
||||
Just fPath ->
|
||||
ifM
|
||||
(doesDirectoryExist fPath)
|
||||
(fPath `uniqueCombine` fileName >>= createEmptyFile)
|
||||
$ ifM
|
||||
(doesFileExist fPath)
|
||||
(chatError $ CEFileAlreadyExists fPath)
|
||||
(createEmptyFile fPath)
|
||||
where
|
||||
createEmptyFile :: FilePath -> m FilePath
|
||||
createEmptyFile fPath = emptyFile fPath `E.catch` (chatError . CEFileWrite fPath)
|
||||
emptyFile :: FilePath -> m FilePath
|
||||
emptyFile fPath = do
|
||||
h <- getFileHandle fileId fPath rcvFiles AppendMode
|
||||
liftIO $ B.hPut h "" >> hFlush h
|
||||
pure fPath
|
||||
uniqueCombine :: FilePath -> String -> m FilePath
|
||||
uniqueCombine filePath fileName = tryCombine (0 :: Int)
|
||||
where
|
||||
tryCombine n =
|
||||
let (name, ext) = splitExtensions fileName
|
||||
suffix = if n == 0 then "" else "_" <> show n
|
||||
f = filePath `combine` (name <> suffix <> ext)
|
||||
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
|
||||
|
||||
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
agentSubscriber = do
|
||||
@ -269,15 +342,15 @@ agentSubscriber = do
|
||||
forever $ do
|
||||
(_, connId, msg) <- atomically $ readTBQueue q
|
||||
user <- readTVarIO =<< asks currentUser
|
||||
-- TODO handle errors properly
|
||||
withLock l . void . runExceptT $
|
||||
processAgentMessage user connId msg `catchError` (liftIO . print)
|
||||
processAgentMessage user connId msg `catchError` showChatError
|
||||
|
||||
subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
subscribeUserConnections = void . runExceptT $ do
|
||||
user <- readTVarIO =<< asks currentUser
|
||||
subscribeContacts user
|
||||
subscribeGroups user
|
||||
subscribeFiles user
|
||||
subscribePendingConnections user
|
||||
where
|
||||
subscribeContacts user = do
|
||||
@ -297,6 +370,27 @@ subscribeUserConnections = void . runExceptT $ do
|
||||
forM_ connectedMembers $ \(GroupMember {localDisplayName = c}, cId) ->
|
||||
subscribe cId `catchError` showMemberSubError g c
|
||||
showGroupSubscribed g
|
||||
subscribeFiles user = do
|
||||
withStore (`getLiveSndFileTransfers` user) >>= mapM_ subscribeSndFile
|
||||
withStore (`getLiveRcvFileTransfers` user) >>= mapM_ subscribeRcvFile
|
||||
where
|
||||
subscribeSndFile ft@SndFileTransfer {fileId, fileStatus, agentConnId} = do
|
||||
subscribe agentConnId `catchError` showSndFileSubError ft
|
||||
void . forkIO $ do
|
||||
threadDelay 1000000
|
||||
l <- asks chatLock
|
||||
a <- asks smpAgent
|
||||
unless (fileStatus == FSNew) . unlessM (isFileActive fileId sndFiles) $
|
||||
withAgentLock a . withLock l $
|
||||
sendFileChunk ft
|
||||
subscribeRcvFile ft@RcvFileTransfer {fileStatus} =
|
||||
case fileStatus of
|
||||
RFSAccepted fInfo -> resume fInfo
|
||||
RFSConnected fInfo -> resume fInfo
|
||||
_ -> pure ()
|
||||
where
|
||||
resume RcvFileInfo {agentConnId} =
|
||||
subscribe agentConnId `catchError` showRcvFileSubError ft
|
||||
subscribePendingConnections user = do
|
||||
connections <- withStore (`getPendingConnections` user)
|
||||
forM_ connections $ \Connection {agentConnId} ->
|
||||
@ -304,7 +398,7 @@ subscribeUserConnections = void . runExceptT $ do
|
||||
subscribe cId = withAgent (`subscribeConnection` cId)
|
||||
|
||||
processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m ()
|
||||
processAgentMessage user@User {userId, profile} agentConnId agentMessage = unless (sent agentMessage) $ do
|
||||
processAgentMessage user@User {userId, profile} agentConnId agentMessage = do
|
||||
chatDirection <- withStore $ \st -> getConnectionChatDirection st user agentConnId
|
||||
forM_ (agentMsgConnStatus agentMessage) $ \status ->
|
||||
withStore $ \st -> updateConnectionStatus st (fromConnection chatDirection) status
|
||||
@ -313,11 +407,11 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
|
||||
processDirectMessage agentMessage conn maybeContact
|
||||
ReceivedGroupMessage conn gName m ->
|
||||
processGroupMessage agentMessage conn gName m
|
||||
RcvFileConnection conn ft ->
|
||||
processRcvFileConn agentMessage conn ft
|
||||
SndFileConnection conn ft ->
|
||||
processSndFileConn agentMessage conn ft
|
||||
where
|
||||
sent :: ACommand 'Agent -> Bool
|
||||
sent SENT {} = True
|
||||
sent _ = False
|
||||
|
||||
isMember :: MemberId -> Group -> Bool
|
||||
isMember memId Group {membership, members} =
|
||||
memberId membership == memId || isJust (find ((== memId) . memberId) members)
|
||||
@ -343,12 +437,15 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
|
||||
acceptAgentConnection conn confId $ XInfo profile
|
||||
INFO connInfo ->
|
||||
saveConnInfo conn connInfo
|
||||
MSG meta _ ->
|
||||
withAckMessage agentConnId meta $ pure ()
|
||||
_ -> pure ()
|
||||
Just ct@Contact {localDisplayName = c} -> case agentMsg of
|
||||
MSG meta msgBody -> do
|
||||
MSG meta msgBody -> withAckMessage agentConnId meta $ 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
|
||||
XInfo p -> xInfo ct p
|
||||
XGrpInv gInv -> processGroupInvitation ct gInv
|
||||
XInfoProbe probe -> xInfoProbe ct probe
|
||||
@ -461,7 +558,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
|
||||
when (contactIsReady ct) $ do
|
||||
notifyMemberConnected gName m
|
||||
when (memberCategory m == GCPreMember) $ probeMatchingContacts ct
|
||||
MSG meta msgBody -> do
|
||||
MSG meta msgBody -> withAckMessage agentConnId meta $ do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody
|
||||
case chatMsgEvent of
|
||||
XMsgNew (MsgContent MTText [] body) ->
|
||||
@ -476,6 +573,81 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
|
||||
_ -> messageError $ "unsupported message: " <> T.pack (show chatMsgEvent)
|
||||
_ -> pure ()
|
||||
|
||||
processSndFileConn :: ACommand 'Agent -> Connection -> SndFileTransfer -> m ()
|
||||
processSndFileConn agentMsg conn ft@SndFileTransfer {fileId, fileName, fileStatus} =
|
||||
case agentMsg of
|
||||
REQ confId connInfo -> do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
|
||||
case chatMsgEvent of
|
||||
XFileAcpt name
|
||||
| name == fileName -> do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSAccepted
|
||||
acceptAgentConnection conn confId XOk
|
||||
| otherwise -> messageError "x.file.acpt: fileName is different from expected"
|
||||
_ -> messageError "REQ from file connection must have x.file.acpt"
|
||||
CON -> do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSConnected
|
||||
showSndFileStart fileId
|
||||
sendFileChunk ft
|
||||
SENT msgId -> do
|
||||
withStore $ \st -> updateSndFileChunkSent st ft msgId
|
||||
unless (fileStatus == FSCancelled) $ sendFileChunk ft
|
||||
MERR _ err -> do
|
||||
cancelSndFileTransfer ft
|
||||
case err of
|
||||
SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ showSndFileRcvCancelled fileId
|
||||
_ -> chatError $ CEFileSend fileId err
|
||||
MSG meta _ ->
|
||||
withAckMessage agentConnId meta $ pure ()
|
||||
_ -> pure ()
|
||||
|
||||
processRcvFileConn :: ACommand 'Agent -> Connection -> RcvFileTransfer -> m ()
|
||||
processRcvFileConn agentMsg _conn ft@RcvFileTransfer {fileId, chunkSize} =
|
||||
case agentMsg of
|
||||
CON -> do
|
||||
withStore $ \st -> updateRcvFileStatus st ft FSConnected
|
||||
showRcvFileStart fileId
|
||||
MSG meta@MsgMeta {recipient = (msgId, _), integrity} msgBody -> withAckMessage agentConnId meta $ do
|
||||
parseFileChunk msgBody >>= \case
|
||||
(0, _) -> do
|
||||
cancelRcvFileTransfer ft
|
||||
showRcvFileSndCancelled fileId
|
||||
(chunkNo, chunk) -> do
|
||||
case integrity of
|
||||
MsgOk -> pure ()
|
||||
MsgError MsgDuplicate -> pure () -- TODO remove once agent removes duplicates
|
||||
MsgError e ->
|
||||
badRcvFileChunk ft $ "invalid file chunk number " <> show chunkNo <> ": " <> show e
|
||||
withStore (\st -> createRcvFileChunk st ft chunkNo msgId) >>= \case
|
||||
RcvChunkOk ->
|
||||
if B.length chunk /= fromInteger chunkSize
|
||||
then badRcvFileChunk ft "incorrect chunk size"
|
||||
else appendFileChunk ft chunkNo chunk
|
||||
RcvChunkFinal ->
|
||||
if B.length chunk > fromInteger chunkSize
|
||||
then badRcvFileChunk ft "incorrect chunk size"
|
||||
else do
|
||||
appendFileChunk ft chunkNo chunk
|
||||
withStore $ \st -> updateRcvFileStatus st ft FSComplete
|
||||
showRcvFileComplete fileId
|
||||
closeFileHandle fileId rcvFiles
|
||||
withAgent (`deleteConnection` agentConnId)
|
||||
RcvChunkDuplicate -> pure ()
|
||||
RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
|
||||
_ -> pure ()
|
||||
|
||||
withAckMessage :: ConnId -> MsgMeta -> m () -> m ()
|
||||
withAckMessage cId MsgMeta {recipient = (msgId, _)} action =
|
||||
action `E.finally` withAgent (\a -> ackMessage a cId msgId `catchError` \_ -> pure ())
|
||||
|
||||
badRcvFileChunk :: RcvFileTransfer -> String -> m ()
|
||||
badRcvFileChunk ft@RcvFileTransfer {fileStatus} err =
|
||||
case fileStatus of
|
||||
RFSCancelled _ -> pure ()
|
||||
_ -> do
|
||||
cancelRcvFileTransfer ft
|
||||
chatError $ CEFileRcvChunk err
|
||||
|
||||
notifyMemberConnected :: GroupName -> GroupMember -> m ()
|
||||
notifyMemberConnected gName m@GroupMember {localDisplayName} = do
|
||||
showConnectedToGroupMember gName m
|
||||
@ -496,10 +668,10 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
|
||||
withStore $ \st -> createSentProbeHash st userId probeId c
|
||||
|
||||
messageWarning :: Text -> m ()
|
||||
messageWarning = liftIO . print
|
||||
messageWarning = showMessageError "warning"
|
||||
|
||||
messageError :: Text -> m ()
|
||||
messageError = liftIO . print
|
||||
messageError = showMessageError "error"
|
||||
|
||||
newTextMessage :: ContactName -> MsgMeta -> Maybe MsgContentBody -> m ()
|
||||
newTextMessage c meta = \case
|
||||
@ -519,6 +691,14 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
|
||||
setActive $ ActiveG gName
|
||||
_ -> messageError "x.msg.new: no expected message body"
|
||||
|
||||
processFileInvitation :: Contact -> FileInvitation -> m ()
|
||||
processFileInvitation Contact {contactId, localDisplayName = c} 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
|
||||
setActive $ ActiveC c
|
||||
|
||||
processGroupInvitation :: Contact -> GroupInvitation -> m ()
|
||||
processGroupInvitation ct@Contact {localDisplayName} inv@(GroupInvitation (fromMemId, fromRole) (memId, memRole) _ _) = do
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole localDisplayName)
|
||||
@ -662,7 +842,96 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = unles
|
||||
mapM_ deleteMemberConnection ms
|
||||
showGroupDeleted gName m
|
||||
|
||||
chatError :: ChatMonad m => ChatErrorType -> m ()
|
||||
sendFileChunk :: ChatMonad m => SndFileTransfer -> m ()
|
||||
sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} =
|
||||
unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
|
||||
withStore (`createSndFileChunk` ft) >>= \case
|
||||
Just chunkNo -> sendFileChunkNo ft chunkNo
|
||||
Nothing -> do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSComplete
|
||||
showSndFileComplete fileId
|
||||
closeFileHandle fileId sndFiles
|
||||
withAgent (`deleteConnection` agentConnId)
|
||||
|
||||
sendFileChunkNo :: ChatMonad m => SndFileTransfer -> Integer -> m ()
|
||||
sendFileChunkNo ft@SndFileTransfer {agentConnId} chunkNo = do
|
||||
bytes <- readFileChunk ft chunkNo
|
||||
msgId <- withAgent $ \a -> sendMessage a agentConnId $ serializeFileChunk chunkNo bytes
|
||||
withStore $ \st -> updateSndFileChunkMsg st ft chunkNo msgId
|
||||
|
||||
readFileChunk :: ChatMonad m => SndFileTransfer -> Integer -> m ByteString
|
||||
readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo =
|
||||
read_ `E.catch` (chatError . CEFileRead filePath)
|
||||
where
|
||||
read_ = do
|
||||
h <- getFileHandle fileId filePath sndFiles ReadMode
|
||||
pos <- hTell h
|
||||
let pos' = (chunkNo - 1) * chunkSize
|
||||
when (pos /= pos') $ hSeek h AbsoluteSeek pos'
|
||||
liftIO . B.hGet h $ fromInteger chunkSize
|
||||
|
||||
parseFileChunk :: ChatMonad m => ByteString -> m (Integer, ByteString)
|
||||
parseFileChunk msg =
|
||||
liftEither . first (ChatError . CEFileRcvChunk) $
|
||||
parseAll ((,) <$> A.decimal <* A.space <*> A.takeByteString) msg
|
||||
|
||||
serializeFileChunk :: Integer -> ByteString -> ByteString
|
||||
serializeFileChunk chunkNo bytes = bshow chunkNo <> " " <> bytes
|
||||
|
||||
appendFileChunk :: ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> m ()
|
||||
appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk =
|
||||
case fileStatus of
|
||||
RFSConnected RcvFileInfo {filePath} -> append_ filePath
|
||||
RFSCancelled _ -> pure ()
|
||||
_ -> chatError $ CEFileInternal "receiving file transfer not in progress"
|
||||
where
|
||||
append_ fPath = do
|
||||
h <- getFileHandle fileId fPath rcvFiles AppendMode
|
||||
E.try (liftIO $ B.hPut h chunk >> hFlush h) >>= \case
|
||||
Left e -> chatError $ CEFileWrite fPath e
|
||||
Right () -> withStore $ \st -> updatedRcvFileChunkStored st ft chunkNo
|
||||
|
||||
getFileHandle :: ChatMonad m => Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> m Handle
|
||||
getFileHandle fileId filePath files ioMode = do
|
||||
fs <- asks files
|
||||
h_ <- M.lookup fileId <$> readTVarIO fs
|
||||
maybe (newHandle fs) pure h_
|
||||
where
|
||||
newHandle fs = do
|
||||
-- TODO handle errors
|
||||
h <- liftIO (openFile filePath ioMode)
|
||||
atomically . modifyTVar fs $ M.insert fileId h
|
||||
pure h
|
||||
|
||||
isFileActive :: ChatMonad m => Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> m Bool
|
||||
isFileActive fileId files = do
|
||||
fs <- asks files
|
||||
isJust . M.lookup fileId <$> readTVarIO fs
|
||||
|
||||
cancelRcvFileTransfer :: ChatMonad m => RcvFileTransfer -> m ()
|
||||
cancelRcvFileTransfer ft@RcvFileTransfer {fileId, fileStatus} = do
|
||||
closeFileHandle fileId rcvFiles
|
||||
withStore $ \st -> updateRcvFileStatus st ft FSCancelled
|
||||
case fileStatus of
|
||||
RFSAccepted RcvFileInfo {agentConnId} -> withAgent (`suspendConnection` agentConnId)
|
||||
RFSConnected RcvFileInfo {agentConnId} -> withAgent (`suspendConnection` agentConnId)
|
||||
_ -> pure ()
|
||||
|
||||
cancelSndFileTransfer :: ChatMonad m => SndFileTransfer -> m ()
|
||||
cancelSndFileTransfer ft@SndFileTransfer {agentConnId, fileStatus} =
|
||||
unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ do
|
||||
withStore $ \st -> updateSndFileStatus st ft FSCancelled
|
||||
withAgent $ \a -> do
|
||||
void $ sendMessage a agentConnId "0 "
|
||||
suspendConnection a agentConnId
|
||||
|
||||
closeFileHandle :: ChatMonad m => Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> m ()
|
||||
closeFileHandle fileId files = do
|
||||
fs <- asks files
|
||||
h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
|
||||
mapM_ hClose h_ `E.catch` \(_ :: E.SomeException) -> pure ()
|
||||
|
||||
chatError :: ChatMonad m => ChatErrorType -> m a
|
||||
chatError = throwError . ChatError
|
||||
|
||||
deleteMemberConnection :: ChatMonad m => GroupMember -> m ()
|
||||
@ -790,6 +1059,11 @@ chatCommandP =
|
||||
<|> ("/connect" <|> "/c") $> AddContact
|
||||
<|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName)
|
||||
<|> A.char '@' *> (SendMessage <$> displayName <*> (A.space *> A.takeByteString))
|
||||
<|> ("/file #" <|> "/f #") *> (SendGroupFile <$> displayName <* A.space <*> filePath)
|
||||
<|> ("/file @" <|> "/file " <|> "/f @" <|> "/f ") *> (SendFile <$> displayName <* A.space <*> filePath)
|
||||
<|> ("/file_receive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (A.space *> filePath))
|
||||
<|> ("/file_cancel " <|> "/fc ") *> (CancelFile <$> A.decimal)
|
||||
<|> ("/file_status " <|> "/fs ") *> (FileStatus <$> A.decimal)
|
||||
<|> ("/markdown" <|> "/m") $> MarkdownHelp
|
||||
<|> ("/profile " <|> "/p ") *> (UpdateProfile <$> userProfile)
|
||||
<|> ("/profile" <|> "/p") $> ShowProfile
|
||||
@ -808,6 +1082,7 @@ chatCommandP =
|
||||
fullNameP name = do
|
||||
n <- (A.space *> A.takeByteString) <|> pure ""
|
||||
pure $ if B.null n then name else safeDecodeUtf8 n
|
||||
filePath = T.unpack . safeDecodeUtf8 <$> A.takeByteString
|
||||
memberRole =
|
||||
(" owner" $> GROwner)
|
||||
<|> (" admin" $> GRAdmin)
|
||||
|
@ -11,15 +11,27 @@ import Control.Monad.Except
|
||||
import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Data.Int (Int64)
|
||||
import Data.Map.Strict (Map)
|
||||
import Numeric.Natural
|
||||
import Simplex.Chat.Notification
|
||||
import Simplex.Chat.Store (StoreError)
|
||||
import Simplex.Chat.Terminal
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent (AgentClient)
|
||||
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig)
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore)
|
||||
import System.IO (Handle)
|
||||
import UnliftIO.STM
|
||||
|
||||
data ChatConfig = ChatConfig
|
||||
{ agentConfig :: AgentConfig,
|
||||
dbPoolSize :: Int,
|
||||
tbqSize :: Natural,
|
||||
fileChunkSize :: Integer
|
||||
}
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar User,
|
||||
smpAgent :: AgentClient,
|
||||
@ -29,7 +41,10 @@ data ChatController = ChatController
|
||||
inputQ :: TBQueue InputEvent,
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO (),
|
||||
chatLock :: TMVar ()
|
||||
chatLock :: TMVar (),
|
||||
sndFiles :: TVar (Map Int64 Handle),
|
||||
rcvFiles :: TVar (Map Int64 Handle),
|
||||
config :: ChatConfig
|
||||
}
|
||||
|
||||
data InputEvent = InputCommand String | InputControl Char
|
||||
@ -51,6 +66,14 @@ data ChatErrorType
|
||||
| CEGroupMemberUserRemoved
|
||||
| CEGroupMemberNotFound ContactName
|
||||
| CEGroupInternal String
|
||||
| CEFileNotFound String
|
||||
| CEFileAlreadyReceiving String
|
||||
| CEFileAlreadyExists FilePath
|
||||
| CEFileRead FilePath SomeException
|
||||
| CEFileWrite FilePath SomeException
|
||||
| CEFileSend Int64 AgentErrorType
|
||||
| CEFileRcvChunk String
|
||||
| CEFileInternal String
|
||||
deriving (Show, Exception)
|
||||
|
||||
type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m)
|
||||
|
@ -23,7 +23,10 @@ import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Util (safeDecodeUtf8)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Parsers (parseAll)
|
||||
import Simplex.Messaging.Util (bshow)
|
||||
@ -33,6 +36,8 @@ data ChatDirection (p :: AParty) where
|
||||
SentDirectMessage :: Contact -> ChatDirection 'Client
|
||||
ReceivedGroupMessage :: Connection -> GroupName -> GroupMember -> ChatDirection 'Agent
|
||||
SentGroupMessage :: GroupName -> ChatDirection 'Client
|
||||
SndFileConnection :: Connection -> SndFileTransfer -> ChatDirection 'Agent
|
||||
RcvFileConnection :: Connection -> RcvFileTransfer -> ChatDirection 'Agent
|
||||
|
||||
deriving instance Eq (ChatDirection p)
|
||||
|
||||
@ -42,9 +47,13 @@ fromConnection :: ChatDirection 'Agent -> Connection
|
||||
fromConnection = \case
|
||||
ReceivedDirectMessage conn _ -> conn
|
||||
ReceivedGroupMessage conn _ _ -> conn
|
||||
SndFileConnection conn _ -> conn
|
||||
RcvFileConnection conn _ -> conn
|
||||
|
||||
data ChatMsgEvent
|
||||
= XMsgNew MsgContent
|
||||
| XFile FileInvitation
|
||||
| XFileAcpt String
|
||||
| XInfo Profile
|
||||
| XGrpInv GroupInvitation
|
||||
| XGrpAcpt MemberId
|
||||
@ -100,6 +109,13 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod
|
||||
t <- toMsgType mt
|
||||
files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles
|
||||
chatMsg . XMsgNew $ MsgContent {messageType = t, files, content = body}
|
||||
("x.file", [name, size, qInfo]) -> do
|
||||
let fileName = T.unpack $ safeDecodeUtf8 name
|
||||
fileSize <- parseAll A.decimal size
|
||||
fileQInfo <- parseAll smpQueueInfoP qInfo
|
||||
chatMsg . XFile $ FileInvitation {fileName, fileSize, fileQInfo}
|
||||
("x.file.acpt", [name]) ->
|
||||
chatMsg . XFileAcpt . T.unpack $ safeDecodeUtf8 name
|
||||
("x.info", []) -> do
|
||||
profile <- getJSON body
|
||||
chatMsg $ XInfo profile
|
||||
@ -174,6 +190,10 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} =
|
||||
XMsgNew MsgContent {messageType = t, files, content} ->
|
||||
let rawFiles = map (serializeContentInfo . rawContentInfo) files
|
||||
in rawMsg "x.msg.new" (rawMsgType t : rawFiles) content
|
||||
XFile FileInvitation {fileName, fileSize, fileQInfo} ->
|
||||
rawMsg "x.file" [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeSmpQueueInfo fileQInfo] []
|
||||
XFileAcpt fileName ->
|
||||
rawMsg "x.file.acpt" [encodeUtf8 $ T.pack fileName] []
|
||||
XInfo profile ->
|
||||
rawMsg "x.info" [] [jsonBody profile]
|
||||
XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) qInfo groupProfile) ->
|
||||
|
@ -7,6 +7,7 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
@ -27,6 +28,9 @@ module Simplex.Chat.Store
|
||||
updateUserProfile,
|
||||
updateContactProfile,
|
||||
getUserContacts,
|
||||
getLiveSndFileTransfers,
|
||||
getLiveRcvFileTransfers,
|
||||
getPendingSndChunks,
|
||||
getPendingConnections,
|
||||
getContactConnections,
|
||||
getConnectionChatDirection,
|
||||
@ -58,6 +62,19 @@ module Simplex.Chat.Store
|
||||
matchReceivedProbeHash,
|
||||
matchSentProbe,
|
||||
mergeContactRecords,
|
||||
createSndFileTransfer,
|
||||
updateSndFileStatus,
|
||||
createSndFileChunk,
|
||||
updateSndFileChunkMsg,
|
||||
updateSndFileChunkSent,
|
||||
createRcvFileTransfer,
|
||||
getRcvFileTransfer,
|
||||
acceptRcvFileTransfer,
|
||||
updateRcvFileStatus,
|
||||
createRcvFileChunk,
|
||||
updatedRcvFileChunkStored,
|
||||
getFileTransfer,
|
||||
getFileTransferProgress,
|
||||
)
|
||||
where
|
||||
|
||||
@ -85,11 +102,11 @@ import qualified Database.SQLite.Simple as DB
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (AParty (..), ConnId, SMPQueueInfo)
|
||||
import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, SMPQueueInfo)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction)
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Util (bshow, liftIOEither)
|
||||
import Simplex.Messaging.Util (bshow, liftIOEither, (<$$>))
|
||||
import System.FilePath (takeBaseName, takeExtension)
|
||||
import UnliftIO.STM
|
||||
|
||||
@ -315,7 +332,7 @@ getContact_ db userId localDisplayName = do
|
||||
db
|
||||
[sql|
|
||||
SELECT 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.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
FROM connections c
|
||||
WHERE c.user_id = :user_id AND c.contact_id == :contact_id
|
||||
ORDER BY c.connection_id DESC
|
||||
@ -334,9 +351,58 @@ getContact_ db userId localDisplayName = do
|
||||
getUserContacts :: MonadUnliftIO m => SQLiteStore -> User -> m [Contact]
|
||||
getUserContacts st User {userId} =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
contactNames <- liftIO $ map fromOnly <$> DB.query db "SELECT local_display_name FROM contacts WHERE user_id = ?" (Only userId)
|
||||
contactNames <- map fromOnly <$> DB.query db "SELECT local_display_name FROM contacts WHERE user_id = ?" (Only userId)
|
||||
rights <$> mapM (runExceptT . getContact_ db userId) contactNames
|
||||
|
||||
getLiveSndFileTransfers :: MonadUnliftIO m => SQLiteStore -> User -> m [SndFileTransfer]
|
||||
getLiveSndFileTransfers st User {userId} =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
fileIds :: [Int64] <-
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT DISTINCT f.file_id
|
||||
FROM files f
|
||||
JOIN snd_files s
|
||||
WHERE f.user_id = ? AND s.file_status IN (?, ?, ?)
|
||||
|]
|
||||
(userId, FSNew, FSAccepted, FSConnected)
|
||||
concatMap (filter liveTransfer) . rights <$> mapM (getSndFileTransfers_ db userId) fileIds
|
||||
where
|
||||
liveTransfer :: SndFileTransfer -> Bool
|
||||
liveTransfer SndFileTransfer {fileStatus} = fileStatus `elem` [FSNew, FSAccepted, FSConnected]
|
||||
|
||||
getLiveRcvFileTransfers :: MonadUnliftIO m => SQLiteStore -> User -> m [RcvFileTransfer]
|
||||
getLiveRcvFileTransfers st User {userId} =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
fileIds :: [Int64] <-
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT f.file_id
|
||||
FROM files f
|
||||
JOIN rcv_files r
|
||||
WHERE f.user_id = ? AND r.file_status IN (?, ?)
|
||||
|]
|
||||
(userId, FSAccepted, FSConnected)
|
||||
rights <$> mapM (getRcvFileTransfer_ db userId) fileIds
|
||||
|
||||
getPendingSndChunks :: MonadUnliftIO m => SQLiteStore -> Int64 -> Int64 -> m [Integer]
|
||||
getPendingSndChunks st fileId connId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
map fromOnly
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT chunk_number
|
||||
FROM snd_file_chunks
|
||||
WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id IS NULL
|
||||
ORDER BY chunk_number
|
||||
|]
|
||||
(fileId, connId)
|
||||
|
||||
getPendingConnections :: MonadUnliftIO m => SQLiteStore -> User -> m [Connection]
|
||||
getPendingConnections st User {userId} =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
@ -344,12 +410,12 @@ getPendingConnections st User {userId} =
|
||||
<$> DB.queryNamed
|
||||
db
|
||||
[sql|
|
||||
SELECT 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.created_at
|
||||
FROM connections c
|
||||
WHERE c.user_id = :user_id
|
||||
AND c.conn_type = :conn_type
|
||||
AND c.contact_id IS NULL
|
||||
SELECT connection_id, agent_conn_id, conn_level, via_contact,
|
||||
conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, created_at
|
||||
FROM connections
|
||||
WHERE user_id = :user_id
|
||||
AND conn_type = :conn_type
|
||||
AND contact_id IS NULL
|
||||
|]
|
||||
[":user_id" := userId, ":conn_type" := ConnContact]
|
||||
|
||||
@ -361,7 +427,7 @@ getContactConnections st userId displayName =
|
||||
db
|
||||
[sql|
|
||||
SELECT 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.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
FROM connections c
|
||||
JOIN contacts cs ON c.contact_id == cs.contact_id
|
||||
WHERE c.user_id = :user_id
|
||||
@ -373,22 +439,24 @@ getContactConnections st userId displayName =
|
||||
connections [] = Left $ SEContactNotFound displayName
|
||||
connections rows = Right $ map toConnection rows
|
||||
|
||||
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, UTCTime)
|
||||
type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, UTCTime)
|
||||
|
||||
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Int64, Maybe Int64, Maybe UTCTime)
|
||||
type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime)
|
||||
|
||||
toConnection :: ConnectionRow -> Connection
|
||||
toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, createdAt) =
|
||||
toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, createdAt) =
|
||||
let entityId = entityId_ connType
|
||||
in Connection {connId, agentConnId, connLevel, viaContact, connStatus, connType, entityId, createdAt}
|
||||
where
|
||||
entityId_ :: ConnType -> Maybe Int64
|
||||
entityId_ ConnContact = contactId
|
||||
entityId_ ConnMember = groupMemberId
|
||||
entityId_ ConnRcvFile = rcvFileId
|
||||
entityId_ ConnSndFile = sndFileId
|
||||
|
||||
toMaybeConnection :: MaybeConnectionRow -> Maybe Connection
|
||||
toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Just connStatus, Just connType, contactId, groupMemberId, Just createdAt) =
|
||||
Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, createdAt)
|
||||
toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Just connStatus, Just connType, contactId, groupMemberId, sndFileId, rcvFileId, Just createdAt) =
|
||||
Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, createdAt)
|
||||
toMaybeConnection _ = Nothing
|
||||
|
||||
getMatchingContacts :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [Contact]
|
||||
@ -515,15 +583,17 @@ getConnectionChatDirection :: StoreMonad m => SQLiteStore -> User -> ConnId -> m
|
||||
getConnectionChatDirection st User {userId, userContactId} agentConnId =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
c@Connection {connType, entityId} <- getConnection_ db
|
||||
case connType of
|
||||
ConnMember ->
|
||||
case entityId of
|
||||
Nothing -> throwError $ SEInternal "group member without connection"
|
||||
Just groupMemberId -> uncurry (ReceivedGroupMessage c) <$> getGroupAndMember_ db groupMemberId c
|
||||
ConnContact ->
|
||||
ReceivedDirectMessage c <$> case entityId of
|
||||
Nothing -> pure Nothing
|
||||
Just contactId -> Just <$> getContactRec_ db contactId c
|
||||
case entityId of
|
||||
Nothing ->
|
||||
if connType == ConnContact
|
||||
then pure $ ReceivedDirectMessage c Nothing
|
||||
else throwError $ SEInternal $ "connection " <> bshow connType <> " without entity"
|
||||
Just entId ->
|
||||
case connType of
|
||||
ConnMember -> uncurry (ReceivedGroupMessage c) <$> getGroupAndMember_ db entId c
|
||||
ConnContact -> ReceivedDirectMessage c . Just <$> getContactRec_ db entId c
|
||||
ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ db entId c
|
||||
ConnRcvFile -> RcvFileConnection c <$> ExceptT (getRcvFileTransfer_ db userId entId)
|
||||
where
|
||||
getConnection_ :: DB.Connection -> ExceptT StoreError IO Connection
|
||||
getConnection_ db = ExceptT $ do
|
||||
@ -532,7 +602,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
|
||||
db
|
||||
[sql|
|
||||
SELECT connection_id, agent_conn_id, conn_level, via_contact,
|
||||
conn_status, conn_type, contact_id, group_member_id, created_at
|
||||
conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, created_at
|
||||
FROM connections
|
||||
WHERE user_id = ? AND agent_conn_id = ?
|
||||
|]
|
||||
@ -578,6 +648,22 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId =
|
||||
let member = toGroupMember userContactId memberRow
|
||||
in Right (groupName, (member :: GroupMember) {activeConn = Just c})
|
||||
toGroupAndMember _ _ = Left $ SEInternal "referenced group member not found"
|
||||
getConnSndFileTransfer_ :: DB.Connection -> Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer
|
||||
getConnSndFileTransfer_ db fileId Connection {connId} =
|
||||
ExceptT $
|
||||
sndFileTransfer_ fileId connId
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT s.file_status, f.file_name, f.file_size, f.chunk_size, f.file_path
|
||||
FROM snd_files s
|
||||
JOIN files f USING (file_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_ fileId _ _ = Left $ SESndFileNotFound fileId
|
||||
|
||||
updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m ()
|
||||
updateConnectionStatus st Connection {connId} connStatus =
|
||||
@ -655,7 +741,7 @@ getGroup_ db User {userId, userContactId} localDisplayName = do
|
||||
m.group_member_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.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
FROM group_members m
|
||||
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
||||
LEFT JOIN connections c ON c.connection_id = (
|
||||
@ -1011,7 +1097,7 @@ getViaGroupMember st User {userId, userContactId} Contact {contactId} =
|
||||
m.group_member_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.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
FROM group_members m
|
||||
JOIN contacts ct ON ct.contact_id = m.contact_id
|
||||
JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id
|
||||
@ -1041,7 +1127,7 @@ getViaGroupContact st User {userId} GroupMember {groupMemberId} =
|
||||
SELECT
|
||||
ct.contact_id, ct.local_display_name, p.display_name, p.full_name, ct.via_group,
|
||||
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.created_at
|
||||
c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at
|
||||
FROM contacts ct
|
||||
JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id
|
||||
JOIN connections c ON c.connection_id = (
|
||||
@ -1062,6 +1148,225 @@ 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 =
|
||||
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
|
||||
Connection {connId} <- createSndFileConnection_ db userId fileId agentConnId
|
||||
let fileStatus = FSNew
|
||||
DB.execute db "INSERT INTO snd_files (file_id, file_status, connection_id) VALUES (?, ?, ?)" (fileId, fileStatus, connId)
|
||||
pure SndFileTransfer {..}
|
||||
|
||||
createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection
|
||||
createSndFileConnection_ db userId fileId agentConnId = do
|
||||
createdAt <- getCurrentTime
|
||||
let connType = ConnSndFile
|
||||
connStatus = ConnNew
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO connections
|
||||
(user_id, snd_file_id, agent_conn_id, conn_status, conn_type, created_at) VALUES (?,?,?,?,?,?)
|
||||
|]
|
||||
(userId, fileId, agentConnId, connStatus, connType, createdAt)
|
||||
connId <- insertedRowId db
|
||||
pure Connection {connId, agentConnId, connType, entityId = Just fileId, viaContact = Nothing, connLevel = 0, connStatus, createdAt}
|
||||
|
||||
updateSndFileStatus :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> FileStatus -> m ()
|
||||
updateSndFileStatus st SndFileTransfer {fileId, connId} status =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute db "UPDATE snd_files SET file_status = ? WHERE file_id = ? AND connection_id = ?" (status, fileId, connId)
|
||||
|
||||
createSndFileChunk :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> m (Maybe Integer)
|
||||
createSndFileChunk st SndFileTransfer {fileId, connId, fileSize, chunkSize} =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
chunkNo <- getLastChunkNo db
|
||||
insertChunk db chunkNo
|
||||
pure chunkNo
|
||||
where
|
||||
getLastChunkNo db = do
|
||||
ns <- DB.query db "SELECT chunk_number FROM snd_file_chunks WHERE file_id = ? AND connection_id = ? AND chunk_sent = 1 ORDER BY chunk_number DESC LIMIT 1" (fileId, connId)
|
||||
pure $ case map fromOnly ns of
|
||||
[] -> Just 1
|
||||
n : _ -> if n * chunkSize >= fileSize then Nothing else Just (n + 1)
|
||||
insertChunk db = \case
|
||||
Just chunkNo -> DB.execute db "INSERT OR REPLACE INTO snd_file_chunks (file_id, connection_id, chunk_number) VALUES (?, ?, ?)" (fileId, connId, chunkNo)
|
||||
Nothing -> pure ()
|
||||
|
||||
updateSndFileChunkMsg :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> Integer -> AgentMsgId -> m ()
|
||||
updateSndFileChunkMsg st SndFileTransfer {fileId, connId} chunkNo msgId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE snd_file_chunks
|
||||
SET chunk_agent_msg_id = ?
|
||||
WHERE file_id = ? AND connection_id = ? AND chunk_number = ?
|
||||
|]
|
||||
(msgId, fileId, connId, chunkNo)
|
||||
|
||||
updateSndFileChunkSent :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> AgentMsgId -> m ()
|
||||
updateSndFileChunkSent st SndFileTransfer {fileId, connId} msgId =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE snd_file_chunks
|
||||
SET chunk_sent = 1
|
||||
WHERE file_id = ? AND connection_id = ? AND chunk_agent_msg_id = ?
|
||||
|]
|
||||
(fileId, connId, msgId)
|
||||
|
||||
createRcvFileTransfer :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> FileInvitation -> Integer -> m RcvFileTransfer
|
||||
createRcvFileTransfer st userId contactId 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}
|
||||
|
||||
getRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m RcvFileTransfer
|
||||
getRcvFileTransfer st userId fileId =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
getRcvFileTransfer_ db userId fileId
|
||||
|
||||
getRcvFileTransfer_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError RcvFileTransfer)
|
||||
getRcvFileTransfer_ db userId fileId =
|
||||
rcvFileTransfer
|
||||
<$> DB.query
|
||||
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
|
||||
FROM rcv_files r
|
||||
JOIN files f USING (file_id)
|
||||
LEFT JOIN connections c ON r.file_id = c.rcv_file_id
|
||||
WHERE f.user_id = ? AND f.file_id = ?
|
||||
|]
|
||||
(userId, fileId)
|
||||
where
|
||||
rcvFileTransfer ::
|
||||
[(FileStatus, SMPQueueInfo, String, Integer, Integer, Maybe FilePath, Maybe Int64, Maybe ConnId)] ->
|
||||
Either StoreError RcvFileTransfer
|
||||
rcvFileTransfer [(fileStatus', fileQInfo, fileName, fileSize, chunkSize, 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
|
||||
where
|
||||
ft fileInvitation rfs = \case
|
||||
(Just filePath, Just connId, Just agentConnId) ->
|
||||
let fileStatus = rfs RcvFileInfo {filePath, connId, agentConnId}
|
||||
in Right RcvFileTransfer {..}
|
||||
_ -> Left $ SERcvFileInvalid fileId
|
||||
rcvFileTransfer _ = Left $ SERcvFileNotFound fileId
|
||||
|
||||
acceptRcvFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ConnId -> FilePath -> m ()
|
||||
acceptRcvFileTransfer st userId fileId agentConnId filePath =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
DB.execute db "UPDATE files SET file_path = ? WHERE user_id = ? AND file_id = ?" (filePath, userId, fileId)
|
||||
DB.execute db "UPDATE rcv_files SET file_status = ? WHERE file_id = ?" (FSAccepted, fileId)
|
||||
|
||||
DB.execute db "INSERT INTO connections (agent_conn_id, conn_status, conn_type, rcv_file_id, user_id) VALUES (?, ?, ?, ?, ?)" (agentConnId, ConnJoined, ConnRcvFile, fileId, userId)
|
||||
|
||||
updateRcvFileStatus :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> FileStatus -> m ()
|
||||
updateRcvFileStatus st RcvFileTransfer {fileId} status =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute db "UPDATE rcv_files SET file_status = ? WHERE file_id = ?" (status, fileId)
|
||||
|
||||
createRcvFileChunk :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> Integer -> AgentMsgId -> m RcvChunkStatus
|
||||
createRcvFileChunk st RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileSize}, chunkSize} chunkNo msgId =
|
||||
liftIO . withTransaction st $ \db -> do
|
||||
status <- getLastChunkNo db
|
||||
unless (status == RcvChunkError) $
|
||||
DB.execute db "INSERT OR REPLACE INTO rcv_file_chunks (file_id, chunk_number, chunk_agent_msg_id) VALUES (?, ?, ?)" (fileId, chunkNo, msgId)
|
||||
pure status
|
||||
where
|
||||
getLastChunkNo db = do
|
||||
ns <- DB.query db "SELECT chunk_number FROM rcv_file_chunks WHERE file_id = ? ORDER BY chunk_number DESC LIMIT 1" (Only fileId)
|
||||
pure $ case map fromOnly ns of
|
||||
[] -> if chunkNo == 1 then RcvChunkOk else RcvChunkError
|
||||
n : _
|
||||
| chunkNo == n -> RcvChunkDuplicate
|
||||
| chunkNo == n + 1 ->
|
||||
let prevSize = n * chunkSize
|
||||
in if prevSize >= fileSize
|
||||
then RcvChunkError
|
||||
else
|
||||
if prevSize + chunkSize >= fileSize
|
||||
then RcvChunkFinal
|
||||
else RcvChunkOk
|
||||
| otherwise -> RcvChunkError
|
||||
|
||||
updatedRcvFileChunkStored :: MonadUnliftIO m => SQLiteStore -> RcvFileTransfer -> Integer -> m ()
|
||||
updatedRcvFileChunkStored st RcvFileTransfer {fileId} chunkNo =
|
||||
liftIO . withTransaction st $ \db ->
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE rcv_file_chunks
|
||||
SET chunk_stored = 1
|
||||
WHERE file_id = ? AND chunk_number = ?
|
||||
|]
|
||||
(fileId, chunkNo)
|
||||
|
||||
getFileTransfer :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m FileTransfer
|
||||
getFileTransfer st userId fileId =
|
||||
liftIOEither . withTransaction st $ \db ->
|
||||
getFileTransfer_ db userId fileId
|
||||
|
||||
getFileTransferProgress :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m (FileTransfer, [Integer])
|
||||
getFileTransferProgress st userId fileId =
|
||||
liftIOEither . withTransaction st $ \db -> runExceptT $ do
|
||||
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)
|
||||
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)
|
||||
getFileTransfer_ db userId fileId =
|
||||
fileTransfer
|
||||
=<< DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT s.file_id, r.file_id
|
||||
FROM files f
|
||||
LEFT JOIN snd_files s ON s.file_id = f.file_id
|
||||
LEFT JOIN rcv_files r ON r.file_id = f.file_id
|
||||
WHERE user_id = ? AND f.file_id = ?
|
||||
|]
|
||||
(userId, fileId)
|
||||
where
|
||||
fileTransfer :: [(Maybe Int64, Maybe Int64)] -> IO (Either StoreError FileTransfer)
|
||||
fileTransfer ((Just _, Nothing) : _) = FTSnd <$$> getSndFileTransfers_ db userId fileId
|
||||
fileTransfer [(Nothing, Just _)] = FTRcv <$$> getRcvFileTransfer_ db userId fileId
|
||||
fileTransfer _ = pure . Left $ SEFileNotFound fileId
|
||||
|
||||
getSndFileTransfers_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError [SndFileTransfer])
|
||||
getSndFileTransfers_ db userId fileId =
|
||||
sndFileTransfers
|
||||
<$> 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
|
||||
FROM snd_files s
|
||||
JOIN files f USING (file_id)
|
||||
JOIN connections c USING (connection_id)
|
||||
WHERE f.user_id = ? AND f.file_id = ?
|
||||
|]
|
||||
(userId, fileId)
|
||||
where
|
||||
sndFileTransfers :: [(FileStatus, String, Integer, Integer, FilePath, Int64, ConnId)] -> Either StoreError [SndFileTransfer]
|
||||
sndFileTransfers [] = Left $ SESndFileNotFound fileId
|
||||
sndFileTransfers fts = Right $ map sndFileTransfer fts
|
||||
sndFileTransfer (fileStatus, fileName, fileSize, chunkSize, filePath, connId, agentConnId) = SndFileTransfer {..}
|
||||
|
||||
-- | Saves unique local display name based on passed displayName, suffixed with _N if required.
|
||||
-- This function should be called inside transaction.
|
||||
withLocalDisplayName :: forall a. DB.Connection -> UserId -> Text -> (Text -> IO a) -> IO (Either StoreError a)
|
||||
@ -1126,6 +1431,10 @@ data StoreError
|
||||
| SEDuplicateGroupMember
|
||||
| SEGroupAlreadyJoined
|
||||
| SEGroupInvitationNotFound
|
||||
| SESndFileNotFound Int64
|
||||
| SERcvFileNotFound Int64
|
||||
| SEFileNotFound Int64
|
||||
| SERcvFileInvalid Int64
|
||||
| SEConnectionNotFound ConnId
|
||||
| SEIntroNotFound
|
||||
| SEUniqueID
|
||||
|
@ -7,6 +7,7 @@ module Simplex.Chat.Styled
|
||||
styleMarkdown,
|
||||
styleMarkdownText,
|
||||
sLength,
|
||||
sShow,
|
||||
)
|
||||
where
|
||||
|
||||
@ -54,6 +55,9 @@ instance StyledFormat Text where
|
||||
styled f = styled f . T.unpack
|
||||
plain = Styled [] . T.unpack
|
||||
|
||||
sShow :: Show a => a -> StyledString
|
||||
sShow = plain . show
|
||||
|
||||
sgr :: Format -> [SGR]
|
||||
sgr = \case
|
||||
Bold -> [SetConsoleIntensity BoldIntensity]
|
||||
|
@ -299,6 +299,76 @@ serializeMemberStatus = \case
|
||||
GSMemComplete -> "complete"
|
||||
GSMemCreator -> "creator"
|
||||
|
||||
data SndFileTransfer = SndFileTransfer
|
||||
{ fileId :: Int64,
|
||||
fileName :: String,
|
||||
filePath :: String,
|
||||
fileSize :: Integer,
|
||||
chunkSize :: Integer,
|
||||
connId :: Int64,
|
||||
agentConnId :: ConnId,
|
||||
fileStatus :: FileStatus
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FileInvitation = FileInvitation
|
||||
{ fileName :: String,
|
||||
fileSize :: Integer,
|
||||
fileQInfo :: SMPQueueInfo
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RcvFileTransfer = RcvFileTransfer
|
||||
{ fileId :: Int64,
|
||||
fileInvitation :: FileInvitation,
|
||||
fileStatus :: RcvFileStatus,
|
||||
chunkSize :: Integer
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RcvFileStatus
|
||||
= RFSNew
|
||||
| RFSAccepted RcvFileInfo
|
||||
| RFSConnected RcvFileInfo
|
||||
| RFSComplete RcvFileInfo
|
||||
| RFSCancelled RcvFileInfo
|
||||
deriving (Eq, Show)
|
||||
|
||||
data RcvFileInfo = RcvFileInfo
|
||||
{ filePath :: FilePath,
|
||||
connId :: Int64,
|
||||
agentConnId :: ConnId
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data FileTransfer = FTSnd [SndFileTransfer] | FTRcv RcvFileTransfer
|
||||
|
||||
data FileStatus = FSNew | FSAccepted | FSConnected | FSComplete | FSCancelled deriving (Eq, Show)
|
||||
|
||||
instance FromField FileStatus where fromField = fromTextField_ fileStatusT
|
||||
|
||||
instance ToField FileStatus where toField = toField . serializeFileStatus
|
||||
|
||||
fileStatusT :: Text -> Maybe FileStatus
|
||||
fileStatusT = \case
|
||||
"new" -> Just FSNew
|
||||
"accepted" -> Just FSAccepted
|
||||
"connected" -> Just FSConnected
|
||||
"complete" -> Just FSComplete
|
||||
"cancelled" -> Just FSCancelled
|
||||
_ -> Nothing
|
||||
|
||||
serializeFileStatus :: FileStatus -> Text
|
||||
serializeFileStatus = \case
|
||||
FSNew -> "new"
|
||||
FSAccepted -> "accepted"
|
||||
FSConnected -> "connected"
|
||||
FSComplete -> "complete"
|
||||
FSCancelled -> "cancelled"
|
||||
|
||||
data RcvChunkStatus = RcvChunkOk | RcvChunkFinal | RcvChunkDuplicate | RcvChunkError
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Connection = Connection
|
||||
{ connId :: Int64,
|
||||
agentConnId :: ConnId,
|
||||
@ -306,7 +376,7 @@ data Connection = Connection
|
||||
viaContact :: Maybe Int64,
|
||||
connType :: ConnType,
|
||||
connStatus :: ConnStatus,
|
||||
entityId :: Maybe Int64, -- contact or group member ID
|
||||
entityId :: Maybe Int64, -- contact, group member or file ID
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
@ -353,7 +423,7 @@ serializeConnStatus = \case
|
||||
ConnReady -> "ready"
|
||||
ConnDeleted -> "deleted"
|
||||
|
||||
data ConnType = ConnContact | ConnMember
|
||||
data ConnType = ConnContact | ConnMember | ConnSndFile | ConnRcvFile
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance FromField ConnType where fromField = fromTextField_ connTypeT
|
||||
@ -364,12 +434,16 @@ connTypeT :: Text -> Maybe ConnType
|
||||
connTypeT = \case
|
||||
"contact" -> Just ConnContact
|
||||
"member" -> Just ConnMember
|
||||
"snd_file" -> Just ConnSndFile
|
||||
"rcv_file" -> Just ConnRcvFile
|
||||
_ -> Nothing
|
||||
|
||||
serializeConnType :: ConnType -> Text
|
||||
serializeConnType = \case
|
||||
ConnContact -> "contact"
|
||||
ConnMember -> "member"
|
||||
ConnSndFile -> "snd_file"
|
||||
ConnRcvFile -> "rcv_file"
|
||||
|
||||
data NewConnection = NewConnection
|
||||
{ agentConnId :: ByteString,
|
||||
|
@ -8,3 +8,9 @@ safeDecodeUtf8 :: ByteString -> Text
|
||||
safeDecodeUtf8 = decodeUtf8With onError
|
||||
where
|
||||
onError _ _ = Just '?'
|
||||
|
||||
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||
ifM ba t f = ba >>= \b -> if b then t else f
|
||||
|
||||
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||
unlessM b = ifM b $ pure ()
|
||||
|
@ -24,6 +24,20 @@ module Simplex.Chat.View
|
||||
showReceivedGroupMessage,
|
||||
showSentMessage,
|
||||
showSentGroupMessage,
|
||||
showSentFileInvitation,
|
||||
showSndFileStart,
|
||||
showSndFileComplete,
|
||||
showSndFileCancelled,
|
||||
showSndFileRcvCancelled,
|
||||
showReceivedFileInvitation,
|
||||
showRcvFileAccepted,
|
||||
showRcvFileStart,
|
||||
showRcvFileComplete,
|
||||
showRcvFileCancelled,
|
||||
showRcvFileSndCancelled,
|
||||
showFileTransferStatus,
|
||||
showSndFileSubError,
|
||||
showRcvFileSubError,
|
||||
showGroupCreated,
|
||||
showGroupDeletedUser,
|
||||
showGroupDeleted,
|
||||
@ -42,6 +56,7 @@ module Simplex.Chat.View
|
||||
showUserProfile,
|
||||
showUserProfileUpdated,
|
||||
showContactUpdated,
|
||||
showMessageError,
|
||||
safeDecodeUtf8,
|
||||
)
|
||||
where
|
||||
@ -50,11 +65,13 @@ import Control.Monad.IO.Unlift
|
||||
import Control.Monad.Reader
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Composition ((.:), (.:.))
|
||||
import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (DiffTime, UTCTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
import Data.Time.LocalTime (TimeZone, ZonedTime, getCurrentTimeZone, getZonedTime, localDay, localTimeOfDay, timeOfDayToTime, utcToLocalTime, zonedTimeToLocalTime)
|
||||
import Numeric (showFFloat)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Store (StoreError (..))
|
||||
@ -124,6 +141,48 @@ 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
|
||||
|
||||
showSndFileStart :: ChatReader m => Int64 -> m ()
|
||||
showSndFileStart = printToView . sndFileStart
|
||||
|
||||
showSndFileComplete :: ChatReader m => Int64 -> m ()
|
||||
showSndFileComplete = printToView . sndFileComplete
|
||||
|
||||
showSndFileCancelled :: ChatReader m => Int64 -> m ()
|
||||
showSndFileCancelled = printToView . sndFileCancelled
|
||||
|
||||
showSndFileRcvCancelled :: ChatReader m => Int64 -> m ()
|
||||
showSndFileRcvCancelled = printToView . sndFileRcvCancelled
|
||||
|
||||
showReceivedFileInvitation :: ChatReader m => ContactName -> RcvFileTransfer -> m ()
|
||||
showReceivedFileInvitation = printToView .: receivedFileInvitation
|
||||
|
||||
showRcvFileAccepted :: ChatReader m => Int64 -> FilePath -> m ()
|
||||
showRcvFileAccepted = printToView .: rcvFileAccepted
|
||||
|
||||
showRcvFileStart :: ChatReader m => Int64 -> m ()
|
||||
showRcvFileStart = printToView . rcvFileStart
|
||||
|
||||
showRcvFileComplete :: ChatReader m => Int64 -> m ()
|
||||
showRcvFileComplete = printToView . rcvFileComplete
|
||||
|
||||
showRcvFileCancelled :: ChatReader m => Int64 -> m ()
|
||||
showRcvFileCancelled = printToView . rcvFileCancelled
|
||||
|
||||
showRcvFileSndCancelled :: ChatReader m => Int64 -> m ()
|
||||
showRcvFileSndCancelled = printToView . rcvFileSndCancelled
|
||||
|
||||
showFileTransferStatus :: ChatReader m => (FileTransfer, [Integer]) -> m ()
|
||||
showFileTransferStatus = printToView . fileTransferStatus
|
||||
|
||||
showSndFileSubError :: ChatReader m => SndFileTransfer -> ChatError -> m ()
|
||||
showSndFileSubError = printToView .: sndFileSubError
|
||||
|
||||
showRcvFileSubError :: ChatReader m => RcvFileTransfer -> ChatError -> m ()
|
||||
showRcvFileSubError = printToView .: rcvFileSubError
|
||||
|
||||
showGroupCreated :: ChatReader m => Group -> m ()
|
||||
showGroupCreated = printToView . groupCreated
|
||||
|
||||
@ -178,6 +237,9 @@ showUserProfileUpdated = printToView .: userProfileUpdated
|
||||
showContactUpdated :: ChatReader m => Contact -> Contact -> m ()
|
||||
showContactUpdated = printToView .: contactUpdated
|
||||
|
||||
showMessageError :: ChatReader m => Text -> Text -> m ()
|
||||
showMessageError = printToView .: messageError
|
||||
|
||||
invitation :: SMPQueueInfo -> [StyledString]
|
||||
invitation qInfo =
|
||||
[ "pass this invitation to your contact (via another channel): ",
|
||||
@ -202,19 +264,19 @@ contactConnected :: Contact -> [StyledString]
|
||||
contactConnected ct = [ttyFullContact ct <> ": contact is connected"]
|
||||
|
||||
contactDisconnected :: ContactName -> [StyledString]
|
||||
contactDisconnected c = [ttyContact c <> ": contact is disconnected (messages will be queued)"]
|
||||
contactDisconnected c = [ttyContact c <> ": disconnected from server (messages will be queued)"]
|
||||
|
||||
contactAnotherClient :: ContactName -> [StyledString]
|
||||
contactAnotherClient c = [ttyContact c <> ": contact is connected to another client"]
|
||||
|
||||
contactSubscribed :: ContactName -> [StyledString]
|
||||
contactSubscribed c = [ttyContact c <> ": contact is active"]
|
||||
contactSubscribed c = [ttyContact c <> ": connected to server"]
|
||||
|
||||
contactSubError :: ContactName -> ChatError -> [StyledString]
|
||||
contactSubError c e = [ttyContact c <> ": contact error " <> plain (show e)]
|
||||
contactSubError c e = [ttyContact c <> ": contact error " <> sShow e]
|
||||
|
||||
groupSubscribed :: GroupName -> [StyledString]
|
||||
groupSubscribed g = [ttyGroup g <> ": group is active"]
|
||||
groupSubscribed g = [ttyGroup g <> ": connected to server(s)"]
|
||||
|
||||
groupEmpty :: GroupName -> [StyledString]
|
||||
groupEmpty g = [ttyGroup g <> ": group is empty"]
|
||||
@ -223,7 +285,7 @@ groupRemoved :: GroupName -> [StyledString]
|
||||
groupRemoved g = [ttyGroup g <> ": you are no longer a member or group deleted"]
|
||||
|
||||
memberSubError :: GroupName -> ContactName -> ChatError -> [StyledString]
|
||||
memberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> plain (show e)]
|
||||
memberSubError g c e = [ttyGroup g <> " member " <> ttyContact c <> " error: " <> sShow e]
|
||||
|
||||
groupCreated :: Group -> [StyledString]
|
||||
groupCreated g@Group {localDisplayName} =
|
||||
@ -317,7 +379,7 @@ contactsMerged _to@Contact {localDisplayName = c1} _from@Contact {localDisplayNa
|
||||
userProfile :: Profile -> [StyledString]
|
||||
userProfile Profile {displayName, fullName} =
|
||||
[ "user profile: " <> ttyFullName displayName fullName,
|
||||
"use " <> highlight' "/p <display name>[ <full name>]" <> " to change it",
|
||||
"use " <> highlight' "/p <display name> [<full name>]" <> " to change it",
|
||||
"(the updated profile will be sent to all your contacts)"
|
||||
]
|
||||
|
||||
@ -344,6 +406,9 @@ contactUpdated
|
||||
where
|
||||
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName'
|
||||
|
||||
messageError :: Text -> Text -> [StyledString]
|
||||
messageError prefix err = [plain prefix <> ": " <> plain err]
|
||||
|
||||
receivedMessage :: StyledString -> UTCTime -> Text -> MsgIntegrity -> IO [StyledString]
|
||||
receivedMessage from utcTime msg mOk = do
|
||||
t <- formatUTCTime <$> getCurrentTimeZone <*> getZonedTime
|
||||
@ -382,6 +447,90 @@ 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"
|
||||
]
|
||||
|
||||
sndFileStart :: Int64 -> [StyledString]
|
||||
sndFileStart fileId = ["started sending the file " <> sShow fileId]
|
||||
|
||||
sndFileComplete :: Int64 -> [StyledString]
|
||||
sndFileComplete fileId = ["completed sending the file " <> sShow fileId]
|
||||
|
||||
sndFileCancelled :: Int64 -> [StyledString]
|
||||
sndFileCancelled fileId = ["cancelled sending the file " <> sShow fileId]
|
||||
|
||||
sndFileRcvCancelled :: Int64 -> [StyledString]
|
||||
sndFileRcvCancelled fileId = ["recipient cancelled receiving the file " <> sShow fileId]
|
||||
|
||||
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)",
|
||||
"use " <> highlight ("/fr " <> show fileId <> " [<dir>/ | <path>]") <> " to receive it"
|
||||
]
|
||||
|
||||
humanReadableSize :: Integer -> StyledString
|
||||
humanReadableSize size
|
||||
| size < kB = sShow size <> " bytes"
|
||||
| size < mB = hrSize kB "KiB"
|
||||
| size < gB = hrSize mB "MiB"
|
||||
| otherwise = hrSize gB "GiB"
|
||||
where
|
||||
hrSize sB name = plain $ unwords [showFFloat (Just 1) (fromIntegral size / (fromIntegral sB :: Double)) "", name]
|
||||
kB = 1024
|
||||
mB = kB * 1024
|
||||
gB = mB * 1024
|
||||
|
||||
rcvFileAccepted :: Int64 -> FilePath -> [StyledString]
|
||||
rcvFileAccepted fileId filePath = ["saving file " <> sShow fileId <> " to " <> plain filePath]
|
||||
|
||||
rcvFileStart :: Int64 -> [StyledString]
|
||||
rcvFileStart fileId = ["started receiving the file " <> sShow fileId]
|
||||
|
||||
rcvFileComplete :: Int64 -> [StyledString]
|
||||
rcvFileComplete fileId = ["completed receiving the file " <> sShow fileId]
|
||||
|
||||
rcvFileCancelled :: Int64 -> [StyledString]
|
||||
rcvFileCancelled fileId = ["cancelled receiving the file " <> sShow fileId]
|
||||
|
||||
rcvFileSndCancelled :: Int64 -> [StyledString]
|
||||
rcvFileSndCancelled fileId = ["sender cancelled sending the file " <> sShow fileId]
|
||||
|
||||
fileTransferStatus :: (FileTransfer, [Integer]) -> [StyledString]
|
||||
fileTransferStatus (FTSnd [SndFileTransfer {fileStatus, fileSize, chunkSize}], chunksNum) =
|
||||
["sent file transfer " <> sndStatus]
|
||||
where
|
||||
sndStatus = case fileStatus of
|
||||
FSNew -> "is 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]
|
||||
where
|
||||
rcvStatus = case fileStatus of
|
||||
RFSNew -> "is 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
|
||||
|
||||
fileProgress :: [Integer] -> Integer -> Integer -> StyledString
|
||||
fileProgress chunksNum chunkSize fileSize =
|
||||
sShow (sum chunksNum * chunkSize * 100 `div` fileSize) <> "% of " <> humanReadableSize fileSize
|
||||
|
||||
sndFileSubError :: SndFileTransfer -> ChatError -> [StyledString]
|
||||
sndFileSubError SndFileTransfer {fileId, fileName} e =
|
||||
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
|
||||
rcvFileSubError :: RcvFileTransfer -> ChatError -> [StyledString]
|
||||
rcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e =
|
||||
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
|
||||
|
||||
chatError :: ChatError -> [StyledString]
|
||||
chatError = \case
|
||||
ChatError err -> case err of
|
||||
@ -394,16 +543,29 @@ chatError = \case
|
||||
CEGroupMemberUserRemoved -> ["you are no longer the member of the group"]
|
||||
CEGroupMemberNotFound c -> ["contact " <> ttyContact c <> " is not a group member"]
|
||||
CEGroupInternal s -> ["chat group bug: " <> plain s]
|
||||
-- e -> ["chat error: " <> plain (show e)]
|
||||
CEFileNotFound f -> ["file not found: " <> plain f]
|
||||
CEFileAlreadyReceiving f -> ["file is already accepted: " <> plain f]
|
||||
CEFileAlreadyExists f -> ["file already exists: " <> plain f]
|
||||
CEFileRead f e -> ["cannot read file " <> plain f, sShow e]
|
||||
CEFileWrite f e -> ["cannot write file " <> plain f, sShow e]
|
||||
CEFileSend fileId e -> ["error sending file " <> sShow fileId <> ": " <> sShow e]
|
||||
CEFileRcvChunk e -> ["error receiving file: " <> plain e]
|
||||
CEFileInternal e -> ["file error: " <> plain e]
|
||||
-- e -> ["chat error: " <> sShow e]
|
||||
ChatErrorStore err -> case err of
|
||||
SEDuplicateName -> ["this display name is already used by user, contact or group"]
|
||||
SEContactNotFound c -> ["no contact " <> ttyContact c]
|
||||
SEContactNotReady c -> ["contact " <> ttyContact c <> " is not active yet"]
|
||||
SEGroupNotFound g -> ["no group " <> ttyGroup g]
|
||||
SEGroupAlreadyJoined -> ["you already joined this group"]
|
||||
e -> ["chat db error: " <> plain (show e)]
|
||||
ChatErrorAgent e -> ["smp agent error: " <> plain (show e)]
|
||||
ChatErrorMessage e -> ["chat message error: " <> plain (show e)]
|
||||
SEFileNotFound fileId -> fileNotFound fileId
|
||||
SESndFileNotFound fileId -> fileNotFound fileId
|
||||
SERcvFileNotFound fileId -> fileNotFound fileId
|
||||
e -> ["chat db error: " <> sShow e]
|
||||
ChatErrorAgent e -> ["smp agent error: " <> sShow e]
|
||||
ChatErrorMessage e -> ["chat message error: " <> sShow e]
|
||||
where
|
||||
fileNotFound fileId = ["file " <> sShow fileId <> " not found"]
|
||||
|
||||
printToView :: (MonadUnliftIO m, MonadReader ChatController m) => [StyledString] -> m ()
|
||||
printToView s = asks chatTerminal >>= liftIO . (`printToTerminal` s)
|
||||
|
@ -65,6 +65,7 @@ refMsgHash = 16*16(OCTET) ; SHA256 of agent message body
|
||||
' x.grp.mem.inv 23456,234 x.text:NNN <invitation> '
|
||||
' x.grp.mem.req 23456,123 x.json:NNN {...} '
|
||||
' x.grp.mem.direct.inv 23456,234 x.text:NNN <invitation> '
|
||||
' x.file name,size x.text:NNN <invitation> '
|
||||
```
|
||||
|
||||
### Group protocol
|
||||
|
@ -43,8 +43,7 @@ extra-deps:
|
||||
# - simplexmq-0.3.1@sha256:f247aaff3c16c5d3974a4ab4d5882ab50ac78073110997c0bceb05a74d10a325,6688
|
||||
# - ../simplexmq
|
||||
- github: simplex-chat/simplexmq
|
||||
commit: dd5137c336d5525c38b068d7212964b4ab196a33
|
||||
# this commit is in PR #164
|
||||
commit: 2ac903a2dd37c11a8612b19cd132cf43fe771fe4
|
||||
#
|
||||
# extra-deps: []
|
||||
|
||||
|
@ -15,7 +15,7 @@ import Control.Monad.Except
|
||||
import Data.List (dropWhileEnd)
|
||||
import Network.Socket
|
||||
import Simplex.Chat
|
||||
import Simplex.Chat.Controller (ChatController (..))
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..))
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Types (Profile)
|
||||
@ -145,9 +145,11 @@ serverCfg =
|
||||
ServerConfig
|
||||
{ transports = [(serverPort, transport @TCP)],
|
||||
tbqSize = 1,
|
||||
msgQueueQuota = 4,
|
||||
queueIdBytes = 12,
|
||||
msgIdBytes = 6,
|
||||
storeLog = Nothing,
|
||||
blockSize = 4096,
|
||||
serverPrivateKey =
|
||||
-- full RSA private key (only for tests)
|
||||
"MIIFIwIBAAKCAQEArZyrri/NAwt5buvYjwu+B/MQeJUszDBpRgVqNddlI9kNwDXu\
|
||||
|
@ -7,10 +7,13 @@ module ChatTests where
|
||||
import ChatClient
|
||||
import Control.Concurrent.Async (concurrently_)
|
||||
import Control.Concurrent.STM
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Char (isDigit)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Types (Profile (..), User (..))
|
||||
import Simplex.Chat.Util (unlessM)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.Timeout (timeout)
|
||||
import Test.Hspec
|
||||
|
||||
@ -37,6 +40,10 @@ chatTests = do
|
||||
it "remove contact from group and add again" testGroupRemoveAdd
|
||||
describe "user profiles" $
|
||||
it "update user profiles and notify contacts" testUpdateProfile
|
||||
describe "sending and receiving files" $ do
|
||||
it "send and receive file" testFileTransfer
|
||||
it "sender cancelled file transfer" testFileSndCancel
|
||||
it "recipient cancelled file transfer" testFileRcvCancel
|
||||
|
||||
testAddContact :: IO ()
|
||||
testAddContact =
|
||||
@ -359,7 +366,7 @@ testUpdateProfile =
|
||||
createGroup3 "team" alice bob cath
|
||||
alice ##> "/p"
|
||||
alice <## "user profile: alice (Alice)"
|
||||
alice <## "use /p <display name>[ <full name>] to change it"
|
||||
alice <## "use /p <display name> [<full name>] to change it"
|
||||
alice <## "(the updated profile will be sent to all your contacts)"
|
||||
alice ##> "/p alice"
|
||||
concurrentlyN_
|
||||
@ -394,6 +401,87 @@ testUpdateProfile =
|
||||
bob <## "use @cat <message> to send messages"
|
||||
]
|
||||
|
||||
testFileTransfer :: IO ()
|
||||
testFileTransfer =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
connectUsers alice bob
|
||||
startFileTransfer alice bob
|
||||
concurrentlyN_
|
||||
[ do
|
||||
bob #> "@alice receiving here..."
|
||||
bob <## "completed receiving the file 1",
|
||||
do
|
||||
alice <# "bob> receiving here..."
|
||||
alice <## "completed sending the file 1"
|
||||
]
|
||||
src <- B.readFile "./tests/fixtures/test.jpg"
|
||||
dest <- B.readFile "./tests/tmp/test.jpg"
|
||||
dest `shouldBe` src
|
||||
|
||||
testFileSndCancel :: IO ()
|
||||
testFileSndCancel =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
connectUsers alice bob
|
||||
startFileTransfer alice bob
|
||||
alice ##> "/fc 1"
|
||||
concurrentlyN_
|
||||
[ do
|
||||
alice <## "cancelled sending the file 1"
|
||||
alice ##> "/fs 1"
|
||||
alice <## "sent file transfer is cancelled",
|
||||
do
|
||||
bob <## "sender cancelled sending the file 1"
|
||||
bob ##> "/fs 1"
|
||||
bob <## "received file transfer is cancelled, received part path: ./tests/tmp/test.jpg"
|
||||
]
|
||||
checkPartialTransfer
|
||||
|
||||
testFileRcvCancel :: IO ()
|
||||
testFileRcvCancel =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
connectUsers alice bob
|
||||
startFileTransfer alice bob
|
||||
bob ##> "/fs 1"
|
||||
getTermLine bob >>= (`shouldStartWith` "received file transfer progress:")
|
||||
waitFileExists "./tests/tmp/test.jpg"
|
||||
bob ##> "/fc 1"
|
||||
concurrentlyN_
|
||||
[ do
|
||||
bob <## "cancelled receiving the file 1"
|
||||
bob ##> "/fs 1"
|
||||
bob <## "received file transfer is cancelled, received part path: ./tests/tmp/test.jpg",
|
||||
do
|
||||
alice <## "recipient cancelled receiving the file 1"
|
||||
alice ##> "/fs 1"
|
||||
alice <## "sent file transfer is cancelled"
|
||||
]
|
||||
checkPartialTransfer
|
||||
where
|
||||
waitFileExists f = unlessM (doesFileExist f) $ waitFileExists f
|
||||
|
||||
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 <## "use /fc 1 to cancel sending"
|
||||
bob <## "alice wants to send you the 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"
|
||||
concurrently_
|
||||
(bob <## "started receiving the file 1")
|
||||
(alice <## "started sending the file 1")
|
||||
|
||||
checkPartialTransfer :: IO ()
|
||||
checkPartialTransfer = do
|
||||
src <- B.readFile "./tests/fixtures/test.jpg"
|
||||
dest <- B.readFile "./tests/tmp/test.jpg"
|
||||
B.unpack src `shouldStartWith` B.unpack dest
|
||||
B.length src > B.length dest `shouldBe` True
|
||||
|
||||
connectUsers :: TestCC -> TestCC -> IO ()
|
||||
connectUsers cc1 cc2 = do
|
||||
name1 <- showName cc1
|
||||
|
BIN
tests/fixtures/test.jpg
vendored
Normal file
BIN
tests/fixtures/test.jpg
vendored
Normal file
Binary file not shown.
After Width: | Height: | Size: 136 KiB |
Loading…
Reference in New Issue
Block a user