diff --git a/migrations/20210612_initial.sql b/migrations/20210612_initial.sql index 86abb601c..933ab1e60 100644 --- a/migrations/20210612_initial.sql +++ b/migrations/20210612_initial.sql @@ -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 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 4db11757e..f8023291f 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -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) diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index b67bfbab7..ae6dfd5e7 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -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) diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index ee79c40aa..2ccb8289c 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -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) -> diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index a5f529eb5..4896ea56e 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -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 diff --git a/src/Simplex/Chat/Styled.hs b/src/Simplex/Chat/Styled.hs index 9bbb88d27..f7a3a80ac 100644 --- a/src/Simplex/Chat/Styled.hs +++ b/src/Simplex/Chat/Styled.hs @@ -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] diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 94708cdf9..b73deab15 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -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, diff --git a/src/Simplex/Chat/Util.hs b/src/Simplex/Chat/Util.hs index d2fe0c3d4..05ea20cf8 100644 --- a/src/Simplex/Chat/Util.hs +++ b/src/Simplex/Chat/Util.hs @@ -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 () diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 608cac481..5139a94d9 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -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 [ ]" <> " to change it", + "use " <> highlight' "/p []" <> " 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 <> " [/ | ]") <> " 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) diff --git a/src/Simplex/Chat/protocol.md b/src/Simplex/Chat/protocol.md index bd761ec46..111319c59 100644 --- a/src/Simplex/Chat/protocol.md +++ b/src/Simplex/Chat/protocol.md @@ -65,6 +65,7 @@ refMsgHash = 16*16(OCTET) ; SHA256 of agent message body ' x.grp.mem.inv 23456,234 x.text:NNN ' ' x.grp.mem.req 23456,123 x.json:NNN {...} ' ' x.grp.mem.direct.inv 23456,234 x.text:NNN ' +' x.file name,size x.text:NNN ' ``` ### Group protocol diff --git a/stack.yaml b/stack.yaml index 2d17c5d3a..9a58b8394 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: [] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 5b266e8c7..eff8ff6c1 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -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\ diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index ad5c4ff08..0afdf62ef 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -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 [ ] to change it" + alice <## "use /p [] 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 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 [/ | ] 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 diff --git a/tests/fixtures/test.jpg b/tests/fixtures/test.jpg new file mode 100644 index 000000000..4a1103059 Binary files /dev/null and b/tests/fixtures/test.jpg differ